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