diff --git a/mex/build/kalman_steady_state.am b/mex/build/kalman_steady_state.am
index 80ed84de6..735c4576c 100644
--- a/mex/build/kalman_steady_state.am
+++ b/mex/build/kalman_steady_state.am
@@ -1,6 +1,5 @@
noinst_PROGRAMS = kalman_steady_state
-kalman_steady_state_LDADD = ../libslicot/libslicot.a
-kalman_steady_state_LDADD +=../libslicot/libauxslicot.a
+kalman_steady_state_LDADD = $(LIBADD_SLICOT)
nodist_kalman_steady_state_SOURCES = $(top_srcdir)/../../sources/kalman_steady_state/kalman_steady_state.cc
diff --git a/mex/build/libslicot.am b/mex/build/libslicot.am
deleted file mode 100644
index d5d9b21ff..000000000
--- a/mex/build/libslicot.am
+++ /dev/null
@@ -1,478 +0,0 @@
-noinst_LIBRARIES = libslicot.a libauxslicot.a
-
-TOPDIR = $(top_srcdir)/../../sources/libslicot
-
-nodist_libslicot_a_SOURCES = \
- $(TOPDIR)/AB01MD.f \
- $(TOPDIR)/AB01ND.f \
- $(TOPDIR)/AB01OD.f \
- $(TOPDIR)/AB04MD.f \
- $(TOPDIR)/AB05MD.f \
- $(TOPDIR)/AB05ND.f \
- $(TOPDIR)/AB05OD.f \
- $(TOPDIR)/AB05PD.f \
- $(TOPDIR)/AB05QD.f \
- $(TOPDIR)/AB05RD.f \
- $(TOPDIR)/AB05SD.f \
- $(TOPDIR)/AB07MD.f \
- $(TOPDIR)/AB07ND.f \
- $(TOPDIR)/AB08MD.f \
- $(TOPDIR)/AB08MZ.f \
- $(TOPDIR)/AB08ND.f \
- $(TOPDIR)/AB08NX.f \
- $(TOPDIR)/AB08NZ.f \
- $(TOPDIR)/AB09AD.f \
- $(TOPDIR)/AB09AX.f \
- $(TOPDIR)/AB09BD.f \
- $(TOPDIR)/AB09BX.f \
- $(TOPDIR)/AB09CD.f \
- $(TOPDIR)/AB09CX.f \
- $(TOPDIR)/AB09DD.f \
- $(TOPDIR)/AB09ED.f \
- $(TOPDIR)/AB09FD.f \
- $(TOPDIR)/AB09GD.f \
- $(TOPDIR)/AB09HD.f \
- $(TOPDIR)/AB09HX.f \
- $(TOPDIR)/AB09HY.f \
- $(TOPDIR)/AB09ID.f \
- $(TOPDIR)/AB09IX.f \
- $(TOPDIR)/AB09IY.f \
- $(TOPDIR)/AB09JD.f \
- $(TOPDIR)/AB09JV.f \
- $(TOPDIR)/AB09JW.f \
- $(TOPDIR)/AB09JX.f \
- $(TOPDIR)/AB09KD.f \
- $(TOPDIR)/AB09KX.f \
- $(TOPDIR)/AB09MD.f \
- $(TOPDIR)/AB09ND.f \
- $(TOPDIR)/AB13AD.f \
- $(TOPDIR)/AB13AX.f \
- $(TOPDIR)/AB13BD.f \
- $(TOPDIR)/AB13CD.f \
- $(TOPDIR)/AB13DD.f \
- $(TOPDIR)/AB13DX.f \
- $(TOPDIR)/AB13ED.f \
- $(TOPDIR)/AB13FD.f \
- $(TOPDIR)/AB13MD.f \
- $(TOPDIR)/AB8NXZ.f \
- $(TOPDIR)/AG07BD.f \
- $(TOPDIR)/AG08BD.f \
- $(TOPDIR)/AG08BY.f \
- $(TOPDIR)/AG08BZ.f \
- $(TOPDIR)/AG8BYZ.f \
- $(TOPDIR)/BB01AD.f \
- $(TOPDIR)/BB02AD.f \
- $(TOPDIR)/BB03AD.f \
- $(TOPDIR)/BB04AD.f \
- $(TOPDIR)/BD01AD.f \
- $(TOPDIR)/BD02AD.f \
- $(TOPDIR)/DE01OD.f \
- $(TOPDIR)/DE01PD.f \
- $(TOPDIR)/delctg.f \
- $(TOPDIR)/DF01MD.f \
- $(TOPDIR)/DG01MD.f \
- $(TOPDIR)/DG01ND.f \
- $(TOPDIR)/DG01NY.f \
- $(TOPDIR)/DG01OD.f \
- $(TOPDIR)/DK01MD.f \
- $(TOPDIR)/FB01QD.f \
- $(TOPDIR)/FB01RD.f \
- $(TOPDIR)/FB01SD.f \
- $(TOPDIR)/FB01TD.f \
- $(TOPDIR)/FB01VD.f \
- $(TOPDIR)/FD01AD.f \
- $(TOPDIR)/IB01AD.f \
- $(TOPDIR)/IB01BD.f \
- $(TOPDIR)/IB01CD.f \
- $(TOPDIR)/IB01MD.f \
- $(TOPDIR)/IB01MY.f \
- $(TOPDIR)/IB01ND.f \
- $(TOPDIR)/IB01OD.f \
- $(TOPDIR)/IB01OY.f \
- $(TOPDIR)/IB01PD.f \
- $(TOPDIR)/IB01PX.f \
- $(TOPDIR)/IB01PY.f \
- $(TOPDIR)/IB01QD.f \
- $(TOPDIR)/IB01RD.f \
- $(TOPDIR)/IB03AD.f \
- $(TOPDIR)/IB03BD.f \
- $(TOPDIR)/MA01AD.f \
- $(TOPDIR)/MA02AD.f \
- $(TOPDIR)/MA02BD.f \
- $(TOPDIR)/MA02BZ.f \
- $(TOPDIR)/MA02CD.f \
- $(TOPDIR)/MA02CZ.f \
- $(TOPDIR)/MA02DD.f \
- $(TOPDIR)/MA02ED.f \
- $(TOPDIR)/MA02FD.f \
- $(TOPDIR)/MA02GD.f \
- $(TOPDIR)/MA02HD.f \
- $(TOPDIR)/MA02ID.f \
- $(TOPDIR)/MA02JD.f \
- $(TOPDIR)/MB01MD.f \
- $(TOPDIR)/MB01ND.f \
- $(TOPDIR)/MB01PD.f \
- $(TOPDIR)/MB01QD.f \
- $(TOPDIR)/MB01RD.f \
- $(TOPDIR)/MB01RU.f \
- $(TOPDIR)/MB01RW.f \
- $(TOPDIR)/MB01RX.f \
- $(TOPDIR)/MB01RY.f \
- $(TOPDIR)/MB01SD.f \
- $(TOPDIR)/MB01TD.f \
- $(TOPDIR)/MB01UD.f \
- $(TOPDIR)/MB01UW.f \
- $(TOPDIR)/MB01UX.f \
- $(TOPDIR)/MB01VD.f \
- $(TOPDIR)/MB01WD.f \
- $(TOPDIR)/MB01XD.f \
- $(TOPDIR)/MB01XY.f \
- $(TOPDIR)/MB01YD.f \
- $(TOPDIR)/MB01ZD.f \
- $(TOPDIR)/MB02CD.f \
- $(TOPDIR)/MB02CU.f \
- $(TOPDIR)/MB02CV.f \
- $(TOPDIR)/MB02CX.f \
- $(TOPDIR)/MB02CY.f \
- $(TOPDIR)/MB02DD.f \
- $(TOPDIR)/MB02ED.f \
- $(TOPDIR)/MB02FD.f \
- $(TOPDIR)/MB02GD.f \
- $(TOPDIR)/MB02HD.f \
- $(TOPDIR)/MB02ID.f \
- $(TOPDIR)/MB02JD.f \
- $(TOPDIR)/MB02JX.f \
- $(TOPDIR)/MB02KD.f \
- $(TOPDIR)/MB02MD.f \
- $(TOPDIR)/MB02ND.f \
- $(TOPDIR)/MB02NY.f \
- $(TOPDIR)/MB02OD.f \
- $(TOPDIR)/MB02PD.f \
- $(TOPDIR)/MB02QD.f \
- $(TOPDIR)/MB02QY.f \
- $(TOPDIR)/MB02RD.f \
- $(TOPDIR)/MB02RZ.f \
- $(TOPDIR)/MB02SD.f \
- $(TOPDIR)/MB02SZ.f \
- $(TOPDIR)/MB02TD.f \
- $(TOPDIR)/MB02TZ.f \
- $(TOPDIR)/MB02UD.f \
- $(TOPDIR)/MB02UU.f \
- $(TOPDIR)/MB02UV.f \
- $(TOPDIR)/MB02VD.f \
- $(TOPDIR)/MB02WD.f \
- $(TOPDIR)/MB02XD.f \
- $(TOPDIR)/MB02YD.f \
- $(TOPDIR)/MB03MD.f \
- $(TOPDIR)/MB03MY.f \
- $(TOPDIR)/MB03ND.f \
- $(TOPDIR)/MB03NY.f \
- $(TOPDIR)/MB03OD.f \
- $(TOPDIR)/MB03OY.f \
- $(TOPDIR)/MB03PD.f \
- $(TOPDIR)/MB03PY.f \
- $(TOPDIR)/MB03QD.f \
- $(TOPDIR)/MB03QX.f \
- $(TOPDIR)/MB03QY.f \
- $(TOPDIR)/MB03RD.f \
- $(TOPDIR)/MB03RX.f \
- $(TOPDIR)/MB03RY.f \
- $(TOPDIR)/MB03SD.f \
- $(TOPDIR)/MB03TD.f \
- $(TOPDIR)/MB03TS.f \
- $(TOPDIR)/MB03UD.f \
- $(TOPDIR)/MB03VD.f \
- $(TOPDIR)/MB03VY.f \
- $(TOPDIR)/MB03WA.f \
- $(TOPDIR)/MB03WD.f \
- $(TOPDIR)/MB03WX.f \
- $(TOPDIR)/MB03XD.f \
- $(TOPDIR)/MB03XP.f \
- $(TOPDIR)/MB03XU.f \
- $(TOPDIR)/MB03YA.f \
- $(TOPDIR)/MB03YD.f \
- $(TOPDIR)/MB03YT.f \
- $(TOPDIR)/MB03ZA.f \
- $(TOPDIR)/MB03ZD.f \
- $(TOPDIR)/MB04DD.f \
- $(TOPDIR)/MB04DI.f \
- $(TOPDIR)/MB04DS.f \
- $(TOPDIR)/MB04DY.f \
- $(TOPDIR)/MB04GD.f \
- $(TOPDIR)/MB04ID.f \
- $(TOPDIR)/MB04IY.f \
- $(TOPDIR)/MB04IZ.f \
- $(TOPDIR)/MB04JD.f \
- $(TOPDIR)/MB04KD.f \
- $(TOPDIR)/MB04LD.f \
- $(TOPDIR)/MB04MD.f \
- $(TOPDIR)/MB04ND.f \
- $(TOPDIR)/MB04NY.f \
- $(TOPDIR)/MB04OD.f \
- $(TOPDIR)/MB04OW.f \
- $(TOPDIR)/MB04OX.f \
- $(TOPDIR)/MB04OY.f \
- $(TOPDIR)/MB04PA.f \
- $(TOPDIR)/MB04PB.f \
- $(TOPDIR)/MB04PU.f \
- $(TOPDIR)/MB04PY.f \
- $(TOPDIR)/MB04QB.f \
- $(TOPDIR)/MB04QC.f \
- $(TOPDIR)/MB04QF.f \
- $(TOPDIR)/MB04QU.f \
- $(TOPDIR)/MB04TB.f \
- $(TOPDIR)/MB04TS.f \
- $(TOPDIR)/MB04TT.f \
- $(TOPDIR)/MB04TU.f \
- $(TOPDIR)/MB04TV.f \
- $(TOPDIR)/MB04TW.f \
- $(TOPDIR)/MB04TX.f \
- $(TOPDIR)/MB04TY.f \
- $(TOPDIR)/MB04UD.f \
- $(TOPDIR)/MB04VD.f \
- $(TOPDIR)/MB04VX.f \
- $(TOPDIR)/MB04WD.f \
- $(TOPDIR)/MB04WP.f \
- $(TOPDIR)/MB04WR.f \
- $(TOPDIR)/MB04WU.f \
- $(TOPDIR)/MB04XD.f \
- $(TOPDIR)/MB04XY.f \
- $(TOPDIR)/MB04YD.f \
- $(TOPDIR)/MB04YW.f \
- $(TOPDIR)/MB04ZD.f \
- $(TOPDIR)/MB05MD.f \
- $(TOPDIR)/MB05MY.f \
- $(TOPDIR)/MB05ND.f \
- $(TOPDIR)/MB05OD.f \
- $(TOPDIR)/MB05OY.f \
- $(TOPDIR)/MB3OYZ.f \
- $(TOPDIR)/MB3PYZ.f \
- $(TOPDIR)/MC01MD.f \
- $(TOPDIR)/MC01ND.f \
- $(TOPDIR)/MC01OD.f \
- $(TOPDIR)/MC01PD.f \
- $(TOPDIR)/MC01PY.f \
- $(TOPDIR)/MC01QD.f \
- $(TOPDIR)/MC01RD.f \
- $(TOPDIR)/MC01SD.f \
- $(TOPDIR)/MC01SW.f \
- $(TOPDIR)/MC01SX.f \
- $(TOPDIR)/MC01SY.f \
- $(TOPDIR)/MC01TD.f \
- $(TOPDIR)/MC01VD.f \
- $(TOPDIR)/MC01WD.f \
- $(TOPDIR)/MC03MD.f \
- $(TOPDIR)/MC03ND.f \
- $(TOPDIR)/MC03NX.f \
- $(TOPDIR)/MC03NY.f \
- $(TOPDIR)/MD03AD.f \
- $(TOPDIR)/MD03BA.f \
- $(TOPDIR)/MD03BB.f \
- $(TOPDIR)/MD03BD.f \
- $(TOPDIR)/MD03BF.f \
- $(TOPDIR)/MD03BX.f \
- $(TOPDIR)/MD03BY.f \
- $(TOPDIR)/NF01AD.f \
- $(TOPDIR)/NF01AY.f \
- $(TOPDIR)/NF01BA.f \
- $(TOPDIR)/NF01BB.f \
- $(TOPDIR)/NF01BD.f \
- $(TOPDIR)/NF01BE.f \
- $(TOPDIR)/NF01BF.f \
- $(TOPDIR)/NF01BP.f \
- $(TOPDIR)/NF01BQ.f \
- $(TOPDIR)/NF01BR.f \
- $(TOPDIR)/NF01BS.f \
- $(TOPDIR)/NF01BU.f \
- $(TOPDIR)/NF01BV.f \
- $(TOPDIR)/NF01BW.f \
- $(TOPDIR)/NF01BX.f \
- $(TOPDIR)/NF01BY.f \
- $(TOPDIR)/SB01BD.f \
- $(TOPDIR)/SB01BX.f \
- $(TOPDIR)/SB01BY.f \
- $(TOPDIR)/SB01DD.f \
- $(TOPDIR)/SB01FY.f \
- $(TOPDIR)/SB01MD.f \
- $(TOPDIR)/SB02CX.f \
- $(TOPDIR)/SB02MD.f \
- $(TOPDIR)/SB02MR.f \
- $(TOPDIR)/SB02MS.f \
- $(TOPDIR)/SB02MT.f \
- $(TOPDIR)/SB02MU.f \
- $(TOPDIR)/SB02MV.f \
- $(TOPDIR)/SB02MW.f \
- $(TOPDIR)/SB02ND.f \
- $(TOPDIR)/SB02OD.f \
- $(TOPDIR)/SB02OU.f \
- $(TOPDIR)/SB02OV.f \
- $(TOPDIR)/SB02OW.f \
- $(TOPDIR)/SB02OX.f \
- $(TOPDIR)/SB02OY.f \
- $(TOPDIR)/SB02PD.f \
- $(TOPDIR)/SB02QD.f \
- $(TOPDIR)/SB02RD.f \
- $(TOPDIR)/SB02RU.f \
- $(TOPDIR)/SB02SD.f \
- $(TOPDIR)/SB03MD.f \
- $(TOPDIR)/SB03MU.f \
- $(TOPDIR)/SB03MV.f \
- $(TOPDIR)/SB03MW.f \
- $(TOPDIR)/SB03MX.f \
- $(TOPDIR)/SB03MY.f \
- $(TOPDIR)/SB03OD.f \
- $(TOPDIR)/SB03OR.f \
- $(TOPDIR)/SB03OT.f \
- $(TOPDIR)/SB03OU.f \
- $(TOPDIR)/SB03OV.f \
- $(TOPDIR)/SB03OY.f \
- $(TOPDIR)/SB03PD.f \
- $(TOPDIR)/SB03QD.f \
- $(TOPDIR)/SB03QX.f \
- $(TOPDIR)/SB03QY.f \
- $(TOPDIR)/SB03RD.f \
- $(TOPDIR)/SB03SD.f \
- $(TOPDIR)/SB03SX.f \
- $(TOPDIR)/SB03SY.f \
- $(TOPDIR)/SB03TD.f \
- $(TOPDIR)/SB03UD.f \
- $(TOPDIR)/SB04MD.f \
- $(TOPDIR)/SB04MR.f \
- $(TOPDIR)/SB04MU.f \
- $(TOPDIR)/SB04MW.f \
- $(TOPDIR)/SB04MY.f \
- $(TOPDIR)/SB04ND.f \
- $(TOPDIR)/SB04NV.f \
- $(TOPDIR)/SB04NW.f \
- $(TOPDIR)/SB04NX.f \
- $(TOPDIR)/SB04NY.f \
- $(TOPDIR)/SB04OD.f \
- $(TOPDIR)/SB04OW.f \
- $(TOPDIR)/SB04PD.f \
- $(TOPDIR)/SB04PX.f \
- $(TOPDIR)/SB04PY.f \
- $(TOPDIR)/SB04QD.f \
- $(TOPDIR)/SB04QR.f \
- $(TOPDIR)/SB04QU.f \
- $(TOPDIR)/SB04QY.f \
- $(TOPDIR)/SB04RD.f \
- $(TOPDIR)/SB04RV.f \
- $(TOPDIR)/SB04RW.f \
- $(TOPDIR)/SB04RX.f \
- $(TOPDIR)/SB04RY.f \
- $(TOPDIR)/SB06ND.f \
- $(TOPDIR)/SB08CD.f \
- $(TOPDIR)/SB08DD.f \
- $(TOPDIR)/SB08ED.f \
- $(TOPDIR)/SB08FD.f \
- $(TOPDIR)/SB08GD.f \
- $(TOPDIR)/SB08HD.f \
- $(TOPDIR)/SB08MD.f \
- $(TOPDIR)/SB08MY.f \
- $(TOPDIR)/SB08ND.f \
- $(TOPDIR)/SB08NY.f \
- $(TOPDIR)/SB09MD.f \
- $(TOPDIR)/SB10AD.f \
- $(TOPDIR)/SB10DD.f \
- $(TOPDIR)/SB10ED.f \
- $(TOPDIR)/SB10FD.f \
- $(TOPDIR)/SB10HD.f \
- $(TOPDIR)/SB10ID.f \
- $(TOPDIR)/SB10JD.f \
- $(TOPDIR)/SB10KD.f \
- $(TOPDIR)/SB10LD.f \
- $(TOPDIR)/SB10MD.f \
- $(TOPDIR)/SB10PD.f \
- $(TOPDIR)/SB10QD.f \
- $(TOPDIR)/SB10RD.f \
- $(TOPDIR)/SB10SD.f \
- $(TOPDIR)/SB10TD.f \
- $(TOPDIR)/SB10UD.f \
- $(TOPDIR)/SB10VD.f \
- $(TOPDIR)/SB10WD.f \
- $(TOPDIR)/SB10YD.f \
- $(TOPDIR)/SB10ZD.f \
- $(TOPDIR)/SB10ZP.f \
- $(TOPDIR)/SB16AD.f \
- $(TOPDIR)/SB16AY.f \
- $(TOPDIR)/SB16BD.f \
- $(TOPDIR)/SB16CD.f \
- $(TOPDIR)/SB16CY.f \
- $(TOPDIR)/select.f \
- $(TOPDIR)/SG02AD.f \
- $(TOPDIR)/SG03AD.f \
- $(TOPDIR)/SG03AX.f \
- $(TOPDIR)/SG03AY.f \
- $(TOPDIR)/SG03BD.f \
- $(TOPDIR)/SG03BU.f \
- $(TOPDIR)/SG03BV.f \
- $(TOPDIR)/SG03BW.f \
- $(TOPDIR)/SG03BX.f \
- $(TOPDIR)/SG03BY.f \
- $(TOPDIR)/TB01ID.f \
- $(TOPDIR)/TB01IZ.f \
- $(TOPDIR)/TB01KD.f \
- $(TOPDIR)/TB01LD.f \
- $(TOPDIR)/TB01MD.f \
- $(TOPDIR)/TB01ND.f \
- $(TOPDIR)/TB01PD.f \
- $(TOPDIR)/TB01TD.f \
- $(TOPDIR)/TB01TY.f \
- $(TOPDIR)/TB01UD.f \
- $(TOPDIR)/TB01VD.f \
- $(TOPDIR)/TB01VY.f \
- $(TOPDIR)/TB01WD.f \
- $(TOPDIR)/TB01XD.f \
- $(TOPDIR)/TB01XZ.f \
- $(TOPDIR)/TB01YD.f \
- $(TOPDIR)/TB01ZD.f \
- $(TOPDIR)/TB03AD.f \
- $(TOPDIR)/TB03AY.f \
- $(TOPDIR)/TB04AD.f \
- $(TOPDIR)/TB04AY.f \
- $(TOPDIR)/TB04BD.f \
- $(TOPDIR)/TB04BV.f \
- $(TOPDIR)/TB04BW.f \
- $(TOPDIR)/TB04BX.f \
- $(TOPDIR)/TB04CD.f \
- $(TOPDIR)/TB05AD.f \
- $(TOPDIR)/TC01OD.f \
- $(TOPDIR)/TC04AD.f \
- $(TOPDIR)/TC05AD.f \
- $(TOPDIR)/TD03AD.f \
- $(TOPDIR)/TD03AY.f \
- $(TOPDIR)/TD04AD.f \
- $(TOPDIR)/TD05AD.f \
- $(TOPDIR)/TF01MD.f \
- $(TOPDIR)/TF01MX.f \
- $(TOPDIR)/TF01MY.f \
- $(TOPDIR)/TF01ND.f \
- $(TOPDIR)/TF01OD.f \
- $(TOPDIR)/TF01PD.f \
- $(TOPDIR)/TF01QD.f \
- $(TOPDIR)/TF01RD.f \
- $(TOPDIR)/TG01AD.f \
- $(TOPDIR)/TG01AZ.f \
- $(TOPDIR)/TG01BD.f \
- $(TOPDIR)/TG01CD.f \
- $(TOPDIR)/TG01DD.f \
- $(TOPDIR)/TG01ED.f \
- $(TOPDIR)/TG01FD.f \
- $(TOPDIR)/TG01FZ.f \
- $(TOPDIR)/TG01HD.f \
- $(TOPDIR)/TG01HX.f \
- $(TOPDIR)/TG01ID.f \
- $(TOPDIR)/TG01JD.f \
- $(TOPDIR)/TG01WD.f \
- $(TOPDIR)/UD01BD.f \
- $(TOPDIR)/UD01CD.f \
- $(TOPDIR)/UD01DD.f \
- $(TOPDIR)/UD01MD.f \
- $(TOPDIR)/UD01MZ.f \
- $(TOPDIR)/UD01ND.f \
- $(TOPDIR)/UE01MD.f
-
-nodist_libauxslicot_a_SOURCES = \
- $(TOPDIR)/dcabs1.f \
- $(TOPDIR)/dhgeqz.f \
- $(TOPDIR)/dtgsy2.f
diff --git a/mex/build/matlab/Makefile.am b/mex/build/matlab/Makefile.am
index 82904454f..ae91caf93 100644
--- a/mex/build/matlab/Makefile.am
+++ b/mex/build/matlab/Makefile.am
@@ -8,9 +8,8 @@ if HAVE_GSL
SUBDIRS += ms_sbvar
endif
-# libslicot must come before kalman_steady_state
-if HAVE_FORT
-SUBDIRS += libslicot kalman_steady_state
+if HAVE_SLICOT
+SUBDIRS += kalman_steady_state
endif
if HAVE_M2HTML
diff --git a/mex/build/matlab/configure.ac b/mex/build/matlab/configure.ac
index ca948b4db..0072c6704 100644
--- a/mex/build/matlab/configure.ac
+++ b/mex/build/matlab/configure.ac
@@ -54,7 +54,6 @@ FFLAGS="$FFLAGS -Wall"
CXXFLAGS="$CXXFLAGS -Wall -Wno-parentheses"
AC_PROG_F77([gfortran g77 f77])
-AM_CONDITIONAL([HAVE_FORT], [test "x$F77" != "x"])
AC_PROG_CC
AC_PROG_CXX
AC_PROG_RANLIB
@@ -77,6 +76,27 @@ AC_SUBST([LIBADD_DLOPEN])
AX_GSL
AM_CONDITIONAL([HAVE_GSL], [test "x$has_gsl" = "xyes"])
+# Check for libslicot, needed by kalman_steady_state
+AC_F77_FUNC(sb02od)
+LDFLAGS_SAVED=$LDFLAGS
+LDFLAGS=$MATLAB_LDFLAGS
+case ${MATLAB_ARCH} in
+ glnxa64 | win64 | maci64)
+ AX_COMPARE_VERSION([$MATLAB_VERSION], [ge], [7.8], [use_64_bit_indexing=yes], [use_64_bit_indexing=no])
+ ;;
+ *)
+ use_64_bit_indexing=no
+ ;;
+esac
+if test "$use_64_bit_indexing" = "yes"; then
+ AC_CHECK_LIB([slicot64_pic], [$sb02od], [LIBADD_SLICOT="-lslicot64_pic"], [], [$MATLAB_LIBS])
+else
+ AC_CHECK_LIB([slicot_pic], [$sb02od], [LIBADD_SLICOT="-lslicot_pic"], [], [$MATLAB_LIBS])
+fi
+LDFLAGS=$LDFLAGS_SAVED
+AC_SUBST([LIBADD_SLICOT])
+AM_CONDITIONAL([HAVE_SLICOT], [test "x$LIBADD_SLICOT" != "x"])
+
AM_CONDITIONAL([DO_SOMETHING], [test "x$ax_enable_matlab" = "xyes" -a "x$ax_matlab_version_ok" = "xyes" -a "x$ax_mexopts_ok" = "xyes"])
if test "x$ax_enable_matlab" = "xyes" -a "x$ax_matlab_version_ok" = "xyes" -a "x$ax_mexopts_ok" = "xyes"; then
@@ -89,10 +109,10 @@ else
BUILD_MEX_MATLAB="no (missing MATLAB, or unknown version, or unknown architecture)"
fi
-if test "x$ax_enable_matlab" = "xyes" -a "x$ax_matlab_version_ok" = "xyes" -a "x$ax_mexopts_ok" = "xyes" -a "x$F77" != "x"; then
+if test "x$ax_enable_matlab" = "xyes" -a "x$ax_matlab_version_ok" = "xyes" -a "x$ax_mexopts_ok" = "xyes" -a "x$LIBADD_SLICOT" != "x"; then
BUILD_KALMAN_STEADY_STATE_MATLAB="yes"
else
- BUILD_KALMAN_STEADY_STATE_MATLAB="no (missing Fortran Compiler for compilation of libslicot)"
+ BUILD_KALMAN_STEADY_STATE_MATLAB="no (missing SLICOT)"
fi
if test "x$ax_enable_matlab" = "xyes" -a "x$ax_matlab_version_ok" = "xyes" -a "x$ax_mexopts_ok" = "xyes" -a "x$has_gsl" = "xyes"; then
@@ -140,7 +160,6 @@ AC_CONFIG_FILES([Makefile
k_order_perturbation/Makefile
dynare_simul_/Makefile
estimation/Makefile
- libslicot/Makefile
kalman_steady_state/Makefile
ms_sbvar/Makefile
block_kalman_filter/Makefile
diff --git a/mex/build/matlab/libslicot/Makefile.am b/mex/build/matlab/libslicot/Makefile.am
deleted file mode 100644
index 680519fea..000000000
--- a/mex/build/matlab/libslicot/Makefile.am
+++ /dev/null
@@ -1,2 +0,0 @@
-include ../mex.am
-include ../../libslicot.am
diff --git a/mex/build/octave/Makefile.am b/mex/build/octave/Makefile.am
index 2689afab4..2b99916b8 100644
--- a/mex/build/octave/Makefile.am
+++ b/mex/build/octave/Makefile.am
@@ -10,9 +10,8 @@ SUBDIRS += ms_sbvar
endif
endif
-# libslicot must come before kalman_steady_state
-if HAVE_FORT
-SUBDIRS += libslicot kalman_steady_state
+if HAVE_SLICOT
+SUBDIRS += kalman_steady_state
endif
if HAVE_MATIO
diff --git a/mex/build/octave/configure.ac b/mex/build/octave/configure.ac
index 0a1362799..187ae8a63 100644
--- a/mex/build/octave/configure.ac
+++ b/mex/build/octave/configure.ac
@@ -37,7 +37,6 @@ FFLAGS="$FFLAGS -Wall"
CXXFLAGS="$CXXFLAGS -Wall -Wno-parentheses"
AC_PROG_F77([gfortran g77 f77])
-AM_CONDITIONAL([HAVE_FORT], [test "x$F77" != "x"])
AC_PROG_CC
AC_PROG_CXX
AC_PROG_RANLIB
@@ -66,6 +65,14 @@ AC_CHECK_LIB([matio], [Mat_Open], [LIBADD_MATIO="-lmatio"])
AC_SUBST([LIBADD_MATIO])
AM_CONDITIONAL([HAVE_MATIO], [test "x$ac_cv_header_matio_h" = "xyes" -a "x$ac_cv_lib_matio_Mat_Open" = "xyes"])
+# Check for libslicot, needed by kalman_steady_state
+AC_F77_FUNC(sb02od)
+AC_CHECK_LIB([slicot], [$sb02od], [LIBADD_SLICOT="-lslicot"],
+ [AC_CHECK_LIB([slicot_pic], [$sb02od], [LIBADD_SLICOT="-lslicot_pic"], [], [`$MKOCTFILE -p BLAS_LIBS` `$MKOCTFILE -p LAPACK_LIBS`])], # Fallback on libslicot_pic if dynamic libslicot not found
+ [`$MKOCTFILE -p BLAS_LIBS` `$MKOCTFILE -p LAPACK_LIBS`])
+AC_SUBST([LIBADD_SLICOT])
+AM_CONDITIONAL([HAVE_SLICOT], [test "x$LIBADD_SLICOT" != "x"])
+
AM_CONDITIONAL([DO_SOMETHING], [test "x$MKOCTFILE" != "x"])
if test "x$MKOCTFILE" != "x"; then
@@ -84,10 +91,10 @@ else
BUILD_ESTIMATION_MEX_OCTAVE="no (missing MatIO library)"
fi
-if test "x$MKOCTFILE" != "x" -a "x$F77" != "x"; then
+if test "x$MKOCTFILE" != "x" -a "x$LIBADD_SLICOT" != "x"; then
BUILD_KALMAN_STEADY_STATE_OCTAVE="yes"
else
- BUILD_KALMAN_STEADY_STATE_OCTAVE="no (missing Fortran Compiler for compilation of libslicot)"
+ BUILD_KALMAN_STEADY_STATE_OCTAVE="no (missing SLICOT)"
fi
if test "x$MKOCTFILE" != "x" -a "x$has_gsl" = "xyes"; then
@@ -127,7 +134,6 @@ AC_CONFIG_FILES([Makefile
estimation/Makefile
qzcomplex/Makefile
ordschur/Makefile
- libslicot/Makefile
kalman_steady_state/Makefile
ms_sbvar/Makefile
block_kalman_filter/Makefile
diff --git a/mex/build/octave/libslicot/Makefile.am b/mex/build/octave/libslicot/Makefile.am
deleted file mode 100644
index 47b05ecff..000000000
--- a/mex/build/octave/libslicot/Makefile.am
+++ /dev/null
@@ -1,3 +0,0 @@
-EXEEXT = .mex
-include ../mex.am
-include ../../libslicot.am
diff --git a/mex/sources/Makefile.am b/mex/sources/Makefile.am
index 57934b164..2d9c6021d 100644
--- a/mex/sources/Makefile.am
+++ b/mex/sources/Makefile.am
@@ -10,7 +10,6 @@ EXTRA_DIST = \
qzcomplex \
k_order_perturbation \
ordschur \
- libslicot \
kalman_steady_state \
ms-sbvar \
block_kalman_filter \
diff --git a/mex/sources/libslicot/AB01MD.f b/mex/sources/libslicot/AB01MD.f
deleted file mode 100644
index d00d02a82..000000000
--- a/mex/sources/libslicot/AB01MD.f
+++ /dev/null
@@ -1,402 +0,0 @@
- 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
deleted file mode 100644
index c6280fcbe..000000000
--- a/mex/sources/libslicot/AB01ND.f
+++ /dev/null
@@ -1,470 +0,0 @@
- 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
deleted file mode 100644
index f85ed5626..000000000
--- a/mex/sources/libslicot/AB01OD.f
+++ /dev/null
@@ -1,535 +0,0 @@
- 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
deleted file mode 100644
index b5856fcd9..000000000
--- a/mex/sources/libslicot/AB04MD.f
+++ /dev/null
@@ -1,345 +0,0 @@
- 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
deleted file mode 100644
index 0324368bf..000000000
--- a/mex/sources/libslicot/AB05MD.f
+++ /dev/null
@@ -1,547 +0,0 @@
- 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
deleted file mode 100644
index 507d6ea16..000000000
--- a/mex/sources/libslicot/AB05ND.f
+++ /dev/null
@@ -1,564 +0,0 @@
- 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
deleted file mode 100644
index 6eafa6949..000000000
--- a/mex/sources/libslicot/AB05OD.f
+++ /dev/null
@@ -1,418 +0,0 @@
- 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
deleted file mode 100644
index 918aed8a0..000000000
--- a/mex/sources/libslicot/AB05PD.f
+++ /dev/null
@@ -1,385 +0,0 @@
- 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
deleted file mode 100644
index c9f54bcaa..000000000
--- a/mex/sources/libslicot/AB05QD.f
+++ /dev/null
@@ -1,419 +0,0 @@
- 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
deleted file mode 100644
index 4592f93d3..000000000
--- a/mex/sources/libslicot/AB05RD.f
+++ /dev/null
@@ -1,393 +0,0 @@
- 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
deleted file mode 100644
index 7cc57b5c7..000000000
--- a/mex/sources/libslicot/AB05SD.f
+++ /dev/null
@@ -1,371 +0,0 @@
- 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
deleted file mode 100644
index da49e2df7..000000000
--- a/mex/sources/libslicot/AB07MD.f
+++ /dev/null
@@ -1,224 +0,0 @@
- 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
deleted file mode 100644
index 86b26d27a..000000000
--- a/mex/sources/libslicot/AB07ND.f
+++ /dev/null
@@ -1,303 +0,0 @@
- 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
deleted file mode 100644
index bd801a617..000000000
--- a/mex/sources/libslicot/AB08MD.f
+++ /dev/null
@@ -1,299 +0,0 @@
- 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
deleted file mode 100644
index 89d8005e7..000000000
--- a/mex/sources/libslicot/AB08MZ.f
+++ /dev/null
@@ -1,303 +0,0 @@
- 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
deleted file mode 100644
index 8fdb139d2..000000000
--- a/mex/sources/libslicot/AB08ND.f
+++ /dev/null
@@ -1,568 +0,0 @@
- 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
deleted file mode 100644
index d67f6a193..000000000
--- a/mex/sources/libslicot/AB08NX.f
+++ /dev/null
@@ -1,446 +0,0 @@
- 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
deleted file mode 100644
index 9638b4bbb..000000000
--- a/mex/sources/libslicot/AB08NZ.f
+++ /dev/null
@@ -1,576 +0,0 @@
- 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
deleted file mode 100644
index 8d04fa633..000000000
--- a/mex/sources/libslicot/AB09AD.f
+++ /dev/null
@@ -1,363 +0,0 @@
- 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
deleted file mode 100644
index 6d333337a..000000000
--- a/mex/sources/libslicot/AB09AX.f
+++ /dev/null
@@ -1,564 +0,0 @@
- 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
deleted file mode 100644
index 0aa01b394..000000000
--- a/mex/sources/libslicot/AB09BD.f
+++ /dev/null
@@ -1,385 +0,0 @@
- 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
deleted file mode 100644
index 438babc5d..000000000
--- a/mex/sources/libslicot/AB09BX.f
+++ /dev/null
@@ -1,662 +0,0 @@
- 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
deleted file mode 100644
index 01567db21..000000000
--- a/mex/sources/libslicot/AB09CD.f
+++ /dev/null
@@ -1,375 +0,0 @@
- 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
deleted file mode 100644
index 7644d7992..000000000
--- a/mex/sources/libslicot/AB09CX.f
+++ /dev/null
@@ -1,558 +0,0 @@
- 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
deleted file mode 100644
index 0ba78924c..000000000
--- a/mex/sources/libslicot/AB09DD.f
+++ /dev/null
@@ -1,278 +0,0 @@
- 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
deleted file mode 100644
index 7c3afb8e4..000000000
--- a/mex/sources/libslicot/AB09ED.f
+++ /dev/null
@@ -1,493 +0,0 @@
- 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
deleted file mode 100644
index cb954ba15..000000000
--- a/mex/sources/libslicot/AB09FD.f
+++ /dev/null
@@ -1,649 +0,0 @@
- 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
deleted file mode 100644
index c55160369..000000000
--- a/mex/sources/libslicot/AB09GD.f
+++ /dev/null
@@ -1,681 +0,0 @@
- 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
deleted file mode 100644
index 1468accc6..000000000
--- a/mex/sources/libslicot/AB09HD.f
+++ /dev/null
@@ -1,671 +0,0 @@
- 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
deleted file mode 100644
index 4bba6fe3b..000000000
--- a/mex/sources/libslicot/AB09HX.f
+++ /dev/null
@@ -1,690 +0,0 @@
- 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
deleted file mode 100644
index 78a1093e6..000000000
--- a/mex/sources/libslicot/AB09HY.f
+++ /dev/null
@@ -1,396 +0,0 @@
- 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
deleted file mode 100644
index 2448d4660..000000000
--- a/mex/sources/libslicot/AB09ID.f
+++ /dev/null
@@ -1,1048 +0,0 @@
- 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
deleted file mode 100644
index f3ad3b395..000000000
--- a/mex/sources/libslicot/AB09IX.f
+++ /dev/null
@@ -1,695 +0,0 @@
- 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
deleted file mode 100644
index 475505219..000000000
--- a/mex/sources/libslicot/AB09IY.f
+++ /dev/null
@@ -1,859 +0,0 @@
- 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
deleted file mode 100644
index 8729aa4e8..000000000
--- a/mex/sources/libslicot/AB09JD.f
+++ /dev/null
@@ -1,1482 +0,0 @@
- 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
deleted file mode 100644
index 5a7d08ab2..000000000
--- a/mex/sources/libslicot/AB09JV.f
+++ /dev/null
@@ -1,958 +0,0 @@
- 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
deleted file mode 100644
index 9c8068428..000000000
--- a/mex/sources/libslicot/AB09JW.f
+++ /dev/null
@@ -1,972 +0,0 @@
- 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
deleted file mode 100644
index 68e2c60dd..000000000
--- a/mex/sources/libslicot/AB09JX.f
+++ /dev/null
@@ -1,253 +0,0 @@
- 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
deleted file mode 100644
index d390cfd6b..000000000
--- a/mex/sources/libslicot/AB09KD.f
+++ /dev/null
@@ -1,864 +0,0 @@
- 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
deleted file mode 100644
index 5ac044c76..000000000
--- a/mex/sources/libslicot/AB09KX.f
+++ /dev/null
@@ -1,869 +0,0 @@
- 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
deleted file mode 100644
index aaa808bfe..000000000
--- a/mex/sources/libslicot/AB09MD.f
+++ /dev/null
@@ -1,474 +0,0 @@
- 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
deleted file mode 100644
index 49ea0c0cd..000000000
--- a/mex/sources/libslicot/AB09ND.f
+++ /dev/null
@@ -1,497 +0,0 @@
- 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
deleted file mode 100644
index fb2b2018e..000000000
--- a/mex/sources/libslicot/AB13AD.f
+++ /dev/null
@@ -1,349 +0,0 @@
- 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
deleted file mode 100644
index 4053e2a7e..000000000
--- a/mex/sources/libslicot/AB13AX.f
+++ /dev/null
@@ -1,308 +0,0 @@
- 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
deleted file mode 100644
index ac69fd7b6..000000000
--- a/mex/sources/libslicot/AB13BD.f
+++ /dev/null
@@ -1,390 +0,0 @@
- 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
deleted file mode 100644
index ec9fa2559..000000000
--- a/mex/sources/libslicot/AB13CD.f
+++ /dev/null
@@ -1,601 +0,0 @@
- 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
deleted file mode 100644
index e9df19f47..000000000
--- a/mex/sources/libslicot/AB13DD.f
+++ /dev/null
@@ -1,1870 +0,0 @@
- 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
deleted file mode 100644
index 09362b7c6..000000000
--- a/mex/sources/libslicot/AB13DX.f
+++ /dev/null
@@ -1,544 +0,0 @@
- 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
deleted file mode 100644
index a757b84e2..000000000
--- a/mex/sources/libslicot/AB13ED.f
+++ /dev/null
@@ -1,347 +0,0 @@
- 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 threshold 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
deleted file mode 100644
index 44628b470..000000000
--- a/mex/sources/libslicot/AB13FD.f
+++ /dev/null
@@ -1,403 +0,0 @@
- 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
deleted file mode 100644
index e0e0d4724..000000000
--- a/mex/sources/libslicot/AB13MD.f
+++ /dev/null
@@ -1,1782 +0,0 @@
- 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
deleted file mode 100644
index 9ec0da563..000000000
--- a/mex/sources/libslicot/AB8NXZ.f
+++ /dev/null
@@ -1,456 +0,0 @@
- 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
deleted file mode 100644
index 5a7ab4c5a..000000000
--- a/mex/sources/libslicot/AG07BD.f
+++ /dev/null
@@ -1,273 +0,0 @@
- 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
deleted file mode 100644
index ff0cdcc81..000000000
--- a/mex/sources/libslicot/AG08BD.f
+++ /dev/null
@@ -1,628 +0,0 @@
- 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
deleted file mode 100644
index 7e980bf87..000000000
--- a/mex/sources/libslicot/AG08BY.f
+++ /dev/null
@@ -1,680 +0,0 @@
- 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
deleted file mode 100644
index 6292b0554..000000000
--- a/mex/sources/libslicot/AG08BZ.f
+++ /dev/null
@@ -1,641 +0,0 @@
- 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
deleted file mode 100644
index c2dc7d5e4..000000000
--- a/mex/sources/libslicot/AG8BYZ.f
+++ /dev/null
@@ -1,692 +0,0 @@
- 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
deleted file mode 100644
index 8eafe1f32..000000000
--- a/mex/sources/libslicot/BB01AD.f
+++ /dev/null
@@ -1,1286 +0,0 @@
- 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
deleted file mode 100644
index b9edfa346..000000000
--- a/mex/sources/libslicot/BB02AD.f
+++ /dev/null
@@ -1,1017 +0,0 @@
- 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
deleted file mode 100644
index d19c19105..000000000
--- a/mex/sources/libslicot/BB03AD.f
+++ /dev/null
@@ -1,490 +0,0 @@
- 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
deleted file mode 100644
index a017a8808..000000000
--- a/mex/sources/libslicot/BB04AD.f
+++ /dev/null
@@ -1,476 +0,0 @@
- 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
deleted file mode 100644
index 9cc34c065..000000000
--- a/mex/sources/libslicot/BD01AD.f
+++ /dev/null
@@ -1,1017 +0,0 @@
- 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
deleted file mode 100644
index ebe6f4a70..000000000
--- a/mex/sources/libslicot/BD02AD.f
+++ /dev/null
@@ -1,601 +0,0 @@
- 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
deleted file mode 100644
index b2b0a608a..000000000
--- a/mex/sources/libslicot/DE01OD.f
+++ /dev/null
@@ -1,203 +0,0 @@
- 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
deleted file mode 100644
index 0358e8036..000000000
--- a/mex/sources/libslicot/DE01PD.f
+++ /dev/null
@@ -1,236 +0,0 @@
- 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
deleted file mode 100644
index 1dafa4b97..000000000
--- a/mex/sources/libslicot/DF01MD.f
+++ /dev/null
@@ -1,299 +0,0 @@
- 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
deleted file mode 100644
index ac91ab314..000000000
--- a/mex/sources/libslicot/DG01MD.f
+++ /dev/null
@@ -1,235 +0,0 @@
- 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
deleted file mode 100644
index 0a97d0ea5..000000000
--- a/mex/sources/libslicot/DG01ND.f
+++ /dev/null
@@ -1,247 +0,0 @@
- 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
deleted file mode 100644
index 9b7929dee..000000000
--- a/mex/sources/libslicot/DG01NY.f
+++ /dev/null
@@ -1,94 +0,0 @@
- 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
deleted file mode 100644
index ded9d479f..000000000
--- a/mex/sources/libslicot/DG01OD.f
+++ /dev/null
@@ -1,357 +0,0 @@
- 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
deleted file mode 100644
index 3ae298675..000000000
--- a/mex/sources/libslicot/DK01MD.f
+++ /dev/null
@@ -1,183 +0,0 @@
- 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
deleted file mode 100644
index 4bcc391f9..000000000
--- a/mex/sources/libslicot/FB01QD.f
+++ /dev/null
@@ -1,464 +0,0 @@
- 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
deleted file mode 100644
index 721cb2ae7..000000000
--- a/mex/sources/libslicot/FB01RD.f
+++ /dev/null
@@ -1,535 +0,0 @@
- 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
deleted file mode 100644
index 41783fc2e..000000000
--- a/mex/sources/libslicot/FB01SD.f
+++ /dev/null
@@ -1,597 +0,0 @@
- 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
deleted file mode 100644
index f248de0d9..000000000
--- a/mex/sources/libslicot/FB01TD.f
+++ /dev/null
@@ -1,641 +0,0 @@
- 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
deleted file mode 100644
index eabf21748..000000000
--- a/mex/sources/libslicot/FB01VD.f
+++ /dev/null
@@ -1,391 +0,0 @@
- 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
deleted file mode 100644
index 79fef1b65..000000000
--- a/mex/sources/libslicot/FD01AD.f
+++ /dev/null
@@ -1,367 +0,0 @@
- 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
deleted file mode 100644
index 301cdd529..000000000
--- a/mex/sources/libslicot/IB01AD.f
+++ /dev/null
@@ -1,686 +0,0 @@
- 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
deleted file mode 100644
index 011e02d34..000000000
--- a/mex/sources/libslicot/IB01BD.f
+++ /dev/null
@@ -1,791 +0,0 @@
- 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
deleted file mode 100644
index 001c6dcca..000000000
--- a/mex/sources/libslicot/IB01CD.f
+++ /dev/null
@@ -1,823 +0,0 @@
- 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
deleted file mode 100644
index d76b4af38..000000000
--- a/mex/sources/libslicot/IB01MD.f
+++ /dev/null
@@ -1,1433 +0,0 @@
- 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
deleted file mode 100644
index a76f452a3..000000000
--- a/mex/sources/libslicot/IB01MY.f
+++ /dev/null
@@ -1,1094 +0,0 @@
- 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
deleted file mode 100644
index ad315b4cd..000000000
--- a/mex/sources/libslicot/IB01ND.f
+++ /dev/null
@@ -1,731 +0,0 @@
- 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
deleted file mode 100644
index 69d22c5ea..000000000
--- a/mex/sources/libslicot/IB01OD.f
+++ /dev/null
@@ -1,214 +0,0 @@
- 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
deleted file mode 100644
index 1e475d751..000000000
--- a/mex/sources/libslicot/IB01OY.f
+++ /dev/null
@@ -1,175 +0,0 @@
- 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
deleted file mode 100644
index 45c3e0f11..000000000
--- a/mex/sources/libslicot/IB01PD.f
+++ /dev/null
@@ -1,1232 +0,0 @@
- 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
deleted file mode 100644
index cf19feb43..000000000
--- a/mex/sources/libslicot/IB01PX.f
+++ /dev/null
@@ -1,474 +0,0 @@
- 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
deleted file mode 100644
index 4b4ff2f5e..000000000
--- a/mex/sources/libslicot/IB01PY.f
+++ /dev/null
@@ -1,768 +0,0 @@
- 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
deleted file mode 100644
index 93bf15663..000000000
--- a/mex/sources/libslicot/IB01QD.f
+++ /dev/null
@@ -1,1081 +0,0 @@
- 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
deleted file mode 100644
index b5eaf6125..000000000
--- a/mex/sources/libslicot/IB01RD.f
+++ /dev/null
@@ -1,762 +0,0 @@
- 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
deleted file mode 100644
index 9ba63187c..000000000
--- a/mex/sources/libslicot/IB03AD.f
+++ /dev/null
@@ -1,1076 +0,0 @@
- 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
deleted file mode 100644
index a1e0e86de..000000000
--- a/mex/sources/libslicot/IB03BD.f
+++ /dev/null
@@ -1,1087 +0,0 @@
- 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
deleted file mode 100644
index eab214d03..000000000
--- a/mex/sources/libslicot/MA01AD.f
+++ /dev/null
@@ -1,95 +0,0 @@
- 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
deleted file mode 100644
index a3cec4e40..000000000
--- a/mex/sources/libslicot/MA02AD.f
+++ /dev/null
@@ -1,108 +0,0 @@
- 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
deleted file mode 100644
index 38e713734..000000000
--- a/mex/sources/libslicot/MA02BD.f
+++ /dev/null
@@ -1,113 +0,0 @@
- 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
deleted file mode 100644
index b2a699bf1..000000000
--- a/mex/sources/libslicot/MA02BZ.f
+++ /dev/null
@@ -1,114 +0,0 @@
- 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
deleted file mode 100644
index e4948b891..000000000
--- a/mex/sources/libslicot/MA02CD.f
+++ /dev/null
@@ -1,113 +0,0 @@
- 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
deleted file mode 100644
index 5bb85b5ed..000000000
--- a/mex/sources/libslicot/MA02CZ.f
+++ /dev/null
@@ -1,113 +0,0 @@
- 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
deleted file mode 100644
index ef7967e73..000000000
--- a/mex/sources/libslicot/MA02DD.f
+++ /dev/null
@@ -1,157 +0,0 @@
- 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
deleted file mode 100644
index 79ce82f7c..000000000
--- a/mex/sources/libslicot/MA02ED.f
+++ /dev/null
@@ -1,99 +0,0 @@
- 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
deleted file mode 100644
index f2ec4350b..000000000
--- a/mex/sources/libslicot/MA02FD.f
+++ /dev/null
@@ -1,104 +0,0 @@
- 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
deleted file mode 100644
index 90cda2ed4..000000000
--- a/mex/sources/libslicot/MA02GD.f
+++ /dev/null
@@ -1,158 +0,0 @@
- 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
deleted file mode 100644
index 2017da866..000000000
--- a/mex/sources/libslicot/MA02HD.f
+++ /dev/null
@@ -1,180 +0,0 @@
- 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
deleted file mode 100644
index 8b822bb55..000000000
--- a/mex/sources/libslicot/MA02ID.f
+++ /dev/null
@@ -1,293 +0,0 @@
- 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
deleted file mode 100644
index ebf75d0a2..000000000
--- a/mex/sources/libslicot/MA02JD.f
+++ /dev/null
@@ -1,164 +0,0 @@
- 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
deleted file mode 100644
index 94f99f57a..000000000
--- a/mex/sources/libslicot/MB01MD.f
+++ /dev/null
@@ -1,279 +0,0 @@
- 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
deleted file mode 100644
index 036facf71..000000000
--- a/mex/sources/libslicot/MB01ND.f
+++ /dev/null
@@ -1,249 +0,0 @@
- 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
deleted file mode 100644
index 1845ab8a8..000000000
--- a/mex/sources/libslicot/MB01PD.f
+++ /dev/null
@@ -1,271 +0,0 @@
- 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
deleted file mode 100644
index 61befc51a..000000000
--- a/mex/sources/libslicot/MB01QD.f
+++ /dev/null
@@ -1,334 +0,0 @@
- 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
deleted file mode 100644
index 2c53070de..000000000
--- a/mex/sources/libslicot/MB01RD.f
+++ /dev/null
@@ -1,345 +0,0 @@
- 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
deleted file mode 100644
index c22549cc7..000000000
--- a/mex/sources/libslicot/MB01RU.f
+++ /dev/null
@@ -1,282 +0,0 @@
- SUBROUTINE MB01RU( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA,
- $ X, LDX, DWORK, LDWORK, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have received 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
deleted file mode 100644
index 1305d3ed4..000000000
--- a/mex/sources/libslicot/MB01RW.f
+++ /dev/null
@@ -1,249 +0,0 @@
- 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
deleted file mode 100644
index 64abe3901..000000000
--- a/mex/sources/libslicot/MB01RX.f
+++ /dev/null
@@ -1,315 +0,0 @@
- SUBROUTINE MB01RX( SIDE, UPLO, TRANS, M, N, ALPHA, BETA, R, LDR,
- $ A, LDA, B, LDB, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have received 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
deleted file mode 100644
index af32cfe63..000000000
--- a/mex/sources/libslicot/MB01RY.f
+++ /dev/null
@@ -1,429 +0,0 @@
- SUBROUTINE MB01RY( SIDE, UPLO, TRANS, M, ALPHA, BETA, R, LDR, H,
- $ LDH, B, LDB, DWORK, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have received 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
deleted file mode 100644
index b29437379..000000000
--- a/mex/sources/libslicot/MB01SD.f
+++ /dev/null
@@ -1,123 +0,0 @@
- 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
deleted file mode 100644
index d4e06e626..000000000
--- a/mex/sources/libslicot/MB01TD.f
+++ /dev/null
@@ -1,173 +0,0 @@
- 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
deleted file mode 100644
index 0bdacadf5..000000000
--- a/mex/sources/libslicot/MB01UD.f
+++ /dev/null
@@ -1,238 +0,0 @@
- SUBROUTINE MB01UD( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA, B,
- $ LDB, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have received 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
deleted file mode 100644
index ff8489636..000000000
--- a/mex/sources/libslicot/MB01UW.f
+++ /dev/null
@@ -1,377 +0,0 @@
- 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
deleted file mode 100644
index 166c23c44..000000000
--- a/mex/sources/libslicot/MB01UX.f
+++ /dev/null
@@ -1,373 +0,0 @@
- 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
deleted file mode 100644
index bcd924d68..000000000
--- a/mex/sources/libslicot/MB01VD.f
+++ /dev/null
@@ -1,1693 +0,0 @@
- 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
deleted file mode 100644
index 53c85f9da..000000000
--- a/mex/sources/libslicot/MB01WD.f
+++ /dev/null
@@ -1,343 +0,0 @@
- 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
deleted file mode 100644
index 3a54a2e2a..000000000
--- a/mex/sources/libslicot/MB01XD.f
+++ /dev/null
@@ -1,207 +0,0 @@
- 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
deleted file mode 100644
index 6af6275cd..000000000
--- a/mex/sources/libslicot/MB01XY.f
+++ /dev/null
@@ -1,191 +0,0 @@
- 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
deleted file mode 100644
index 6d5c2a0fe..000000000
--- a/mex/sources/libslicot/MB01YD.f
+++ /dev/null
@@ -1,352 +0,0 @@
- 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
deleted file mode 100644
index abdbbf473..000000000
--- a/mex/sources/libslicot/MB01ZD.f
+++ /dev/null
@@ -1,475 +0,0 @@
- 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
deleted file mode 100644
index 2c878db9d..000000000
--- a/mex/sources/libslicot/MB02CD.f
+++ /dev/null
@@ -1,597 +0,0 @@
- 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
deleted file mode 100644
index 38bddf38f..000000000
--- a/mex/sources/libslicot/MB02CU.f
+++ /dev/null
@@ -1,1015 +0,0 @@
- 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
deleted file mode 100644
index f049fca50..000000000
--- a/mex/sources/libslicot/MB02CV.f
+++ /dev/null
@@ -1,795 +0,0 @@
- 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
deleted file mode 100644
index be4989cbf..000000000
--- a/mex/sources/libslicot/MB02CX.f
+++ /dev/null
@@ -1,318 +0,0 @@
- 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
deleted file mode 100644
index 7d977dee9..000000000
--- a/mex/sources/libslicot/MB02CY.f
+++ /dev/null
@@ -1,372 +0,0 @@
- 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
deleted file mode 100644
index fadd6b442..000000000
--- a/mex/sources/libslicot/MB02DD.f
+++ /dev/null
@@ -1,564 +0,0 @@
- 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
deleted file mode 100644
index d5c366cbc..000000000
--- a/mex/sources/libslicot/MB02ED.f
+++ /dev/null
@@ -1,445 +0,0 @@
- 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
deleted file mode 100644
index 0e608a832..000000000
--- a/mex/sources/libslicot/MB02FD.f
+++ /dev/null
@@ -1,383 +0,0 @@
- 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
deleted file mode 100644
index c227a556a..000000000
--- a/mex/sources/libslicot/MB02GD.f
+++ /dev/null
@@ -1,558 +0,0 @@
- 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
deleted file mode 100644
index c93d2474a..000000000
--- a/mex/sources/libslicot/MB02HD.f
+++ /dev/null
@@ -1,545 +0,0 @@
- 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
deleted file mode 100644
index a0e5e659b..000000000
--- a/mex/sources/libslicot/MB02ID.f
+++ /dev/null
@@ -1,508 +0,0 @@
- 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
deleted file mode 100644
index 95c49b43a..000000000
--- a/mex/sources/libslicot/MB02JD.f
+++ /dev/null
@@ -1,486 +0,0 @@
- 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
deleted file mode 100644
index c941bd446..000000000
--- a/mex/sources/libslicot/MB02JX.f
+++ /dev/null
@@ -1,737 +0,0 @@
- 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
deleted file mode 100644
index c45c7cd62..000000000
--- a/mex/sources/libslicot/MB02KD.f
+++ /dev/null
@@ -1,842 +0,0 @@
- 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
deleted file mode 100644
index 28cbdadaa..000000000
--- a/mex/sources/libslicot/MB02MD.f
+++ /dev/null
@@ -1,577 +0,0 @@
- 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
deleted file mode 100644
index 047296025..000000000
--- a/mex/sources/libslicot/MB02ND.f
+++ /dev/null
@@ -1,889 +0,0 @@
- 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
deleted file mode 100644
index acf0bce5a..000000000
--- a/mex/sources/libslicot/MB02NY.f
+++ /dev/null
@@ -1,261 +0,0 @@
- 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
deleted file mode 100644
index 0a6929954..000000000
--- a/mex/sources/libslicot/MB02OD.f
+++ /dev/null
@@ -1,267 +0,0 @@
- 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
deleted file mode 100644
index e8fb4a9a8..000000000
--- a/mex/sources/libslicot/MB02PD.f
+++ /dev/null
@@ -1,553 +0,0 @@
- SUBROUTINE MB02PD( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV,
- $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR,
- $ IWORK, DWORK, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have 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
deleted file mode 100644
index 610c25043..000000000
--- a/mex/sources/libslicot/MB02QD.f
+++ /dev/null
@@ -1,502 +0,0 @@
- 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
deleted file mode 100644
index 329f54d46..000000000
--- a/mex/sources/libslicot/MB02QY.f
+++ /dev/null
@@ -1,339 +0,0 @@
- 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
deleted file mode 100644
index d524e7f9b..000000000
--- a/mex/sources/libslicot/MB02RD.f
+++ /dev/null
@@ -1,197 +0,0 @@
- 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
deleted file mode 100644
index a82be52be..000000000
--- a/mex/sources/libslicot/MB02RZ.f
+++ /dev/null
@@ -1,216 +0,0 @@
- 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
deleted file mode 100644
index 2c72554ee..000000000
--- a/mex/sources/libslicot/MB02SD.f
+++ /dev/null
@@ -1,164 +0,0 @@
- 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
deleted file mode 100644
index 4643a9189..000000000
--- a/mex/sources/libslicot/MB02SZ.f
+++ /dev/null
@@ -1,169 +0,0 @@
- 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
deleted file mode 100644
index 865ffbf39..000000000
--- a/mex/sources/libslicot/MB02TD.f
+++ /dev/null
@@ -1,236 +0,0 @@
- 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
deleted file mode 100644
index 8cc434d75..000000000
--- a/mex/sources/libslicot/MB02TZ.f
+++ /dev/null
@@ -1,247 +0,0 @@
- 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
deleted file mode 100644
index 101c7426e..000000000
--- a/mex/sources/libslicot/MB02UD.f
+++ /dev/null
@@ -1,624 +0,0 @@
- 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
deleted file mode 100644
index 649cc5139..000000000
--- a/mex/sources/libslicot/MB02UU.f
+++ /dev/null
@@ -1,162 +0,0 @@
- 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
deleted file mode 100644
index 61e5bbc73..000000000
--- a/mex/sources/libslicot/MB02UV.f
+++ /dev/null
@@ -1,195 +0,0 @@
- 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
deleted file mode 100644
index 5896d2349..000000000
--- a/mex/sources/libslicot/MB02VD.f
+++ /dev/null
@@ -1,187 +0,0 @@
- SUBROUTINE MB02VD( TRANS, M, N, A, LDA, IPIV, B, LDB, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have received 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
deleted file mode 100644
index 59816e037..000000000
--- a/mex/sources/libslicot/MB02WD.f
+++ /dev/null
@@ -1,458 +0,0 @@
- 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
deleted file mode 100644
index 0575a907a..000000000
--- a/mex/sources/libslicot/MB02XD.f
+++ /dev/null
@@ -1,409 +0,0 @@
- 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
deleted file mode 100644
index 981af1f03..000000000
--- a/mex/sources/libslicot/MB02YD.f
+++ /dev/null
@@ -1,371 +0,0 @@
- 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
deleted file mode 100644
index 7f47657fd..000000000
--- a/mex/sources/libslicot/MB03MD.f
+++ /dev/null
@@ -1,343 +0,0 @@
- 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
deleted file mode 100644
index cee355e8a..000000000
--- a/mex/sources/libslicot/MB03MY.f
+++ /dev/null
@@ -1,91 +0,0 @@
- 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
deleted file mode 100644
index c681c2e53..000000000
--- a/mex/sources/libslicot/MB03ND.f
+++ /dev/null
@@ -1,217 +0,0 @@
- 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
deleted file mode 100644
index a6efae588..000000000
--- a/mex/sources/libslicot/MB03NY.f
+++ /dev/null
@@ -1,208 +0,0 @@
- 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
deleted file mode 100644
index 71cb43d66..000000000
--- a/mex/sources/libslicot/MB03OD.f
+++ /dev/null
@@ -1,306 +0,0 @@
- 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
deleted file mode 100644
index e39734d55..000000000
--- a/mex/sources/libslicot/MB03OY.f
+++ /dev/null
@@ -1,388 +0,0 @@
- 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
deleted file mode 100644
index 5dae93666..000000000
--- a/mex/sources/libslicot/MB03PD.f
+++ /dev/null
@@ -1,339 +0,0 @@
- 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
deleted file mode 100644
index d0c7d0ca2..000000000
--- a/mex/sources/libslicot/MB03PY.f
+++ /dev/null
@@ -1,392 +0,0 @@
- 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
deleted file mode 100644
index d94eed1bb..000000000
--- a/mex/sources/libslicot/MB03QD.f
+++ /dev/null
@@ -1,316 +0,0 @@
- 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
deleted file mode 100644
index 26474ba96..000000000
--- a/mex/sources/libslicot/MB03QX.f
+++ /dev/null
@@ -1,122 +0,0 @@
- 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
deleted file mode 100644
index bf3c8d1ae..000000000
--- a/mex/sources/libslicot/MB03QY.f
+++ /dev/null
@@ -1,164 +0,0 @@
- 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
deleted file mode 100644
index 9d3910d11..000000000
--- a/mex/sources/libslicot/MB03RD.f
+++ /dev/null
@@ -1,613 +0,0 @@
- 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
deleted file mode 100644
index d7c582db5..000000000
--- a/mex/sources/libslicot/MB03RX.f
+++ /dev/null
@@ -1,226 +0,0 @@
- 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
deleted file mode 100644
index 550083136..000000000
--- a/mex/sources/libslicot/MB03RY.f
+++ /dev/null
@@ -1,261 +0,0 @@
- 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
deleted file mode 100644
index 679396e77..000000000
--- a/mex/sources/libslicot/MB03SD.f
+++ /dev/null
@@ -1,348 +0,0 @@
- 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
deleted file mode 100644
index 05561446d..000000000
--- a/mex/sources/libslicot/MB03TD.f
+++ /dev/null
@@ -1,641 +0,0 @@
- 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
deleted file mode 100644
index 202e72f5b..000000000
--- a/mex/sources/libslicot/MB03TS.f
+++ /dev/null
@@ -1,746 +0,0 @@
- 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
deleted file mode 100644
index 37e6b6bcd..000000000
--- a/mex/sources/libslicot/MB03UD.f
+++ /dev/null
@@ -1,318 +0,0 @@
- 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
deleted file mode 100644
index 4cf99f6fb..000000000
--- a/mex/sources/libslicot/MB03VD.f
+++ /dev/null
@@ -1,306 +0,0 @@
- 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
deleted file mode 100644
index 163e77497..000000000
--- a/mex/sources/libslicot/MB03VY.f
+++ /dev/null
@@ -1,216 +0,0 @@
- 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
deleted file mode 100644
index 0a800ae0c..000000000
--- a/mex/sources/libslicot/MB03WA.f
+++ /dev/null
@@ -1,538 +0,0 @@
- 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
deleted file mode 100644
index 76bd6780d..000000000
--- a/mex/sources/libslicot/MB03WD.f
+++ /dev/null
@@ -1,966 +0,0 @@
- 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
deleted file mode 100644
index b8c3a9e28..000000000
--- a/mex/sources/libslicot/MB03WX.f
+++ /dev/null
@@ -1,170 +0,0 @@
- 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
deleted file mode 100644
index 3b68a9726..000000000
--- a/mex/sources/libslicot/MB03XD.f
+++ /dev/null
@@ -1,826 +0,0 @@
- 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
deleted file mode 100644
index bf374c251..000000000
--- a/mex/sources/libslicot/MB03XP.f
+++ /dev/null
@@ -1,659 +0,0 @@
- 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
deleted file mode 100644
index b25d49da3..000000000
--- a/mex/sources/libslicot/MB03XU.f
+++ /dev/null
@@ -1,2338 +0,0 @@
- 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
deleted file mode 100644
index 0a87c7c30..000000000
--- a/mex/sources/libslicot/MB03YA.f
+++ /dev/null
@@ -1,297 +0,0 @@
- 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
deleted file mode 100644
index e99078cdb..000000000
--- a/mex/sources/libslicot/MB03YD.f
+++ /dev/null
@@ -1,540 +0,0 @@
- 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
deleted file mode 100644
index 774b0bdda..000000000
--- a/mex/sources/libslicot/MB03YT.f
+++ /dev/null
@@ -1,331 +0,0 @@
- 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
deleted file mode 100644
index 814525200..000000000
--- a/mex/sources/libslicot/MB03ZA.f
+++ /dev/null
@@ -1,1371 +0,0 @@
- 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
deleted file mode 100644
index 74e945525..000000000
--- a/mex/sources/libslicot/MB03ZD.f
+++ /dev/null
@@ -1,908 +0,0 @@
- 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
deleted file mode 100644
index 857bceef0..000000000
--- a/mex/sources/libslicot/MB04DD.f
+++ /dev/null
@@ -1,440 +0,0 @@
- 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
deleted file mode 100644
index 793d6ab5a..000000000
--- a/mex/sources/libslicot/MB04DI.f
+++ /dev/null
@@ -1,216 +0,0 @@
- 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
deleted file mode 100644
index f543a97d1..000000000
--- a/mex/sources/libslicot/MB04DS.f
+++ /dev/null
@@ -1,450 +0,0 @@
- 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
deleted file mode 100644
index 6b8b3203d..000000000
--- a/mex/sources/libslicot/MB04DY.f
+++ /dev/null
@@ -1,329 +0,0 @@
- 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
deleted file mode 100644
index fa7502ec6..000000000
--- a/mex/sources/libslicot/MB04GD.f
+++ /dev/null
@@ -1,258 +0,0 @@
- 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
deleted file mode 100644
index d28929f2f..000000000
--- a/mex/sources/libslicot/MB04ID.f
+++ /dev/null
@@ -1,278 +0,0 @@
- 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
deleted file mode 100644
index 4b07b2c35..000000000
--- a/mex/sources/libslicot/MB04IY.f
+++ /dev/null
@@ -1,327 +0,0 @@
- 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
deleted file mode 100644
index c9654a6a5..000000000
--- a/mex/sources/libslicot/MB04IZ.f
+++ /dev/null
@@ -1,282 +0,0 @@
- 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
deleted file mode 100644
index 8dc1a3b9b..000000000
--- a/mex/sources/libslicot/MB04JD.f
+++ /dev/null
@@ -1,248 +0,0 @@
- 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
deleted file mode 100644
index adcdcb6f9..000000000
--- a/mex/sources/libslicot/MB04KD.f
+++ /dev/null
@@ -1,209 +0,0 @@
- 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
deleted file mode 100644
index 7931437f5..000000000
--- a/mex/sources/libslicot/MB04LD.f
+++ /dev/null
@@ -1,209 +0,0 @@
- 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
deleted file mode 100644
index 8a9055af2..000000000
--- a/mex/sources/libslicot/MB04MD.f
+++ /dev/null
@@ -1,290 +0,0 @@
- 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
deleted file mode 100644
index 2a7e0725e..000000000
--- a/mex/sources/libslicot/MB04ND.f
+++ /dev/null
@@ -1,257 +0,0 @@
- 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
deleted file mode 100644
index 4e884454c..000000000
--- a/mex/sources/libslicot/MB04NY.f
+++ /dev/null
@@ -1,437 +0,0 @@
- 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
deleted file mode 100644
index 694c81d75..000000000
--- a/mex/sources/libslicot/MB04OD.f
+++ /dev/null
@@ -1,257 +0,0 @@
- 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
deleted file mode 100644
index ab5940943..000000000
--- a/mex/sources/libslicot/MB04OW.f
+++ /dev/null
@@ -1,251 +0,0 @@
- 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
deleted file mode 100644
index b8d02919e..000000000
--- a/mex/sources/libslicot/MB04OX.f
+++ /dev/null
@@ -1,106 +0,0 @@
- 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
deleted file mode 100644
index d77d28372..000000000
--- a/mex/sources/libslicot/MB04OY.f
+++ /dev/null
@@ -1,370 +0,0 @@
- 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
deleted file mode 100644
index 8ee27d01e..000000000
--- a/mex/sources/libslicot/MB04PA.f
+++ /dev/null
@@ -1,1105 +0,0 @@
- 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
deleted file mode 100644
index 3948eee1e..000000000
--- a/mex/sources/libslicot/MB04PB.f
+++ /dev/null
@@ -1,333 +0,0 @@
- 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
deleted file mode 100644
index 2c13e6636..000000000
--- a/mex/sources/libslicot/MB04PU.f
+++ /dev/null
@@ -1,369 +0,0 @@
- 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
deleted file mode 100644
index 09b5a17d7..000000000
--- a/mex/sources/libslicot/MB04PY.f
+++ /dev/null
@@ -1,648 +0,0 @@
- 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
deleted file mode 100644
index 6cb9e6777..000000000
--- a/mex/sources/libslicot/MB04QB.f
+++ /dev/null
@@ -1,454 +0,0 @@
- 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
deleted file mode 100644
index 44d6a9ebd..000000000
--- a/mex/sources/libslicot/MB04QC.f
+++ /dev/null
@@ -1,1223 +0,0 @@
- 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
deleted file mode 100644
index f2be26ce0..000000000
--- a/mex/sources/libslicot/MB04QF.f
+++ /dev/null
@@ -1,532 +0,0 @@
- 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
deleted file mode 100644
index 6ae814da0..000000000
--- a/mex/sources/libslicot/MB04QU.f
+++ /dev/null
@@ -1,472 +0,0 @@
- 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
deleted file mode 100644
index 3d5ad6614..000000000
--- a/mex/sources/libslicot/MB04TB.f
+++ /dev/null
@@ -1,677 +0,0 @@
- 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
deleted file mode 100644
index 66f085f5f..000000000
--- a/mex/sources/libslicot/MB04TS.f
+++ /dev/null
@@ -1,519 +0,0 @@
- 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
deleted file mode 100644
index 7d8e207f9..000000000
--- a/mex/sources/libslicot/MB04TT.f
+++ /dev/null
@@ -1,413 +0,0 @@
- 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
deleted file mode 100644
index 74e81bfe1..000000000
--- a/mex/sources/libslicot/MB04TU.f
+++ /dev/null
@@ -1,96 +0,0 @@
- 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
deleted file mode 100644
index c3fa37f2d..000000000
--- a/mex/sources/libslicot/MB04TV.f
+++ /dev/null
@@ -1,171 +0,0 @@
- 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
deleted file mode 100644
index 81854d9f2..000000000
--- a/mex/sources/libslicot/MB04TW.f
+++ /dev/null
@@ -1,180 +0,0 @@
- 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
deleted file mode 100644
index ff4c37128..000000000
--- a/mex/sources/libslicot/MB04TX.f
+++ /dev/null
@@ -1,394 +0,0 @@
- 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
deleted file mode 100644
index 1a146092f..000000000
--- a/mex/sources/libslicot/MB04TY.f
+++ /dev/null
@@ -1,241 +0,0 @@
- 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
deleted file mode 100644
index a5e2ba347..000000000
--- a/mex/sources/libslicot/MB04UD.f
+++ /dev/null
@@ -1,375 +0,0 @@
- 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
deleted file mode 100644
index e83817aad..000000000
--- a/mex/sources/libslicot/MB04VD.f
+++ /dev/null
@@ -1,540 +0,0 @@
- 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
deleted file mode 100644
index 92cfab1cd..000000000
--- a/mex/sources/libslicot/MB04VX.f
+++ /dev/null
@@ -1,384 +0,0 @@
- 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
deleted file mode 100644
index 9edbbf8c6..000000000
--- a/mex/sources/libslicot/MB04WD.f
+++ /dev/null
@@ -1,411 +0,0 @@
- 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
deleted file mode 100644
index 2af3306c6..000000000
--- a/mex/sources/libslicot/MB04WP.f
+++ /dev/null
@@ -1,211 +0,0 @@
- 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
deleted file mode 100644
index 42c1f461b..000000000
--- a/mex/sources/libslicot/MB04WR.f
+++ /dev/null
@@ -1,340 +0,0 @@
- 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
deleted file mode 100644
index 1e177810b..000000000
--- a/mex/sources/libslicot/MB04WU.f
+++ /dev/null
@@ -1,402 +0,0 @@
- 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
deleted file mode 100644
index 6d417486a..000000000
--- a/mex/sources/libslicot/MB04XD.f
+++ /dev/null
@@ -1,652 +0,0 @@
- 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
deleted file mode 100644
index 02e8e7e22..000000000
--- a/mex/sources/libslicot/MB04XY.f
+++ /dev/null
@@ -1,274 +0,0 @@
- 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
deleted file mode 100644
index 90ef68b27..000000000
--- a/mex/sources/libslicot/MB04YD.f
+++ /dev/null
@@ -1,623 +0,0 @@
- 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
deleted file mode 100644
index 0090d5111..000000000
--- a/mex/sources/libslicot/MB04YW.f
+++ /dev/null
@@ -1,513 +0,0 @@
- 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
deleted file mode 100644
index 63c77e6a1..000000000
--- a/mex/sources/libslicot/MB04ZD.f
+++ /dev/null
@@ -1,486 +0,0 @@
- 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
deleted file mode 100644
index 58da11528..000000000
--- a/mex/sources/libslicot/MB05MD.f
+++ /dev/null
@@ -1,356 +0,0 @@
- 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
deleted file mode 100644
index 7d7063494..000000000
--- a/mex/sources/libslicot/MB05MY.f
+++ /dev/null
@@ -1,327 +0,0 @@
- 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
deleted file mode 100644
index 37bbe61a6..000000000
--- a/mex/sources/libslicot/MB05ND.f
+++ /dev/null
@@ -1,377 +0,0 @@
- 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
deleted file mode 100644
index ec87a2ee7..000000000
--- a/mex/sources/libslicot/MB05OD.f
+++ /dev/null
@@ -1,574 +0,0 @@
- 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
deleted file mode 100644
index a73de7039..000000000
--- a/mex/sources/libslicot/MB05OY.f
+++ /dev/null
@@ -1,179 +0,0 @@
- 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
deleted file mode 100644
index 054e570ad..000000000
--- a/mex/sources/libslicot/MB3OYZ.f
+++ /dev/null
@@ -1,395 +0,0 @@
- 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
deleted file mode 100644
index 119bca081..000000000
--- a/mex/sources/libslicot/MB3PYZ.f
+++ /dev/null
@@ -1,398 +0,0 @@
- 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
deleted file mode 100644
index 9da419a93..000000000
--- a/mex/sources/libslicot/MC01MD.f
+++ /dev/null
@@ -1,162 +0,0 @@
- 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
deleted file mode 100644
index b45913fe7..000000000
--- a/mex/sources/libslicot/MC01ND.f
+++ /dev/null
@@ -1,146 +0,0 @@
- 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
deleted file mode 100644
index 2d148791f..000000000
--- a/mex/sources/libslicot/MC01OD.f
+++ /dev/null
@@ -1,147 +0,0 @@
- 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
deleted file mode 100644
index f378a84bd..000000000
--- a/mex/sources/libslicot/MC01PD.f
+++ /dev/null
@@ -1,159 +0,0 @@
- 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
deleted file mode 100644
index d43f9b172..000000000
--- a/mex/sources/libslicot/MC01PY.f
+++ /dev/null
@@ -1,157 +0,0 @@
- 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
deleted file mode 100644
index 652887bb6..000000000
--- a/mex/sources/libslicot/MC01QD.f
+++ /dev/null
@@ -1,207 +0,0 @@
- 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
deleted file mode 100644
index da1b3dc2f..000000000
--- a/mex/sources/libslicot/MC01RD.f
+++ /dev/null
@@ -1,299 +0,0 @@
- 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
deleted file mode 100644
index d84362ee2..000000000
--- a/mex/sources/libslicot/MC01SD.f
+++ /dev/null
@@ -1,281 +0,0 @@
- 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
deleted file mode 100644
index 55e155e59..000000000
--- a/mex/sources/libslicot/MC01SW.f
+++ /dev/null
@@ -1,104 +0,0 @@
- 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
deleted file mode 100644
index c20360154..000000000
--- a/mex/sources/libslicot/MC01SX.f
+++ /dev/null
@@ -1,68 +0,0 @@
- 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
deleted file mode 100644
index ab187aa50..000000000
--- a/mex/sources/libslicot/MC01SY.f
+++ /dev/null
@@ -1,146 +0,0 @@
- 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
deleted file mode 100644
index 249f5c367..000000000
--- a/mex/sources/libslicot/MC01TD.f
+++ /dev/null
@@ -1,305 +0,0 @@
- 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
deleted file mode 100644
index 4d03390b1..000000000
--- a/mex/sources/libslicot/MC01VD.f
+++ /dev/null
@@ -1,304 +0,0 @@
- 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
deleted file mode 100644
index 5ef42154c..000000000
--- a/mex/sources/libslicot/MC01WD.f
+++ /dev/null
@@ -1,156 +0,0 @@
- 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
deleted file mode 100644
index 36e69719c..000000000
--- a/mex/sources/libslicot/MC03MD.f
+++ /dev/null
@@ -1,351 +0,0 @@
- 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
deleted file mode 100644
index 5ee0fd02a..000000000
--- a/mex/sources/libslicot/MC03ND.f
+++ /dev/null
@@ -1,495 +0,0 @@
- 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
deleted file mode 100644
index 7376234df..000000000
--- a/mex/sources/libslicot/MC03NX.f
+++ /dev/null
@@ -1,146 +0,0 @@
- 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
deleted file mode 100644
index 9966e02a5..000000000
--- a/mex/sources/libslicot/MC03NY.f
+++ /dev/null
@@ -1,412 +0,0 @@
- 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
deleted file mode 100644
index 6eca057c4..000000000
--- a/mex/sources/libslicot/MD03AD.f
+++ /dev/null
@@ -1,973 +0,0 @@
- 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
deleted file mode 100644
index ac2782e3a..000000000
--- a/mex/sources/libslicot/MD03BA.f
+++ /dev/null
@@ -1,151 +0,0 @@
- 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
deleted file mode 100644
index 67772e407..000000000
--- a/mex/sources/libslicot/MD03BB.f
+++ /dev/null
@@ -1,203 +0,0 @@
- 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
deleted file mode 100644
index eccd179e7..000000000
--- a/mex/sources/libslicot/MD03BD.f
+++ /dev/null
@@ -1,1206 +0,0 @@
- 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
deleted file mode 100644
index 232ac807d..000000000
--- a/mex/sources/libslicot/MD03BF.f
+++ /dev/null
@@ -1,122 +0,0 @@
- 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
deleted file mode 100644
index 7ffef61d0..000000000
--- a/mex/sources/libslicot/MD03BX.f
+++ /dev/null
@@ -1,255 +0,0 @@
- 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
deleted file mode 100644
index ec4637ce4..000000000
--- a/mex/sources/libslicot/MD03BY.f
+++ /dev/null
@@ -1,514 +0,0 @@
- 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
deleted file mode 100644
index 16af66a25..000000000
--- a/mex/sources/libslicot/NF01AD.f
+++ /dev/null
@@ -1,230 +0,0 @@
- 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
deleted file mode 100644
index cc9782a86..000000000
--- a/mex/sources/libslicot/NF01AY.f
+++ /dev/null
@@ -1,353 +0,0 @@
- 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
deleted file mode 100644
index 98c344a37..000000000
--- a/mex/sources/libslicot/NF01BA.f
+++ /dev/null
@@ -1,104 +0,0 @@
- 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
deleted file mode 100644
index ec39f9b38..000000000
--- a/mex/sources/libslicot/NF01BB.f
+++ /dev/null
@@ -1,138 +0,0 @@
- 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
deleted file mode 100644
index 3f15bc2a6..000000000
--- a/mex/sources/libslicot/NF01BD.f
+++ /dev/null
@@ -1,381 +0,0 @@
- 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
deleted file mode 100644
index a9ad1dde5..000000000
--- a/mex/sources/libslicot/NF01BE.f
+++ /dev/null
@@ -1,105 +0,0 @@
- 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
deleted file mode 100644
index d47b288dc..000000000
--- a/mex/sources/libslicot/NF01BF.f
+++ /dev/null
@@ -1,157 +0,0 @@
- 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
deleted file mode 100644
index e15e17f4e..000000000
--- a/mex/sources/libslicot/NF01BP.f
+++ /dev/null
@@ -1,666 +0,0 @@
- 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
deleted file mode 100644
index e07faaa28..000000000
--- a/mex/sources/libslicot/NF01BQ.f
+++ /dev/null
@@ -1,477 +0,0 @@
- 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
deleted file mode 100644
index 4a68dab2b..000000000
--- a/mex/sources/libslicot/NF01BR.f
+++ /dev/null
@@ -1,711 +0,0 @@
- 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
deleted file mode 100644
index 3d7d6e5c9..000000000
--- a/mex/sources/libslicot/NF01BS.f
+++ /dev/null
@@ -1,610 +0,0 @@
- 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
deleted file mode 100644
index 502959cdd..000000000
--- a/mex/sources/libslicot/NF01BU.f
+++ /dev/null
@@ -1,398 +0,0 @@
- 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
deleted file mode 100644
index d596ec50a..000000000
--- a/mex/sources/libslicot/NF01BV.f
+++ /dev/null
@@ -1,249 +0,0 @@
- 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
deleted file mode 100644
index 1fdac4fd9..000000000
--- a/mex/sources/libslicot/NF01BW.f
+++ /dev/null
@@ -1,242 +0,0 @@
- 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
deleted file mode 100644
index 73cc30c61..000000000
--- a/mex/sources/libslicot/NF01BX.f
+++ /dev/null
@@ -1,174 +0,0 @@
- 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
deleted file mode 100644
index c9c0a8e33..000000000
--- a/mex/sources/libslicot/NF01BY.f
+++ /dev/null
@@ -1,294 +0,0 @@
- 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
deleted file mode 100644
index 587581e34..000000000
--- a/mex/sources/libslicot/SB01BD.f
+++ /dev/null
@@ -1,776 +0,0 @@
- 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
deleted file mode 100644
index 86812da08..000000000
--- a/mex/sources/libslicot/SB01BX.f
+++ /dev/null
@@ -1,150 +0,0 @@
- 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
deleted file mode 100644
index 58b480138..000000000
--- a/mex/sources/libslicot/SB01BY.f
+++ /dev/null
@@ -1,332 +0,0 @@
- 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
deleted file mode 100644
index 15ab1b8e9..000000000
--- a/mex/sources/libslicot/SB01DD.f
+++ /dev/null
@@ -1,643 +0,0 @@
- 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
deleted file mode 100644
index 20a716ba1..000000000
--- a/mex/sources/libslicot/SB01FY.f
+++ /dev/null
@@ -1,315 +0,0 @@
- 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
deleted file mode 100644
index cc6abc4d8..000000000
--- a/mex/sources/libslicot/SB01MD.f
+++ /dev/null
@@ -1,397 +0,0 @@
- 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
deleted file mode 100644
index d84f72178..000000000
--- a/mex/sources/libslicot/SB02CX.f
+++ /dev/null
@@ -1,94 +0,0 @@
- 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
deleted file mode 100644
index 4e517d346..000000000
--- a/mex/sources/libslicot/SB02MD.f
+++ /dev/null
@@ -1,559 +0,0 @@
- 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
deleted file mode 100644
index f306a1b93..000000000
--- a/mex/sources/libslicot/SB02MR.f
+++ /dev/null
@@ -1,75 +0,0 @@
- 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
deleted file mode 100644
index 1e8481eb7..000000000
--- a/mex/sources/libslicot/SB02MS.f
+++ /dev/null
@@ -1,79 +0,0 @@
- 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
deleted file mode 100644
index 7106bd971..000000000
--- a/mex/sources/libslicot/SB02MT.f
+++ /dev/null
@@ -1,581 +0,0 @@
- 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
deleted file mode 100644
index 567a22476..000000000
--- a/mex/sources/libslicot/SB02MU.f
+++ /dev/null
@@ -1,486 +0,0 @@
- 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
deleted file mode 100644
index 5dc8e2452..000000000
--- a/mex/sources/libslicot/SB02MV.f
+++ /dev/null
@@ -1,75 +0,0 @@
- 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
deleted file mode 100644
index eb54ebae9..000000000
--- a/mex/sources/libslicot/SB02MW.f
+++ /dev/null
@@ -1,79 +0,0 @@
- 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
deleted file mode 100644
index 1f446c023..000000000
--- a/mex/sources/libslicot/SB02ND.f
+++ /dev/null
@@ -1,755 +0,0 @@
- 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
deleted file mode 100644
index 7408ba397..000000000
--- a/mex/sources/libslicot/SB02OD.f
+++ /dev/null
@@ -1,856 +0,0 @@
- SUBROUTINE SB02OD( DICO, JOBB, FACT, UPLO, JOBL, SORT, N, M, P, A,
- $ LDA, B, LDB, Q, LDQ, R, LDR, L, LDL, RCOND, X,
- $ LDX, ALFAR, ALFAI, BETA, S, LDS, T, LDT, U,
- $ LDU, TOL, IWORK, DWORK, LDWORK, BWORK, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have 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
deleted file mode 100644
index 530d202f6..000000000
--- a/mex/sources/libslicot/SB02OU.f
+++ /dev/null
@@ -1,83 +0,0 @@
- 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
deleted file mode 100644
index db114ae96..000000000
--- a/mex/sources/libslicot/SB02OV.f
+++ /dev/null
@@ -1,88 +0,0 @@
- 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
deleted file mode 100644
index 11de0b233..000000000
--- a/mex/sources/libslicot/SB02OW.f
+++ /dev/null
@@ -1,83 +0,0 @@
- 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
deleted file mode 100644
index b3f90b53b..000000000
--- a/mex/sources/libslicot/SB02OX.f
+++ /dev/null
@@ -1,87 +0,0 @@
- 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
deleted file mode 100644
index 367befee2..000000000
--- a/mex/sources/libslicot/SB02OY.f
+++ /dev/null
@@ -1,791 +0,0 @@
- SUBROUTINE SB02OY( TYPE, DICO, JOBB, FACT, UPLO, JOBL, JOBE, N, M,
- $ P, A, LDA, B, LDB, Q, LDQ, R, LDR, L, LDL, E,
- $ LDE, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK,
- $ LDWORK, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have 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
deleted file mode 100644
index fe63ddfca..000000000
--- a/mex/sources/libslicot/SB02PD.f
+++ /dev/null
@@ -1,756 +0,0 @@
- 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
deleted file mode 100644
index 8ce39d1b3..000000000
--- a/mex/sources/libslicot/SB02QD.f
+++ /dev/null
@@ -1,804 +0,0 @@
- SUBROUTINE SB02QD( JOB, FACT, TRANA, UPLO, LYAPUN, N, A, LDA, T,
- $ LDT, U, LDU, G, LDG, Q, LDQ, X, LDX, SEP,
- $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have 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
deleted file mode 100644
index e4d14172f..000000000
--- a/mex/sources/libslicot/SB02RD.f
+++ /dev/null
@@ -1,1133 +0,0 @@
- SUBROUTINE SB02RD( JOB, DICO, HINV, TRANA, UPLO, SCAL, SORT, FACT,
- $ LYAPUN, N, A, LDA, T, LDT, V, LDV, G, LDG, Q,
- $ LDQ, X, LDX, SEP, RCOND, FERR, WR, WI, S, LDS,
- $ IWORK, DWORK, LDWORK, BWORK, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have 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
deleted file mode 100644
index 947d18148..000000000
--- a/mex/sources/libslicot/SB02RU.f
+++ /dev/null
@@ -1,508 +0,0 @@
- SUBROUTINE SB02RU( DICO, HINV, TRANA, UPLO, N, A, LDA, G, LDG, Q,
- $ LDQ, S, LDS, IWORK, DWORK, LDWORK, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have 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
deleted file mode 100644
index 81685c3b6..000000000
--- a/mex/sources/libslicot/SB02SD.f
+++ /dev/null
@@ -1,859 +0,0 @@
- SUBROUTINE SB02SD( JOB, FACT, TRANA, UPLO, LYAPUN, N, A, LDA, T,
- $ LDT, U, LDU, G, LDG, Q, LDQ, X, LDX, SEPD,
- $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have 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
deleted file mode 100644
index 986998155..000000000
--- a/mex/sources/libslicot/SB03MD.f
+++ /dev/null
@@ -1,556 +0,0 @@
- 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
deleted file mode 100644
index 69ddd7429..000000000
--- a/mex/sources/libslicot/SB03MU.f
+++ /dev/null
@@ -1,467 +0,0 @@
- 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
deleted file mode 100644
index 30dcc6af0..000000000
--- a/mex/sources/libslicot/SB03MV.f
+++ /dev/null
@@ -1,295 +0,0 @@
- SUBROUTINE SB03MV( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX,
- $ XNORM, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have 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
deleted file mode 100644
index 8a0a51202..000000000
--- a/mex/sources/libslicot/SB03MW.f
+++ /dev/null
@@ -1,293 +0,0 @@
- SUBROUTINE SB03MW( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX,
- $ XNORM, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have 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
deleted file mode 100644
index 31b392998..000000000
--- a/mex/sources/libslicot/SB03MX.f
+++ /dev/null
@@ -1,711 +0,0 @@
- SUBROUTINE SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have 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
deleted file mode 100644
index 6aa1642cd..000000000
--- a/mex/sources/libslicot/SB03MY.f
+++ /dev/null
@@ -1,613 +0,0 @@
- SUBROUTINE SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have 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
deleted file mode 100644
index 0b93c7472..000000000
--- a/mex/sources/libslicot/SB03OD.f
+++ /dev/null
@@ -1,662 +0,0 @@
- 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
deleted file mode 100644
index 1094f26f5..000000000
--- a/mex/sources/libslicot/SB03OR.f
+++ /dev/null
@@ -1,429 +0,0 @@
- 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
deleted file mode 100644
index 92550bf56..000000000
--- a/mex/sources/libslicot/SB03OT.f
+++ /dev/null
@@ -1,984 +0,0 @@
- 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
deleted file mode 100644
index d9ae8cb17..000000000
--- a/mex/sources/libslicot/SB03OU.f
+++ /dev/null
@@ -1,410 +0,0 @@
- 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
deleted file mode 100644
index bd92699b8..000000000
--- a/mex/sources/libslicot/SB03OV.f
+++ /dev/null
@@ -1,105 +0,0 @@
- 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
deleted file mode 100644
index 44a94b979..000000000
--- a/mex/sources/libslicot/SB03OY.f
+++ /dev/null
@@ -1,693 +0,0 @@
- 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
deleted file mode 100644
index 8cef1572f..000000000
--- a/mex/sources/libslicot/SB03PD.f
+++ /dev/null
@@ -1,410 +0,0 @@
- 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
deleted file mode 100644
index 5f8ccf886..000000000
--- a/mex/sources/libslicot/SB03QD.f
+++ /dev/null
@@ -1,676 +0,0 @@
- 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
deleted file mode 100644
index 255ca13a0..000000000
--- a/mex/sources/libslicot/SB03QX.f
+++ /dev/null
@@ -1,394 +0,0 @@
- SUBROUTINE SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU,
- $ R, LDR, FERR, IWORK, DWORK, LDWORK, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have 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
deleted file mode 100644
index 63f41f5b8..000000000
--- a/mex/sources/libslicot/SB03QY.f
+++ /dev/null
@@ -1,443 +0,0 @@
- SUBROUTINE SB03QY( JOB, TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX,
- $ SEP, THNORM, IWORK, DWORK, LDWORK, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have 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
deleted file mode 100644
index 0398a3abc..000000000
--- a/mex/sources/libslicot/SB03RD.f
+++ /dev/null
@@ -1,404 +0,0 @@
- 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
deleted file mode 100644
index bcf122954..000000000
--- a/mex/sources/libslicot/SB03SD.f
+++ /dev/null
@@ -1,674 +0,0 @@
- 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
deleted file mode 100644
index 58078b80d..000000000
--- a/mex/sources/libslicot/SB03SX.f
+++ /dev/null
@@ -1,398 +0,0 @@
- SUBROUTINE SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU,
- $ R, LDR, FERR, IWORK, DWORK, LDWORK, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have 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
deleted file mode 100644
index 8cdc0c9bb..000000000
--- a/mex/sources/libslicot/SB03SY.f
+++ /dev/null
@@ -1,451 +0,0 @@
- SUBROUTINE SB03SY( JOB, TRANA, LYAPUN, N, T, LDT, U, LDU, XA,
- $ LDXA, SEPD, THNORM, IWORK, DWORK, LDWORK,
- $ INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have 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
deleted file mode 100644
index a1a81961f..000000000
--- a/mex/sources/libslicot/SB03TD.f
+++ /dev/null
@@ -1,545 +0,0 @@
- 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
deleted file mode 100644
index f09443eb7..000000000
--- a/mex/sources/libslicot/SB03UD.f
+++ /dev/null
@@ -1,554 +0,0 @@
- 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
deleted file mode 100644
index c618c8ac7..000000000
--- a/mex/sources/libslicot/SB04MD.f
+++ /dev/null
@@ -1,347 +0,0 @@
- 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
deleted file mode 100644
index a8aa560cd..000000000
--- a/mex/sources/libslicot/SB04MR.f
+++ /dev/null
@@ -1,222 +0,0 @@
- 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
deleted file mode 100644
index ed3879eca..000000000
--- a/mex/sources/libslicot/SB04MU.f
+++ /dev/null
@@ -1,190 +0,0 @@
- 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
deleted file mode 100644
index 9a56f4658..000000000
--- a/mex/sources/libslicot/SB04MW.f
+++ /dev/null
@@ -1,194 +0,0 @@
- 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
deleted file mode 100644
index d8e568e7d..000000000
--- a/mex/sources/libslicot/SB04MY.f
+++ /dev/null
@@ -1,168 +0,0 @@
- 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
deleted file mode 100644
index b567088ac..000000000
--- a/mex/sources/libslicot/SB04ND.f
+++ /dev/null
@@ -1,405 +0,0 @@
- 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
deleted file mode 100644
index bb09f2778..000000000
--- a/mex/sources/libslicot/SB04NV.f
+++ /dev/null
@@ -1,165 +0,0 @@
- 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
deleted file mode 100644
index a2a52aa82..000000000
--- a/mex/sources/libslicot/SB04NW.f
+++ /dev/null
@@ -1,155 +0,0 @@
- 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
deleted file mode 100644
index ac9ecf524..000000000
--- a/mex/sources/libslicot/SB04NX.f
+++ /dev/null
@@ -1,320 +0,0 @@
- 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
deleted file mode 100644
index 5a0b9c62b..000000000
--- a/mex/sources/libslicot/SB04NY.f
+++ /dev/null
@@ -1,260 +0,0 @@
- 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
deleted file mode 100644
index 6a11ffa76..000000000
--- a/mex/sources/libslicot/SB04OD.f
+++ /dev/null
@@ -1,1028 +0,0 @@
- 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
deleted file mode 100644
index c3d613afd..000000000
--- a/mex/sources/libslicot/SB04OW.f
+++ /dev/null
@@ -1,568 +0,0 @@
- 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
deleted file mode 100644
index a2e5899a4..000000000
--- a/mex/sources/libslicot/SB04PD.f
+++ /dev/null
@@ -1,672 +0,0 @@
- 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
deleted file mode 100644
index 99bd63d3b..000000000
--- a/mex/sources/libslicot/SB04PX.f
+++ /dev/null
@@ -1,468 +0,0 @@
- SUBROUTINE SB04PX( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR,
- $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )
-C
-C SLICOT RELEASE 5.0.
-C
-C Copyright (c) 2002-2009 NICONET e.V.
-C
-C This program is free software: you can redistribute it and/or
-C modify it under the terms of the GNU General Public License as
-C published by the Free Software Foundation, either version 2 of
-C the License, or (at your option) any later version.
-C
-C This program is distributed in the hope that it will be useful,
-C but WITHOUT ANY WARRANTY; without even the implied warranty of
-C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
-C You should have 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
deleted file mode 100644
index 46b81f880..000000000
--- a/mex/sources/libslicot/SB04PY.f
+++ /dev/null
@@ -1,1111 +0,0 @@
- 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
deleted file mode 100644
index 29ceae423..000000000
--- a/mex/sources/libslicot/SB04QD.f
+++ /dev/null
@@ -1,376 +0,0 @@
- 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
deleted file mode 100644
index 77231d322..000000000
--- a/mex/sources/libslicot/SB04QR.f
+++ /dev/null
@@ -1,224 +0,0 @@
- 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
deleted file mode 100644
index 2a53f1e3b..000000000
--- a/mex/sources/libslicot/SB04QU.f
+++ /dev/null
@@ -1,218 +0,0 @@
- 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
deleted file mode 100644
index f351a2f4e..000000000
--- a/mex/sources/libslicot/SB04QY.f
+++ /dev/null
@@ -1,185 +0,0 @@
- 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
deleted file mode 100644
index 6fd6feaec..000000000
--- a/mex/sources/libslicot/SB04RD.f
+++ /dev/null
@@ -1,406 +0,0 @@
- 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
deleted file mode 100644
index a385fb8ae..000000000
--- a/mex/sources/libslicot/SB04RV.f
+++ /dev/null
@@ -1,198 +0,0 @@
- 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
deleted file mode 100644
index 9dc815c67..000000000
--- a/mex/sources/libslicot/SB04RW.f
+++ /dev/null
@@ -1,178 +0,0 @@
- 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
deleted file mode 100644
index e84bb188d..000000000
--- a/mex/sources/libslicot/SB04RX.f
+++ /dev/null
@@ -1,375 +0,0 @@
- 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
deleted file mode 100644
index 2ea8fd91e..000000000
--- a/mex/sources/libslicot/SB04RY.f
+++ /dev/null
@@ -1,261 +0,0 @@
- 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
deleted file mode 100644
index 3ea986376..000000000
--- a/mex/sources/libslicot/SB06ND.f
+++ /dev/null
@@ -1,325 +0,0 @@
- 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
deleted file mode 100644
index ed703beb5..000000000
--- a/mex/sources/libslicot/SB08CD.f
+++ /dev/null
@@ -1,355 +0,0 @@
- 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
deleted file mode 100644
index e88c9028d..000000000
--- a/mex/sources/libslicot/SB08DD.f
+++ /dev/null
@@ -1,583 +0,0 @@
- 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
deleted file mode 100644
index b171c4a16..000000000
--- a/mex/sources/libslicot/SB08ED.f
+++ /dev/null
@@ -1,359 +0,0 @@
- 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
deleted file mode 100644
index 54a21b1d9..000000000
--- a/mex/sources/libslicot/SB08FD.f
+++ /dev/null
@@ -1,630 +0,0 @@
- 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
deleted file mode 100644
index 0368fdf78..000000000
--- a/mex/sources/libslicot/SB08GD.f
+++ /dev/null
@@ -1,256 +0,0 @@
- 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
deleted file mode 100644
index b1a2227d9..000000000
--- a/mex/sources/libslicot/SB08HD.f
+++ /dev/null
@@ -1,267 +0,0 @@
- 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
deleted file mode 100644
index 78f6d46c2..000000000
--- a/mex/sources/libslicot/SB08MD.f
+++ /dev/null
@@ -1,471 +0,0 @@
- 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
deleted file mode 100644
index 085be630a..000000000
--- a/mex/sources/libslicot/SB08MY.f
+++ /dev/null
@@ -1,102 +0,0 @@
- 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
deleted file mode 100644
index ced79b329..000000000
--- a/mex/sources/libslicot/SB08ND.f
+++ /dev/null
@@ -1,382 +0,0 @@
- 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
deleted file mode 100644
index f6c0cb668..000000000
--- a/mex/sources/libslicot/SB08NY.f
+++ /dev/null
@@ -1,83 +0,0 @@
- 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
deleted file mode 100644
index edb0e2d1a..000000000
--- a/mex/sources/libslicot/SB09MD.f
+++ /dev/null
@@ -1,251 +0,0 @@
- 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
deleted file mode 100644
index a74b3a8ee..000000000
--- a/mex/sources/libslicot/SB10AD.f
+++ /dev/null
@@ -1,827 +0,0 @@
- 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
deleted file mode 100644
index b6a99f7b9..000000000
--- a/mex/sources/libslicot/SB10DD.f
+++ /dev/null
@@ -1,1007 +0,0 @@
- 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
deleted file mode 100644
index 51f7f048f..000000000
--- a/mex/sources/libslicot/SB10ED.f
+++ /dev/null
@@ -1,468 +0,0 @@
- 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
deleted file mode 100644
index 61fcdd4f3..000000000
--- a/mex/sources/libslicot/SB10FD.f
+++ /dev/null
@@ -1,469 +0,0 @@
- 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
deleted file mode 100644
index 5e350a98c..000000000
--- a/mex/sources/libslicot/SB10HD.f
+++ /dev/null
@@ -1,390 +0,0 @@
- 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
deleted file mode 100644
index 2ea302e96..000000000
--- a/mex/sources/libslicot/SB10ID.f
+++ /dev/null
@@ -1,584 +0,0 @@
- 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
deleted file mode 100644
index 938b65088..000000000
--- a/mex/sources/libslicot/SB10JD.f
+++ /dev/null
@@ -1,355 +0,0 @@
- 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
deleted file mode 100644
index 38f1cef01..000000000
--- a/mex/sources/libslicot/SB10KD.f
+++ /dev/null
@@ -1,650 +0,0 @@
- 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
deleted file mode 100644
index b2d7d06b3..000000000
--- a/mex/sources/libslicot/SB10LD.f
+++ /dev/null
@@ -1,438 +0,0 @@
- 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
deleted file mode 100644
index 46ea3d84b..000000000
--- a/mex/sources/libslicot/SB10MD.f
+++ /dev/null
@@ -1,670 +0,0 @@
- 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
deleted file mode 100644
index 617bdd29b..000000000
--- a/mex/sources/libslicot/SB10PD.f
+++ /dev/null
@@ -1,505 +0,0 @@
- 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
deleted file mode 100644
index 6b64f8396..000000000
--- a/mex/sources/libslicot/SB10QD.f
+++ /dev/null
@@ -1,602 +0,0 @@
- 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
deleted file mode 100644
index 86d483bb3..000000000
--- a/mex/sources/libslicot/SB10RD.f
+++ /dev/null
@@ -1,706 +0,0 @@
- 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
deleted file mode 100644
index ee99c78f2..000000000
--- a/mex/sources/libslicot/SB10SD.f
+++ /dev/null
@@ -1,629 +0,0 @@
- 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
deleted file mode 100644
index e8d193b41..000000000
--- a/mex/sources/libslicot/SB10TD.f
+++ /dev/null
@@ -1,350 +0,0 @@
- 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
deleted file mode 100644
index b5919d442..000000000
--- a/mex/sources/libslicot/SB10UD.f
+++ /dev/null
@@ -1,419 +0,0 @@
- 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
deleted file mode 100644
index 913a5ab29..000000000
--- a/mex/sources/libslicot/SB10VD.f
+++ /dev/null
@@ -1,393 +0,0 @@
- 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
deleted file mode 100644
index e2f37b2f3..000000000
--- a/mex/sources/libslicot/SB10WD.f
+++ /dev/null
@@ -1,299 +0,0 @@
- 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
deleted file mode 100644
index fa84e9f01..000000000
--- a/mex/sources/libslicot/SB10YD.f
+++ /dev/null
@@ -1,689 +0,0 @@
- 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
deleted file mode 100644
index f70c834dd..000000000
--- a/mex/sources/libslicot/SB10ZD.f
+++ /dev/null
@@ -1,914 +0,0 @@
- 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
deleted file mode 100644
index efaa9ac14..000000000
--- a/mex/sources/libslicot/SB10ZP.f
+++ /dev/null
@@ -1,339 +0,0 @@
- 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
deleted file mode 100644
index 565147c9f..000000000
--- a/mex/sources/libslicot/SB16AD.f
+++ /dev/null
@@ -1,719 +0,0 @@
- 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
deleted file mode 100644
index 51438021e..000000000
--- a/mex/sources/libslicot/SB16AY.f
+++ /dev/null
@@ -1,909 +0,0 @@
- 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
deleted file mode 100644
index 0141f1d0c..000000000
--- a/mex/sources/libslicot/SB16BD.f
+++ /dev/null
@@ -1,652 +0,0 @@
- 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
deleted file mode 100644
index 677a916d7..000000000
--- a/mex/sources/libslicot/SB16CD.f
+++ /dev/null
@@ -1,526 +0,0 @@
- 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
deleted file mode 100644
index 34ebaae79..000000000
--- a/mex/sources/libslicot/SB16CY.f
+++ /dev/null
@@ -1,409 +0,0 @@
- 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
deleted file mode 100644
index e7a9d9782..000000000
--- a/mex/sources/libslicot/SG02AD.f
+++ /dev/null
@@ -1,939 +0,0 @@
- 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
deleted file mode 100644
index a08e218ca..000000000
--- a/mex/sources/libslicot/SG03AD.f
+++ /dev/null
@@ -1,639 +0,0 @@
- 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
deleted file mode 100644
index 872ed0282..000000000
--- a/mex/sources/libslicot/SG03AX.f
+++ /dev/null
@@ -1,687 +0,0 @@
- 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
deleted file mode 100644
index 4f2dfe5ab..000000000
--- a/mex/sources/libslicot/SG03AY.f
+++ /dev/null
@@ -1,686 +0,0 @@
- 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
deleted file mode 100644
index 6bcd7400b..000000000
--- a/mex/sources/libslicot/SG03BD.f
+++ /dev/null
@@ -1,814 +0,0 @@
- 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
deleted file mode 100644
index 0e1084f96..000000000
--- a/mex/sources/libslicot/SG03BU.f
+++ /dev/null
@@ -1,696 +0,0 @@
- 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
deleted file mode 100644
index edce6f0dc..000000000
--- a/mex/sources/libslicot/SG03BV.f
+++ /dev/null
@@ -1,645 +0,0 @@
- 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
deleted file mode 100644
index aed45369f..000000000
--- a/mex/sources/libslicot/SG03BW.f
+++ /dev/null
@@ -1,459 +0,0 @@
- 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
deleted file mode 100644
index 651716cd9..000000000
--- a/mex/sources/libslicot/SG03BX.f
+++ /dev/null
@@ -1,764 +0,0 @@
- 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
deleted file mode 100644
index 356fe0423..000000000
--- a/mex/sources/libslicot/SG03BY.f
+++ /dev/null
@@ -1,93 +0,0 @@
- 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
deleted file mode 100644
index 9dbedb634..000000000
--- a/mex/sources/libslicot/TB01ID.f
+++ /dev/null
@@ -1,402 +0,0 @@
- 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
deleted file mode 100644
index e719aa390..000000000
--- a/mex/sources/libslicot/TB01IZ.f
+++ /dev/null
@@ -1,409 +0,0 @@
- 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
deleted file mode 100644
index a3d0a85d2..000000000
--- a/mex/sources/libslicot/TB01KD.f
+++ /dev/null
@@ -1,334 +0,0 @@
- 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
deleted file mode 100644
index 50f64c914..000000000
--- a/mex/sources/libslicot/TB01LD.f
+++ /dev/null
@@ -1,348 +0,0 @@
- 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
deleted file mode 100644
index b63aacee0..000000000
--- a/mex/sources/libslicot/TB01MD.f
+++ /dev/null
@@ -1,338 +0,0 @@
- 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
deleted file mode 100644
index cc93dd3ac..000000000
--- a/mex/sources/libslicot/TB01ND.f
+++ /dev/null
@@ -1,349 +0,0 @@
- 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
deleted file mode 100644
index c1c9594bd..000000000
--- a/mex/sources/libslicot/TB01PD.f
+++ /dev/null
@@ -1,352 +0,0 @@
- 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
deleted file mode 100644
index 7c52957ad..000000000
--- a/mex/sources/libslicot/TB01TD.f
+++ /dev/null
@@ -1,308 +0,0 @@
- 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
deleted file mode 100644
index 6dada6fa4..000000000
--- a/mex/sources/libslicot/TB01TY.f
+++ /dev/null
@@ -1,136 +0,0 @@
- 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
deleted file mode 100644
index 191780145..000000000
--- a/mex/sources/libslicot/TB01UD.f
+++ /dev/null
@@ -1,491 +0,0 @@
- 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
deleted file mode 100644
index 26cd1c7c3..000000000
--- a/mex/sources/libslicot/TB01VD.f
+++ /dev/null
@@ -1,503 +0,0 @@
- 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
deleted file mode 100644
index d18361a20..000000000
--- a/mex/sources/libslicot/TB01VY.f
+++ /dev/null
@@ -1,317 +0,0 @@
- 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
deleted file mode 100644
index 36dd01231..000000000
--- a/mex/sources/libslicot/TB01WD.f
+++ /dev/null
@@ -1,259 +0,0 @@
- 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
deleted file mode 100644
index 78bf92957..000000000
--- a/mex/sources/libslicot/TB01XD.f
+++ /dev/null
@@ -1,284 +0,0 @@
- 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
deleted file mode 100644
index ef73d0ce3..000000000
--- a/mex/sources/libslicot/TB01XZ.f
+++ /dev/null
@@ -1,280 +0,0 @@
- 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
deleted file mode 100644
index f653ffab5..000000000
--- a/mex/sources/libslicot/TB01YD.f
+++ /dev/null
@@ -1,188 +0,0 @@
- 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
deleted file mode 100644
index 6f8acc3a4..000000000
--- a/mex/sources/libslicot/TB01ZD.f
+++ /dev/null
@@ -1,440 +0,0 @@
- 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
deleted file mode 100644
index 318c2f323..000000000
--- a/mex/sources/libslicot/TB03AD.f
+++ /dev/null
@@ -1,746 +0,0 @@
- 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
deleted file mode 100644
index eeffc6e23..000000000
--- a/mex/sources/libslicot/TB03AY.f
+++ /dev/null
@@ -1,159 +0,0 @@
- 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
deleted file mode 100644
index d864d1914..000000000
--- a/mex/sources/libslicot/TB04AD.f
+++ /dev/null
@@ -1,395 +0,0 @@
- 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
deleted file mode 100644
index afce62c3b..000000000
--- a/mex/sources/libslicot/TB04AY.f
+++ /dev/null
@@ -1,246 +0,0 @@
- 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
deleted file mode 100644
index 0d8d5d0c0..000000000
--- a/mex/sources/libslicot/TB04BD.f
+++ /dev/null
@@ -1,600 +0,0 @@
- 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
deleted file mode 100644
index 10b58b592..000000000
--- a/mex/sources/libslicot/TB04BV.f
+++ /dev/null
@@ -1,343 +0,0 @@
- 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
deleted file mode 100644
index 7fb2a3217..000000000
--- a/mex/sources/libslicot/TB04BW.f
+++ /dev/null
@@ -1,280 +0,0 @@
- 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
deleted file mode 100644
index ff0e004f1..000000000
--- a/mex/sources/libslicot/TB04BX.f
+++ /dev/null
@@ -1,246 +0,0 @@
- 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
deleted file mode 100644
index 012548bec..000000000
--- a/mex/sources/libslicot/TB04CD.f
+++ /dev/null
@@ -1,568 +0,0 @@
- 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
deleted file mode 100644
index c7b93e918..000000000
--- a/mex/sources/libslicot/TB05AD.f
+++ /dev/null
@@ -1,545 +0,0 @@
- 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
deleted file mode 100644
index 3e7bd25ad..000000000
--- a/mex/sources/libslicot/TC01OD.f
+++ /dev/null
@@ -1,236 +0,0 @@
- 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
deleted file mode 100644
index d0ce99d13..000000000
--- a/mex/sources/libslicot/TC04AD.f
+++ /dev/null
@@ -1,483 +0,0 @@
- 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
deleted file mode 100644
index fc9f65ab0..000000000
--- a/mex/sources/libslicot/TC05AD.f
+++ /dev/null
@@ -1,403 +0,0 @@
- 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
deleted file mode 100644
index b06678a78..000000000
--- a/mex/sources/libslicot/TD03AD.f
+++ /dev/null
@@ -1,581 +0,0 @@
- 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
deleted file mode 100644
index 90d53eee2..000000000
--- a/mex/sources/libslicot/TD03AY.f
+++ /dev/null
@@ -1,171 +0,0 @@
- 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
deleted file mode 100644
index 9297cee09..000000000
--- a/mex/sources/libslicot/TD04AD.f
+++ /dev/null
@@ -1,425 +0,0 @@
- 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
deleted file mode 100644
index 0b527c4aa..000000000
--- a/mex/sources/libslicot/TD05AD.f
+++ /dev/null
@@ -1,314 +0,0 @@
- 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
deleted file mode 100644
index 1b33b81ca..000000000
--- a/mex/sources/libslicot/TF01MD.f
+++ /dev/null
@@ -1,233 +0,0 @@
- 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
deleted file mode 100644
index aaaf7aaff..000000000
--- a/mex/sources/libslicot/TF01MX.f
+++ /dev/null
@@ -1,457 +0,0 @@
- 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
deleted file mode 100644
index 85e31c05b..000000000
--- a/mex/sources/libslicot/TF01MY.f
+++ /dev/null
@@ -1,358 +0,0 @@
- 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
deleted file mode 100644
index 04676e7e5..000000000
--- a/mex/sources/libslicot/TF01ND.f
+++ /dev/null
@@ -1,278 +0,0 @@
- 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
deleted file mode 100644
index 656d86c9d..000000000
--- a/mex/sources/libslicot/TF01OD.f
+++ /dev/null
@@ -1,179 +0,0 @@
- 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
deleted file mode 100644
index e45f078b6..000000000
--- a/mex/sources/libslicot/TF01PD.f
+++ /dev/null
@@ -1,178 +0,0 @@
- 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
deleted file mode 100644
index a2d3696ce..000000000
--- a/mex/sources/libslicot/TF01QD.f
+++ /dev/null
@@ -1,234 +0,0 @@
- 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
deleted file mode 100644
index d28a6ed98..000000000
--- a/mex/sources/libslicot/TF01RD.f
+++ /dev/null
@@ -1,230 +0,0 @@
- 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
deleted file mode 100644
index 5bae2d7bf..000000000
--- a/mex/sources/libslicot/TG01AD.f
+++ /dev/null
@@ -1,513 +0,0 @@
- 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
deleted file mode 100644
index 2c0bb3bcf..000000000
--- a/mex/sources/libslicot/TG01AZ.f
+++ /dev/null
@@ -1,523 +0,0 @@
- 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
deleted file mode 100644
index 3a0681e5e..000000000
--- a/mex/sources/libslicot/TG01BD.f
+++ /dev/null
@@ -1,434 +0,0 @@
- 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
deleted file mode 100644
index 1ce07b1e4..000000000
--- a/mex/sources/libslicot/TG01CD.f
+++ /dev/null
@@ -1,292 +0,0 @@
- 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
deleted file mode 100644
index cac8704d8..000000000
--- a/mex/sources/libslicot/TG01DD.f
+++ /dev/null
@@ -1,295 +0,0 @@
- 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
deleted file mode 100644
index 1fe8e8bba..000000000
--- a/mex/sources/libslicot/TG01ED.f
+++ /dev/null
@@ -1,793 +0,0 @@
- 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
deleted file mode 100644
index c50d5fc95..000000000
--- a/mex/sources/libslicot/TG01FD.f
+++ /dev/null
@@ -1,725 +0,0 @@
- 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
deleted file mode 100644
index 5d8f59509..000000000
--- a/mex/sources/libslicot/TG01FZ.f
+++ /dev/null
@@ -1,733 +0,0 @@
- 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
deleted file mode 100644
index 318f1f353..000000000
--- a/mex/sources/libslicot/TG01HD.f
+++ /dev/null
@@ -1,545 +0,0 @@
- 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
deleted file mode 100644
index c0717f81a..000000000
--- a/mex/sources/libslicot/TG01HX.f
+++ /dev/null
@@ -1,694 +0,0 @@
- 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
deleted file mode 100644
index dfd3888a3..000000000
--- a/mex/sources/libslicot/TG01ID.f
+++ /dev/null
@@ -1,587 +0,0 @@
- 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
deleted file mode 100644
index 93cecec4e..000000000
--- a/mex/sources/libslicot/TG01JD.f
+++ /dev/null
@@ -1,613 +0,0 @@
- 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
deleted file mode 100644
index 26d06848e..000000000
--- a/mex/sources/libslicot/TG01WD.f
+++ /dev/null
@@ -1,319 +0,0 @@
- 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
deleted file mode 100644
index 256984c17..000000000
--- a/mex/sources/libslicot/UD01BD.f
+++ /dev/null
@@ -1,149 +0,0 @@
- 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
deleted file mode 100644
index 52a104558..000000000
--- a/mex/sources/libslicot/UD01CD.f
+++ /dev/null
@@ -1,174 +0,0 @@
- 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
deleted file mode 100644
index d09cadbd3..000000000
--- a/mex/sources/libslicot/UD01DD.f
+++ /dev/null
@@ -1,138 +0,0 @@
- 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
deleted file mode 100644
index a44e6545c..000000000
--- a/mex/sources/libslicot/UD01MD.f
+++ /dev/null
@@ -1,175 +0,0 @@
- 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
deleted file mode 100644
index a9d83f706..000000000
--- a/mex/sources/libslicot/UD01MZ.f
+++ /dev/null
@@ -1,175 +0,0 @@
- 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
deleted file mode 100644
index 1791f9865..000000000
--- a/mex/sources/libslicot/UD01ND.f
+++ /dev/null
@@ -1,203 +0,0 @@
- 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
deleted file mode 100644
index c460bf9bf..000000000
--- a/mex/sources/libslicot/UE01MD.f
+++ /dev/null
@@ -1,266 +0,0 @@
- 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
deleted file mode 100644
index c4acbeb5a..000000000
--- a/mex/sources/libslicot/dcabs1.f
+++ /dev/null
@@ -1,16 +0,0 @@
- 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
deleted file mode 100644
index b6b44b7c8..000000000
--- a/mex/sources/libslicot/delctg.f
+++ /dev/null
@@ -1,27 +0,0 @@
- 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
deleted file mode 100644
index 2269451e1..000000000
--- a/mex/sources/libslicot/dhgeqz.f
+++ /dev/null
@@ -1,1249 +0,0 @@
- 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
deleted file mode 100644
index 3486ec482..000000000
--- a/mex/sources/libslicot/dtgsy2.f
+++ /dev/null
@@ -1,956 +0,0 @@
- 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
deleted file mode 100644
index 85f5bce37..000000000
--- a/mex/sources/libslicot/readme
+++ /dev/null
@@ -1,8 +0,0 @@
-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
deleted file mode 100644
index dd3e62baf..000000000
--- a/mex/sources/libslicot/select.f
+++ /dev/null
@@ -1,27 +0,0 @@
- 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