Added the Slicot library (distributed under the GNU General Public Licence at www.slicot.org). This library provides routines
for the design and analysis of control systems. Adapted the building system to handle fortran 77 source files.time-shift
Stéphane Adjemian (Charybdis)
parent
e614227c3f
commit
382ab96cde
|
|
@ -33,6 +33,7 @@ case ${MATLAB_ARCH} in
|
|||
MATLAB_DEFS="$MATLAB_DEFS -D_GNU_SOURCE -DNDEBUG"
|
||||
MATLAB_CFLAGS="-ansi -fexceptions -fPIC -pthread -g -O2"
|
||||
MATLAB_CXXFLAGS="-ansi -fPIC -pthread -g -O2"
|
||||
MATLAB_FFLAGS="-fPIC -g -O2 -fexceptions"
|
||||
MATLAB_LDFLAGS="-shared -Wl,--version-script,$MATLAB/extern/lib/${MATLAB_ARCH}/mexFunction.map -Wl,--no-undefined -Wl,-rpath-link,$MATLAB/bin/${MATLAB_ARCH} -L$MATLAB/bin/${MATLAB_ARCH}"
|
||||
MATLAB_LIBS="-lmx -lmex -lmat -lm -lstdc++ -lmwlapack"
|
||||
# Starting from MATLAB 7.5, BLAS and LAPACK are in distinct libraries
|
||||
|
|
@ -50,6 +51,7 @@ case ${MATLAB_ARCH} in
|
|||
win32 | win64)
|
||||
MATLAB_CFLAGS="-fexceptions -g -O2"
|
||||
MATLAB_CXXFLAGS="-g -O2"
|
||||
MATLAB_FFLAGS="-fexceptions -g -O2"
|
||||
AX_COMPARE_VERSION([$MATLAB_VERSION], [eq], [7.0.1], [AC_MSG_ERROR([MATLAB version 7.0.1 (R14SP1) is buggy (LAPACK library missing for MSVC), and can't be used for compiling MEX files])])
|
||||
MATLAB_DEFS="$MATLAB_DEFS -DNDEBUG"
|
||||
# Note that static-libstdc++ is only supported since GCC 4.5 (but generates no error on older versions)
|
||||
|
|
@ -72,6 +74,7 @@ case ${MATLAB_ARCH} in
|
|||
MATLAB_LDFLAGS="-L$MATLAB/bin/${MATLAB_ARCH} -Wl,-twolevel_namespace -undefined error -arch $ARCHS -Wl,-syslibroot,$SDKROOT -mmacosx-version-min=$MACOSX_DEPLOYMENT_TARGET -bundle -Wl,-exported_symbols_list,\$(top_srcdir)/mexFunction-MacOSX.map"
|
||||
MATLAB_LIBS="-lmx -lmex -lmat -lstdc++ -lmwlapack"
|
||||
MATLAB_CXXFLAGS="-fno-common -no-cpp-precomp -fexceptions -arch $ARCHS -isysroot $SDKROOT -mmacosx-version-min=$MACOSX_DEPLOYMENT_TARGET -O2"
|
||||
MATLAB_CXXFLAGS="-fexceptions -fbackslash -g -O2"
|
||||
# Starting from MATLAB 7.5, BLAS and LAPACK are in distinct libraries
|
||||
AX_COMPARE_VERSION([$MATLAB_VERSION], [ge], [7.5], [MATLAB_LIBS="${MATLAB_LIBS} -lmwblas"])
|
||||
ax_mexopts_ok="yes"
|
||||
|
|
|
|||
|
|
@ -0,0 +1,484 @@
|
|||
vpath %.f $(top_srcdir)/../../sources/libslicot
|
||||
|
||||
noinst_LIBRARIES = libslicot.a libauxslicot.a
|
||||
|
||||
SLICOT_SRC = \
|
||||
AB01MD.f \
|
||||
AB01ND.f \
|
||||
AB01OD.f \
|
||||
AB04MD.f \
|
||||
AB05MD.f \
|
||||
AB05ND.f \
|
||||
AB05OD.f \
|
||||
AB05PD.f \
|
||||
AB05QD.f \
|
||||
AB05RD.f \
|
||||
AB05SD.f \
|
||||
AB07MD.f \
|
||||
AB07ND.f \
|
||||
AB08MD.f \
|
||||
AB08MZ.f \
|
||||
AB08ND.f \
|
||||
AB08NX.f \
|
||||
AB08NZ.f \
|
||||
AB09AD.f \
|
||||
AB09AX.f \
|
||||
AB09BD.f \
|
||||
AB09BX.f \
|
||||
AB09CD.f \
|
||||
AB09CX.f \
|
||||
AB09DD.f \
|
||||
AB09ED.f \
|
||||
AB09FD.f \
|
||||
AB09GD.f \
|
||||
AB09HD.f \
|
||||
AB09HX.f \
|
||||
AB09HY.f \
|
||||
AB09ID.f \
|
||||
AB09IX.f \
|
||||
AB09IY.f \
|
||||
AB09JD.f \
|
||||
AB09JV.f \
|
||||
AB09JW.f \
|
||||
AB09JX.f \
|
||||
AB09KD.f \
|
||||
AB09KX.f \
|
||||
AB09MD.f \
|
||||
AB09ND.f \
|
||||
AB13AD.f \
|
||||
AB13AX.f \
|
||||
AB13BD.f \
|
||||
AB13CD.f \
|
||||
AB13DD.f \
|
||||
AB13DX.f \
|
||||
AB13ED.f \
|
||||
AB13FD.f \
|
||||
AB13MD.f \
|
||||
AB8NXZ.f \
|
||||
AG07BD.f \
|
||||
AG08BD.f \
|
||||
AG08BY.f \
|
||||
AG08BZ.f \
|
||||
AG8BYZ.f \
|
||||
BB01AD.f \
|
||||
BB02AD.f \
|
||||
BB03AD.f \
|
||||
BB04AD.f \
|
||||
BD01AD.f \
|
||||
BD02AD.f \
|
||||
DE01OD.f \
|
||||
DE01PD.f \
|
||||
delctg.f \
|
||||
DF01MD.f \
|
||||
DG01MD.f \
|
||||
DG01ND.f \
|
||||
DG01NY.f \
|
||||
DG01OD.f \
|
||||
DK01MD.f \
|
||||
FB01QD.f \
|
||||
FB01RD.f \
|
||||
FB01SD.f \
|
||||
FB01TD.f \
|
||||
FB01VD.f \
|
||||
FD01AD.f \
|
||||
IB01AD.f \
|
||||
IB01BD.f \
|
||||
IB01CD.f \
|
||||
IB01MD.f \
|
||||
IB01MY.f \
|
||||
IB01ND.f \
|
||||
IB01OD.f \
|
||||
IB01OY.f \
|
||||
IB01PD.f \
|
||||
IB01PX.f \
|
||||
IB01PY.f \
|
||||
IB01QD.f \
|
||||
IB01RD.f \
|
||||
IB03AD.f \
|
||||
IB03BD.f \
|
||||
MA01AD.f \
|
||||
MA02AD.f \
|
||||
MA02BD.f \
|
||||
MA02BZ.f \
|
||||
MA02CD.f \
|
||||
MA02CZ.f \
|
||||
MA02DD.f \
|
||||
MA02ED.f \
|
||||
MA02FD.f \
|
||||
MA02GD.f \
|
||||
MA02HD.f \
|
||||
MA02ID.f \
|
||||
MA02JD.f \
|
||||
MB01MD.f \
|
||||
MB01ND.f \
|
||||
MB01PD.f \
|
||||
MB01QD.f \
|
||||
MB01RD.f \
|
||||
MB01RU.f \
|
||||
MB01RW.f \
|
||||
MB01RX.f \
|
||||
MB01RY.f \
|
||||
MB01SD.f \
|
||||
MB01TD.f \
|
||||
MB01UD.f \
|
||||
MB01UW.f \
|
||||
MB01UX.f \
|
||||
MB01VD.f \
|
||||
MB01WD.f \
|
||||
MB01XD.f \
|
||||
MB01XY.f \
|
||||
MB01YD.f \
|
||||
MB01ZD.f \
|
||||
MB02CD.f \
|
||||
MB02CU.f \
|
||||
MB02CV.f \
|
||||
MB02CX.f \
|
||||
MB02CY.f \
|
||||
MB02DD.f \
|
||||
MB02ED.f \
|
||||
MB02FD.f \
|
||||
MB02GD.f \
|
||||
MB02HD.f \
|
||||
MB02ID.f \
|
||||
MB02JD.f \
|
||||
MB02JX.f \
|
||||
MB02KD.f \
|
||||
MB02MD.f \
|
||||
MB02ND.f \
|
||||
MB02NY.f \
|
||||
MB02OD.f \
|
||||
MB02PD.f \
|
||||
MB02QD.f \
|
||||
MB02QY.f \
|
||||
MB02RD.f \
|
||||
MB02RZ.f \
|
||||
MB02SD.f \
|
||||
MB02SZ.f \
|
||||
MB02TD.f \
|
||||
MB02TZ.f \
|
||||
MB02UD.f \
|
||||
MB02UU.f \
|
||||
MB02UV.f \
|
||||
MB02VD.f \
|
||||
MB02WD.f \
|
||||
MB02XD.f \
|
||||
MB02YD.f \
|
||||
MB03MD.f \
|
||||
MB03MY.f \
|
||||
MB03ND.f \
|
||||
MB03NY.f \
|
||||
MB03OD.f \
|
||||
MB03OY.f \
|
||||
MB03PD.f \
|
||||
MB03PY.f \
|
||||
MB03QD.f \
|
||||
MB03QX.f \
|
||||
MB03QY.f \
|
||||
MB03RD.f \
|
||||
MB03RX.f \
|
||||
MB03RY.f \
|
||||
MB03SD.f \
|
||||
MB03TD.f \
|
||||
MB03TS.f \
|
||||
MB03UD.f \
|
||||
MB03VD.f \
|
||||
MB03VY.f \
|
||||
MB03WA.f \
|
||||
MB03WD.f \
|
||||
MB03WX.f \
|
||||
MB03XD.f \
|
||||
MB03XP.f \
|
||||
MB03XU.f \
|
||||
MB03YA.f \
|
||||
MB03YD.f \
|
||||
MB03YT.f \
|
||||
MB03ZA.f \
|
||||
MB03ZD.f \
|
||||
MB04DD.f \
|
||||
MB04DI.f \
|
||||
MB04DS.f \
|
||||
MB04DY.f \
|
||||
MB04GD.f \
|
||||
MB04ID.f \
|
||||
MB04IY.f \
|
||||
MB04IZ.f \
|
||||
MB04JD.f \
|
||||
MB04KD.f \
|
||||
MB04LD.f \
|
||||
MB04MD.f \
|
||||
MB04ND.f \
|
||||
MB04NY.f \
|
||||
MB04OD.f \
|
||||
MB04OW.f \
|
||||
MB04OX.f \
|
||||
MB04OY.f \
|
||||
MB04PA.f \
|
||||
MB04PB.f \
|
||||
MB04PU.f \
|
||||
MB04PY.f \
|
||||
MB04QB.f \
|
||||
MB04QC.f \
|
||||
MB04QF.f \
|
||||
MB04QU.f \
|
||||
MB04TB.f \
|
||||
MB04TS.f \
|
||||
MB04TT.f \
|
||||
MB04TU.f \
|
||||
MB04TV.f \
|
||||
MB04TW.f \
|
||||
MB04TX.f \
|
||||
MB04TY.f \
|
||||
MB04UD.f \
|
||||
MB04VD.f \
|
||||
MB04VX.f \
|
||||
MB04WD.f \
|
||||
MB04WP.f \
|
||||
MB04WR.f \
|
||||
MB04WU.f \
|
||||
MB04XD.f \
|
||||
MB04XY.f \
|
||||
MB04YD.f \
|
||||
MB04YW.f \
|
||||
MB04ZD.f \
|
||||
MB05MD.f \
|
||||
MB05MY.f \
|
||||
MB05ND.f \
|
||||
MB05OD.f \
|
||||
MB05OY.f \
|
||||
MB3OYZ.f \
|
||||
MB3PYZ.f \
|
||||
MC01MD.f \
|
||||
MC01ND.f \
|
||||
MC01OD.f \
|
||||
MC01PD.f \
|
||||
MC01PY.f \
|
||||
MC01QD.f \
|
||||
MC01RD.f \
|
||||
MC01SD.f \
|
||||
MC01SW.f \
|
||||
MC01SX.f \
|
||||
MC01SY.f \
|
||||
MC01TD.f \
|
||||
MC01VD.f \
|
||||
MC01WD.f \
|
||||
MC03MD.f \
|
||||
MC03ND.f \
|
||||
MC03NX.f \
|
||||
MC03NY.f \
|
||||
MD03AD.f \
|
||||
MD03BA.f \
|
||||
MD03BB.f \
|
||||
MD03BD.f \
|
||||
MD03BF.f \
|
||||
MD03BX.f \
|
||||
MD03BY.f \
|
||||
NF01AD.f \
|
||||
NF01AY.f \
|
||||
NF01BA.f \
|
||||
NF01BB.f \
|
||||
NF01BD.f \
|
||||
NF01BE.f \
|
||||
NF01BF.f \
|
||||
NF01BP.f \
|
||||
NF01BQ.f \
|
||||
NF01BR.f \
|
||||
NF01BS.f \
|
||||
NF01BU.f \
|
||||
NF01BV.f \
|
||||
NF01BW.f \
|
||||
NF01BX.f \
|
||||
NF01BY.f \
|
||||
SB01BD.f \
|
||||
SB01BX.f \
|
||||
SB01BY.f \
|
||||
SB01DD.f \
|
||||
SB01FY.f \
|
||||
SB01MD.f \
|
||||
SB02CX.f \
|
||||
SB02MD.f \
|
||||
SB02MR.f \
|
||||
SB02MS.f \
|
||||
SB02MT.f \
|
||||
SB02MU.f \
|
||||
SB02MV.f \
|
||||
SB02MW.f \
|
||||
SB02ND.f \
|
||||
SB02OD.f \
|
||||
SB02OU.f \
|
||||
SB02OV.f \
|
||||
SB02OW.f \
|
||||
SB02OX.f \
|
||||
SB02OY.f \
|
||||
SB02PD.f \
|
||||
SB02QD.f \
|
||||
SB02RD.f \
|
||||
SB02RU.f \
|
||||
SB02SD.f \
|
||||
SB03MD.f \
|
||||
SB03MU.f \
|
||||
SB03MV.f \
|
||||
SB03MW.f \
|
||||
SB03MX.f \
|
||||
SB03MY.f \
|
||||
SB03OD.f \
|
||||
SB03OR.f \
|
||||
SB03OT.f \
|
||||
SB03OU.f \
|
||||
SB03OV.f \
|
||||
SB03OY.f \
|
||||
SB03PD.f \
|
||||
SB03QD.f \
|
||||
SB03QX.f \
|
||||
SB03QY.f \
|
||||
SB03RD.f \
|
||||
SB03SD.f \
|
||||
SB03SX.f \
|
||||
SB03SY.f \
|
||||
SB03TD.f \
|
||||
SB03UD.f \
|
||||
SB04MD.f \
|
||||
SB04MR.f \
|
||||
SB04MU.f \
|
||||
SB04MW.f \
|
||||
SB04MY.f \
|
||||
SB04ND.f \
|
||||
SB04NV.f \
|
||||
SB04NW.f \
|
||||
SB04NX.f \
|
||||
SB04NY.f \
|
||||
SB04OD.f \
|
||||
SB04OW.f \
|
||||
SB04PD.f \
|
||||
SB04PX.f \
|
||||
SB04PY.f \
|
||||
SB04QD.f \
|
||||
SB04QR.f \
|
||||
SB04QU.f \
|
||||
SB04QY.f \
|
||||
SB04RD.f \
|
||||
SB04RV.f \
|
||||
SB04RW.f \
|
||||
SB04RX.f \
|
||||
SB04RY.f \
|
||||
SB06ND.f \
|
||||
SB08CD.f \
|
||||
SB08DD.f \
|
||||
SB08ED.f \
|
||||
SB08FD.f \
|
||||
SB08GD.f \
|
||||
SB08HD.f \
|
||||
SB08MD.f \
|
||||
SB08MY.f \
|
||||
SB08ND.f \
|
||||
SB08NY.f \
|
||||
SB09MD.f \
|
||||
SB10AD.f \
|
||||
SB10DD.f \
|
||||
SB10ED.f \
|
||||
SB10FD.f \
|
||||
SB10HD.f \
|
||||
SB10ID.f \
|
||||
SB10JD.f \
|
||||
SB10KD.f \
|
||||
SB10LD.f \
|
||||
SB10MD.f \
|
||||
SB10PD.f \
|
||||
SB10QD.f \
|
||||
SB10RD.f \
|
||||
SB10SD.f \
|
||||
SB10TD.f \
|
||||
SB10UD.f \
|
||||
SB10VD.f \
|
||||
SB10WD.f \
|
||||
SB10YD.f \
|
||||
SB10ZD.f \
|
||||
SB10ZP.f \
|
||||
SB16AD.f \
|
||||
SB16AY.f \
|
||||
SB16BD.f \
|
||||
SB16CD.f \
|
||||
SB16CY.f \
|
||||
select.f \
|
||||
SG02AD.f \
|
||||
SG03AD.f \
|
||||
SG03AX.f \
|
||||
SG03AY.f \
|
||||
SG03BD.f \
|
||||
SG03BU.f \
|
||||
SG03BV.f \
|
||||
SG03BW.f \
|
||||
SG03BX.f \
|
||||
SG03BY.f \
|
||||
TB01ID.f \
|
||||
TB01IZ.f \
|
||||
TB01KD.f \
|
||||
TB01LD.f \
|
||||
TB01MD.f \
|
||||
TB01ND.f \
|
||||
TB01PD.f \
|
||||
TB01TD.f \
|
||||
TB01TY.f \
|
||||
TB01UD.f \
|
||||
TB01VD.f \
|
||||
TB01VY.f \
|
||||
TB01WD.f \
|
||||
TB01XD.f \
|
||||
TB01XZ.f \
|
||||
TB01YD.f \
|
||||
TB01ZD.f \
|
||||
TB03AD.f \
|
||||
TB03AY.f \
|
||||
TB04AD.f \
|
||||
TB04AY.f \
|
||||
TB04BD.f \
|
||||
TB04BV.f \
|
||||
TB04BW.f \
|
||||
TB04BX.f \
|
||||
TB04CD.f \
|
||||
TB05AD.f \
|
||||
TC01OD.f \
|
||||
TC04AD.f \
|
||||
TC05AD.f \
|
||||
TD03AD.f \
|
||||
TD03AY.f \
|
||||
TD04AD.f \
|
||||
TD05AD.f \
|
||||
TF01MD.f \
|
||||
TF01MX.f \
|
||||
TF01MY.f \
|
||||
TF01ND.f \
|
||||
TF01OD.f \
|
||||
TF01PD.f \
|
||||
TF01QD.f \
|
||||
TF01RD.f \
|
||||
TG01AD.f \
|
||||
TG01AZ.f \
|
||||
TG01BD.f \
|
||||
TG01CD.f \
|
||||
TG01DD.f \
|
||||
TG01ED.f \
|
||||
TG01FD.f \
|
||||
TG01FZ.f \
|
||||
TG01HD.f \
|
||||
TG01HX.f \
|
||||
TG01ID.f \
|
||||
TG01JD.f \
|
||||
TG01WD.f \
|
||||
UD01BD.f \
|
||||
UD01CD.f \
|
||||
UD01DD.f \
|
||||
UD01MD.f \
|
||||
UD01MZ.f \
|
||||
UD01ND.f \
|
||||
UE01MD.f
|
||||
|
||||
SLICOT_AUX = \
|
||||
dcabs1.f \
|
||||
dhgeqz.f \
|
||||
dtgsy2.f
|
||||
|
||||
nodist_libslicot_a_SOURCES = \
|
||||
$(SLICOT_SRC)
|
||||
|
||||
nodist_libauxslicot_a_SOURCES = \
|
||||
$(SLICOT_AUX)
|
||||
|
|
@ -2,7 +2,7 @@ ACLOCAL_AMFLAGS = -I ../../../m4
|
|||
|
||||
# libdynare++ must come before gensylv, k_order_perturbation, dynare_simul_
|
||||
if DO_SOMETHING
|
||||
SUBDIRS = mjdgges kronecker bytecode libdynare++ gensylv k_order_perturbation dynare_simul_ logposterior logMHMCMCposterior
|
||||
SUBDIRS = mjdgges kronecker bytecode libdynare++ gensylv k_order_perturbation dynare_simul_ logposterior logMHMCMCposterior libslicot
|
||||
if HAVE_GSL
|
||||
SUBDIRS += swz
|
||||
endif
|
||||
|
|
|
|||
|
|
@ -38,6 +38,7 @@ if test "x$ax_enable_matlab" = "xyes"; then
|
|||
|
||||
CFLAGS="$MATLAB_CFLAGS"
|
||||
CXXFLAGS="$MATLAB_CXXFLAGS"
|
||||
FFLAGS="$MATLAB_FFLAGS"
|
||||
fi
|
||||
|
||||
case ${host_os} in
|
||||
|
|
@ -49,8 +50,10 @@ case ${host_os} in
|
|||
esac
|
||||
|
||||
CFLAGS="$CFLAGS -Wall"
|
||||
FFLAGS="$FFLAGS -Wall"
|
||||
CXXFLAGS="$CXXFLAGS -Wall"
|
||||
|
||||
AC_PROG_F77
|
||||
AC_PROG_CC
|
||||
AC_PROG_CXX
|
||||
AC_PROG_RANLIB
|
||||
|
|
@ -130,6 +133,7 @@ AC_CONFIG_FILES([Makefile
|
|||
dynare_simul_/Makefile
|
||||
swz/Makefile
|
||||
logposterior/Makefile
|
||||
logMHMCMCposterior/Makefile])
|
||||
logMHMCMCposterior/Makefile
|
||||
libslicot/Makefile])
|
||||
|
||||
AC_OUTPUT
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
include ../mex.am
|
||||
include ../../libslicot.am
|
||||
|
|
@ -2,7 +2,7 @@ ACLOCAL_AMFLAGS = -I ../../../m4
|
|||
|
||||
# libdynare++ must come before gensylv, k_order_perturbation, dynare_simul_
|
||||
if DO_SOMETHING
|
||||
SUBDIRS = mjdgges kronecker bytecode libdynare++ gensylv k_order_perturbation dynare_simul_ logposterior logMHMCMCposterior qzcomplex ordschur
|
||||
SUBDIRS = mjdgges kronecker bytecode libdynare++ gensylv k_order_perturbation dynare_simul_ logposterior logMHMCMCposterior qzcomplex ordschur libslicot
|
||||
if HAVE_GSL
|
||||
SUBDIRS += swz
|
||||
endif
|
||||
|
|
|
|||
|
|
@ -28,12 +28,15 @@ if test "x$MKOCTFILE" != "x"; then
|
|||
CC=`$MKOCTFILE -p CC`
|
||||
CXX=`$MKOCTFILE -p CXX`
|
||||
CFLAGS=`$MKOCTFILE -p CFLAGS`
|
||||
FFLAGS=`$MKOCTFILE -p FFLAGS`
|
||||
CXXFLAGS=`$MKOCTFILE -p CXXFLAGS`
|
||||
fi
|
||||
|
||||
CFLAGS="$CFLAGS -Wall"
|
||||
FFLAGS="$FFLAGS -Wall"
|
||||
CXXFLAGS="$CXXFLAGS -Wall"
|
||||
|
||||
AC_PROG_F77
|
||||
AC_PROG_CC
|
||||
AC_PROG_CXX
|
||||
AC_PROG_RANLIB
|
||||
|
|
@ -104,6 +107,7 @@ AC_CONFIG_FILES([Makefile
|
|||
logposterior/Makefile
|
||||
logMHMCMCposterior/Makefile
|
||||
qzcomplex/Makefile
|
||||
ordschur/Makefile])
|
||||
ordschur/Makefile
|
||||
libslicot/Makefile])
|
||||
|
||||
AC_OUTPUT
|
||||
|
|
|
|||
|
|
@ -0,0 +1,3 @@
|
|||
EXEEXT = .mex
|
||||
include ../mex.am
|
||||
include ../../libslicot.am
|
||||
|
|
@ -0,0 +1,402 @@
|
|||
SUBROUTINE AB01MD( JOBZ, N, A, LDA, B, NCONT, Z, LDZ, TAU, TOL,
|
||||
$ DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,470 @@
|
|||
SUBROUTINE AB01ND( JOBZ, N, M, A, LDA, B, LDB, NCONT, INDCON,
|
||||
$ NBLK, Z, LDZ, TAU, TOL, IWORK, DWORK, LDWORK,
|
||||
$ INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,535 @@
|
|||
SUBROUTINE AB01OD( STAGES, JOBU, JOBV, N, M, A, LDA, B, LDB, U,
|
||||
$ LDU, V, LDV, NCONT, INDCON, KSTAIR, TOL, IWORK,
|
||||
$ DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,345 @@
|
|||
SUBROUTINE AB04MD( TYPE, N, M, P, ALPHA, BETA, A, LDA, B, LDB, C,
|
||||
$ LDC, D, LDD, IWORK, DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,547 @@
|
|||
SUBROUTINE AB05MD( UPLO, OVER, N1, M1, P1, N2, P2, A1, LDA1, B1,
|
||||
$ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2,
|
||||
$ C2, LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC,
|
||||
$ D, LDD, DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,564 @@
|
|||
SUBROUTINE AB05ND( OVER, N1, M1, P1, N2, ALPHA, A1, LDA1, B1,
|
||||
$ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2,
|
||||
$ C2, LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC,
|
||||
$ D, LDD, IWORK, DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,418 @@
|
|||
SUBROUTINE AB05OD( OVER, N1, M1, P1, N2, M2, ALPHA, A1, LDA1, B1,
|
||||
$ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2,
|
||||
$ C2, LDC2, D2, LDD2, N, M, A, LDA, B, LDB, C,
|
||||
$ LDC, D, LDD, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,385 @@
|
|||
SUBROUTINE AB05PD( OVER, N1, M, P, N2, ALPHA, A1, LDA1, B1, LDB1,
|
||||
$ C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, C2,
|
||||
$ LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC, D,
|
||||
$ LDD, INFO)
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,419 @@
|
|||
SUBROUTINE AB05QD( OVER, N1, M1, P1, N2, M2, P2, A1, LDA1, B1,
|
||||
$ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2,
|
||||
$ C2, LDC2, D2, LDD2, N, M, P, A, LDA, B, LDB,
|
||||
$ C, LDC, D, LDD, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,393 @@
|
|||
SUBROUTINE AB05RD( FBTYPE, JOBD, N, M, P, MV, PZ, ALPHA, BETA, A,
|
||||
$ LDA, B, LDB, C, LDC, D, LDD, F, LDF, K, LDK,
|
||||
$ G, LDG, H, LDH, RCOND, BC, LDBC, CC, LDCC,
|
||||
$ DC, LDDC, IWORK, DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,371 @@
|
|||
SUBROUTINE AB05SD( FBTYPE, JOBD, N, M, P, ALPHA, A, LDA, B, LDB,
|
||||
$ C, LDC, D, LDD, F, LDF, RCOND, IWORK, DWORK,
|
||||
$ LDWORK, INFO)
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,224 @@
|
|||
SUBROUTINE AB07MD( JOBD, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
$ INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,303 @@
|
|||
SUBROUTINE AB07ND( N, M, A, LDA, B, LDB, C, LDC, D, LDD, RCOND,
|
||||
$ IWORK, DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,299 @@
|
|||
SUBROUTINE AB08MD( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
$ RANK, TOL, IWORK, DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,303 @@
|
|||
SUBROUTINE AB08MZ( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
$ RANK, TOL, IWORK, DWORK, ZWORK, LZWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,568 @@
|
|||
SUBROUTINE AB08ND( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
$ NU, RANK, DINFZ, NKROR, NKROL, INFZ, KRONR,
|
||||
$ KRONL, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK,
|
||||
$ LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,446 @@
|
|||
SUBROUTINE AB08NX( N, M, P, RO, SIGMA, SVLMAX, ABCD, LDABCD,
|
||||
$ NINFZ, INFZ, KRONL, MU, NU, NKROL, TOL, IWORK,
|
||||
$ DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,576 @@
|
|||
SUBROUTINE AB08NZ( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
$ NU, RANK, DINFZ, NKROR, NKROL, INFZ, KRONR,
|
||||
$ KRONL, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK,
|
||||
$ ZWORK, LZWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,363 @@
|
|||
SUBROUTINE AB09AD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, A, LDA,
|
||||
$ B, LDB, C, LDC, HSV, TOL, IWORK, DWORK, LDWORK,
|
||||
$ IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,564 @@
|
|||
SUBROUTINE AB09AX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB,
|
||||
$ C, LDC, HSV, T, LDT, TI, LDTI, TOL, IWORK,
|
||||
$ DWORK, LDWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,385 @@
|
|||
SUBROUTINE AB09BD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, A, LDA,
|
||||
$ B, LDB, C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK,
|
||||
$ DWORK, LDWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,662 @@
|
|||
SUBROUTINE AB09BX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB,
|
||||
$ C, LDC, D, LDD, HSV, T, LDT, TI, LDTI, TOL1,
|
||||
$ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,375 @@
|
|||
SUBROUTINE AB09CD( DICO, EQUIL, ORDSEL, N, M, P, NR, A, LDA, B,
|
||||
$ LDB, C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK,
|
||||
$ DWORK, LDWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,558 @@
|
|||
SUBROUTINE AB09CX( DICO, ORDSEL, N, M, P, NR, A, LDA, B, LDB,
|
||||
$ C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK,
|
||||
$ DWORK, LDWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,278 @@
|
|||
SUBROUTINE AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC,
|
||||
$ D, LDD, RCOND, IWORK, DWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,493 @@
|
|||
SUBROUTINE AB09ED( DICO, EQUIL, ORDSEL, N, M, P, NR, ALPHA,
|
||||
$ A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV, TOL1,
|
||||
$ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,649 @@
|
|||
SUBROUTINE AB09FD( DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL, N, M,
|
||||
$ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, NQ, HSV,
|
||||
$ TOL1, TOL2, IWORK, DWORK, LDWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,681 @@
|
|||
SUBROUTINE AB09GD( DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL, N, M,
|
||||
$ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
$ NQ, HSV, TOL1, TOL2, TOL3, IWORK, DWORK,
|
||||
$ LDWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,671 @@
|
|||
SUBROUTINE AB09HD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA,
|
||||
$ BETA, A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV,
|
||||
$ TOL1, TOL2, IWORK, DWORK, LDWORK, BWORK, IWARN,
|
||||
$ INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,690 @@
|
|||
SUBROUTINE AB09HX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB,
|
||||
$ C, LDC, D, LDD, HSV, T, LDT, TI, LDTI, TOL1,
|
||||
$ TOL2, IWORK, DWORK, LDWORK, BWORK, IWARN,
|
||||
$ INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,396 @@
|
|||
SUBROUTINE AB09HY( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
$ SCALEC, SCALEO, S, LDS, R, LDR, IWORK,
|
||||
$ DWORK, LDWORK, BWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,695 @@
|
|||
SUBROUTINE AB09IX( DICO, JOB, FACT, ORDSEL, N, M, P, NR,
|
||||
$ SCALEC, SCALEO, A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
$ TI, LDTI, T, LDT, NMINR, HSV, TOL1, TOL2,
|
||||
$ IWORK, DWORK, LDWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,859 @@
|
|||
SUBROUTINE AB09IY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NV, PV,
|
||||
$ NW, MW, ALPHAC, ALPHAO, A, LDA, B, LDB, C, LDC,
|
||||
$ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV,
|
||||
$ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW,
|
||||
$ SCALEC, SCALEO, S, LDS, R, LDR,
|
||||
$ DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,958 @@
|
|||
SUBROUTINE AB09JV( JOB, DICO, JOBEV, STBCHK, N, M, P, NV, PV,
|
||||
$ A, LDA, B, LDB, C, LDC, D, LDD, AV, LDAV,
|
||||
$ EV, LDEV, BV, LDBV, CV, LDCV, DV, LDDV, IWORK,
|
||||
$ DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,972 @@
|
|||
SUBROUTINE AB09JW( JOB, DICO, JOBEW, STBCHK, N, M, P, NW, MW,
|
||||
$ A, LDA, B, LDB, C, LDC, D, LDD, AW, LDAW,
|
||||
$ EW, LDEW, BW, LDBW, CW, LDCW, DW, LDDW, IWORK,
|
||||
$ DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,253 @@
|
|||
SUBROUTINE AB09JX( DICO, STDOM, EVTYPE, N, ALPHA, ER, EI, ED,
|
||||
$ TOLINF, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,864 @@
|
|||
SUBROUTINE AB09KD( JOB, DICO, WEIGHT, EQUIL, ORDSEL, N, NV, NW, M,
|
||||
$ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
$ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV,
|
||||
$ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW,
|
||||
$ NS, HSV, TOL1, TOL2, IWORK, DWORK, LDWORK,
|
||||
$ IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,869 @@
|
|||
SUBROUTINE AB09KX( JOB, DICO, WEIGHT, N, NV, NW, M, P,
|
||||
$ A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
$ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV,
|
||||
$ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW,
|
||||
$ DWORK, LDWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,474 @@
|
|||
SUBROUTINE AB09MD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA,
|
||||
$ A, LDA, B, LDB, C, LDC, NS, HSV, TOL, IWORK,
|
||||
$ DWORK, LDWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,497 @@
|
|||
SUBROUTINE AB09ND( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA,
|
||||
$ A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV, TOL1,
|
||||
$ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,349 @@
|
|||
DOUBLE PRECISION FUNCTION AB13AD( DICO, EQUIL, N, M, P, ALPHA, A,
|
||||
$ LDA, B, LDB, C, LDC, NS, HSV,
|
||||
$ DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,308 @@
|
|||
DOUBLE PRECISION FUNCTION AB13AX( DICO, N, M, P, A, LDA, B, LDB,
|
||||
$ C, LDC, HSV, DWORK, LDWORK,
|
||||
$ INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,390 @@
|
|||
DOUBLE PRECISION FUNCTION AB13BD( DICO, JOBN, N, M, P, A, LDA,
|
||||
$ B, LDB, C, LDC, D, LDD, NQ, TOL,
|
||||
$ DWORK, LDWORK, IWARN, INFO)
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,601 @@
|
|||
DOUBLE PRECISION FUNCTION AB13CD( N, M, NP, A, LDA, B, LDB, C,
|
||||
$ LDC, D, LDD, TOL, IWORK, DWORK,
|
||||
$ LDWORK, CWORK, LCWORK, BWORK,
|
||||
$ INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,544 @@
|
|||
DOUBLE PRECISION FUNCTION AB13DX( DICO, JOBE, JOBD, N, M, P,
|
||||
$ OMEGA, A, LDA, E, LDE, B, LDB,
|
||||
$ C, LDC, D, LDD, IWORK, DWORK,
|
||||
$ LDWORK, CWORK, LCWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,347 @@
|
|||
SUBROUTINE AB13ED( N, A, LDA, LOW, HIGH, TOL, DWORK, LDWORK,
|
||||
$ INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
C
|
||||
C PURPOSE
|
||||
C
|
||||
C To estimate beta(A), the 2-norm distance from a real matrix A to
|
||||
C the nearest complex matrix with an eigenvalue on the imaginary
|
||||
C axis. The estimate is given as
|
||||
C
|
||||
C LOW <= beta(A) <= HIGH,
|
||||
C
|
||||
C where either
|
||||
C
|
||||
C (1 + TOL) * LOW >= HIGH,
|
||||
C
|
||||
C or
|
||||
C
|
||||
C LOW = 0 and HIGH = delta,
|
||||
C
|
||||
C and delta is a small number approximately equal to the square root
|
||||
C of machine precision times the Frobenius norm (Euclidean norm)
|
||||
C of A. If A is stable in the sense that all eigenvalues of A lie
|
||||
C in the open left half complex plane, then beta(A) is the distance
|
||||
C to the nearest unstable complex matrix, i.e., the complex
|
||||
C stability radius.
|
||||
C
|
||||
C ARGUMENTS
|
||||
C
|
||||
C Input/Output Parameters
|
||||
C
|
||||
C N (input) INTEGER
|
||||
C The order of the matrix A. N >= 0.
|
||||
C
|
||||
C A (input) DOUBLE PRECISION array, dimension (LDA,N)
|
||||
C The leading N-by-N part of this array must contain the
|
||||
C matrix A.
|
||||
C
|
||||
C LDA INTEGER
|
||||
C The leading dimension of array A. LDA >= MAX(1,N).
|
||||
C
|
||||
C LOW (output) DOUBLE PRECISION
|
||||
C A lower bound for beta(A).
|
||||
C
|
||||
C HIGH (output) DOUBLE PRECISION
|
||||
C An upper bound for beta(A).
|
||||
C
|
||||
C Tolerances
|
||||
C
|
||||
C TOL DOUBLE PRECISION
|
||||
C Specifies the accuracy with which LOW and HIGH approximate
|
||||
C beta(A). If the user sets TOL to be less than SQRT(EPS),
|
||||
C where EPS is the machine precision (see LAPACK Library
|
||||
C Routine DLAMCH), then the tolerance is taken to be
|
||||
C SQRT(EPS).
|
||||
C The recommended value is TOL = 9, which gives an estimate
|
||||
C of beta(A) correct to within an order of magnitude.
|
||||
C
|
||||
C Workspace
|
||||
C
|
||||
C DWORK DOUBLE PRECISION array, dimension (LDWORK)
|
||||
C On exit, if INFO = 0, DWORK(1) returns the optimal value
|
||||
C of LDWORK.
|
||||
C
|
||||
C LDWORK INTEGER
|
||||
C The length of the array DWORK.
|
||||
C LDWORK >= MAX( 1, 3*N*(N+1) ).
|
||||
C For optimum performance LDWORK should be larger.
|
||||
C
|
||||
C Error Indicator
|
||||
C
|
||||
C INFO INTEGER
|
||||
C = 0: successful exit;
|
||||
C < 0: if INFO = -i, the i-th argument had an illegal
|
||||
C value;
|
||||
C = 1: the QR algorithm (LAPACK Library routine DHSEQR)
|
||||
C fails to converge; this error is very rare.
|
||||
C
|
||||
C METHOD
|
||||
C
|
||||
C Let beta(A) be the 2-norm distance from a real matrix A to the
|
||||
C nearest complex matrix with an eigenvalue on the imaginary axis.
|
||||
C It is known that beta(A) = minimum of the smallest singular
|
||||
C value of (A - jwI), where I is the identity matrix and j**2 = -1,
|
||||
C and the minimum is taken over all real w.
|
||||
C The algorithm computes a lower bound LOW and an upper bound HIGH
|
||||
C for beta(A) by a bisection method in the following way. Given a
|
||||
C non-negative real number sigma, the Hamiltonian matrix H(sigma)
|
||||
C is constructed:
|
||||
C
|
||||
C | A -sigma*I | | A G |
|
||||
C H(sigma) = | | := | | .
|
||||
C | sigma*I -A' | | F -A' |
|
||||
C
|
||||
C It can be shown [1] that H(sigma) has an eigenvalue whose real
|
||||
C part is zero if and only if sigma >= beta. Any lower and upper
|
||||
C bounds on beta(A) can be improved by choosing a number between
|
||||
C them and checking to see if H(sigma) has an eigenvalue with zero
|
||||
C real part. This decision is made by computing the eigenvalues of
|
||||
C H(sigma) using the square reduced algorithm of Van Loan [2].
|
||||
C
|
||||
C REFERENCES
|
||||
C
|
||||
C [1] Byers, R.
|
||||
C A bisection method for measuring the distance of a stable
|
||||
C matrix to the unstable matrices.
|
||||
C SIAM J. Sci. Stat. Comput., Vol. 9, No. 5, pp. 875-880, 1988.
|
||||
C
|
||||
C [2] Van Loan, C.F.
|
||||
C A symplectic method for approximating all the eigenvalues of a
|
||||
C Hamiltonian matrix.
|
||||
C Linear Algebra and its Applications, Vol 61, 233-251, 1984.
|
||||
C
|
||||
C NUMERICAL ASPECTS
|
||||
C
|
||||
C Due to rounding errors the computed values of LOW and HIGH can be
|
||||
C proven to satisfy
|
||||
C
|
||||
C LOW - p(n) * sqrt(e) * norm(A) <= beta(A)
|
||||
C and
|
||||
C beta(A) <= HIGH + p(n) * sqrt(e) * norm(A),
|
||||
C
|
||||
C where p(n) is a modest polynomial of degree 3, e is the machine
|
||||
C precision and norm(A) is the Frobenius norm of A, see [1].
|
||||
C The recommended value for TOL is 9 which gives an estimate of
|
||||
C beta(A) correct to within an order of magnitude.
|
||||
C AB13ED requires approximately 38*N**3 flops for TOL = 9.
|
||||
C
|
||||
C CONTRIBUTOR
|
||||
C
|
||||
C R. Byers, the routines BISEC and BISEC0 (January, 1995).
|
||||
C
|
||||
C REVISIONS
|
||||
C
|
||||
C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999.
|
||||
C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2003.
|
||||
C
|
||||
C KEYWORDS
|
||||
C
|
||||
C Distances, eigenvalue, eigenvalue perturbation, norms, stability
|
||||
C radius.
|
||||
C
|
||||
C ******************************************************************
|
||||
C
|
||||
C .. Parameters ..
|
||||
DOUBLE PRECISION ZERO, ONE
|
||||
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
|
||||
C .. Scalar Arguments ..
|
||||
DOUBLE PRECISION HIGH, LOW, TOL
|
||||
INTEGER INFO, LDA, LDWORK, N
|
||||
C .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*), DWORK(*)
|
||||
C .. Local Scalars ..
|
||||
INTEGER I, IA2, IAA, IGF, IHI, ILO, IWI, IWK, IWR,
|
||||
$ JWORK, MINWRK, N2
|
||||
DOUBLE PRECISION ANRM, SEPS, SFMN, SIGMA, TAU, TEMP, TOL1, TOL2
|
||||
LOGICAL RNEG, SUFWRK
|
||||
C .. Local Arrays ..
|
||||
DOUBLE PRECISION DUMMY(1), DUMMY2(1,1)
|
||||
C .. External Functions ..
|
||||
DOUBLE PRECISION DLAMCH, DLANGE
|
||||
EXTERNAL DLAMCH, DLANGE
|
||||
C .. External Subroutines ..
|
||||
EXTERNAL DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DSYMM,
|
||||
$ DSYMV, MA02ED, MB04ZD, XERBLA
|
||||
C .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, DBLE, MAX, SQRT
|
||||
C .. Executable Statements ..
|
||||
C
|
||||
C Test the input scalar arguments.
|
||||
C
|
||||
INFO = 0
|
||||
MINWRK = 3*N*( N + 1 )
|
||||
C
|
||||
IF( N.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN
|
||||
INFO = -8
|
||||
END IF
|
||||
C
|
||||
IF ( INFO.NE.0 ) THEN
|
||||
C
|
||||
C Error return.
|
||||
C
|
||||
CALL XERBLA( 'AB13ED', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
C
|
||||
C Quick return if possible.
|
||||
C
|
||||
LOW = ZERO
|
||||
IF ( N.EQ.0 ) THEN
|
||||
HIGH = ZERO
|
||||
DWORK(1) = ONE
|
||||
RETURN
|
||||
END IF
|
||||
C
|
||||
C Indices for splitting the work array.
|
||||
C (Note: Comments in the code beginning "Workspace:" describe the
|
||||
C minimal amount of real workspace needed at that point in the
|
||||
C code, as well as the preferred amount for good performance.)
|
||||
C
|
||||
N2 = N*N
|
||||
IGF = 1
|
||||
IA2 = IGF + N2 + N
|
||||
IAA = IA2 + N2
|
||||
IWK = IAA + N2
|
||||
IWR = IAA
|
||||
IWI = IWR + N
|
||||
C
|
||||
SUFWRK = LDWORK-IWK.GE.N2
|
||||
C
|
||||
C Computation of the tolerances and the treshold for termination of
|
||||
C the bisection method. SEPS is the square root of the machine
|
||||
C precision.
|
||||
C
|
||||
SFMN = DLAMCH( 'Safe minimum' )
|
||||
SEPS = SQRT( DLAMCH( 'Epsilon' ) )
|
||||
TAU = ONE + MAX( TOL, SEPS )
|
||||
ANRM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK )
|
||||
TOL1 = SEPS * ANRM
|
||||
TOL2 = TOL1 * DBLE( 2*N )
|
||||
C
|
||||
C Initialization of the bisection method.
|
||||
C
|
||||
HIGH = ANRM
|
||||
C
|
||||
C WHILE ( HIGH > TAU*MAX( TOL1, LOW ) ) DO
|
||||
10 IF ( HIGH.GT.( TAU*MAX( TOL1, LOW ) ) ) THEN
|
||||
SIGMA = SQRT( HIGH ) * SQRT( MAX( TOL1, LOW ) )
|
||||
C
|
||||
C Set up H(sigma).
|
||||
C Workspace: N*(N+1)+2*N*N.
|
||||
C
|
||||
CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IAA), N )
|
||||
DWORK(IGF) = SIGMA
|
||||
DWORK(IGF+N) = -SIGMA
|
||||
DUMMY(1) = ZERO
|
||||
CALL DCOPY( N-1, DUMMY, 0, DWORK(IGF+1), 1 )
|
||||
C
|
||||
DO 20 I = IGF, IA2 - N - 2, N + 1
|
||||
CALL DCOPY( N+1, DWORK(I), 1, DWORK(I+N+1), 1 )
|
||||
20 CONTINUE
|
||||
C
|
||||
C Computation of the eigenvalues by the square reduced algorithm.
|
||||
C Workspace: N*(N+1)+2*N*N+2*N.
|
||||
C
|
||||
CALL MB04ZD( 'No vectors', N, DWORK(IAA), N, DWORK(IGF), N,
|
||||
$ DUMMY2, 1, DWORK(IWK), INFO )
|
||||
C
|
||||
C Form the matrix A*A + F*G.
|
||||
C Workspace: need N*(N+1)+2*N*N+N;
|
||||
C prefer N*(N+1)+3*N*N.
|
||||
C
|
||||
JWORK = IA2
|
||||
IF ( SUFWRK )
|
||||
$ JWORK = IWK
|
||||
C
|
||||
CALL DLACPY( 'Lower', N, N, DWORK(IGF), N, DWORK(JWORK), N )
|
||||
CALL MA02ED( 'Lower', N, DWORK(JWORK), N )
|
||||
C
|
||||
IF ( SUFWRK ) THEN
|
||||
C
|
||||
C Use BLAS 3 calculation.
|
||||
C
|
||||
CALL DSYMM( 'Left', 'Upper', N, N, ONE, DWORK(IGF+N), N,
|
||||
$ DWORK(JWORK), N, ZERO, DWORK(IA2), N )
|
||||
ELSE
|
||||
C
|
||||
C Use BLAS 2 calculation.
|
||||
C
|
||||
DO 30 I = 1, N
|
||||
CALL DSYMV( 'Upper', N, ONE, DWORK(IGF+N), N,
|
||||
$ DWORK(IA2+N*(I-1)), 1, ZERO, DWORK(IWK), 1 )
|
||||
CALL DCOPY( N, DWORK(IWK), 1, DWORK(IA2+N*(I-1)), 1 )
|
||||
30 CONTINUE
|
||||
C
|
||||
END IF
|
||||
C
|
||||
CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE,
|
||||
$ DWORK(IAA), N, DWORK(IAA), N, ONE, DWORK(IA2), N )
|
||||
C
|
||||
C Find the eigenvalues of A*A + F*G.
|
||||
C Workspace: N*(N+1)+N*N+3*N.
|
||||
C
|
||||
JWORK = IWI + N
|
||||
CALL DGEBAL( 'Scale', N, DWORK(IA2), N, ILO, IHI, DWORK(JWORK),
|
||||
$ I )
|
||||
CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI,
|
||||
$ DWORK(IA2), N, DWORK(IWR), DWORK(IWI), DUMMY2, 1,
|
||||
$ DWORK(JWORK), N, INFO )
|
||||
C
|
||||
IF ( INFO.NE.0 ) THEN
|
||||
INFO = 1
|
||||
RETURN
|
||||
END IF
|
||||
C
|
||||
C (DWORK(IWR+i), DWORK(IWI+i)), i = 0,...,N-1, contain the
|
||||
C squares of the eigenvalues of H(sigma).
|
||||
C
|
||||
I = 0
|
||||
RNEG = .FALSE.
|
||||
C WHILE ( ( DWORK(IWR+i),DWORK(IWI+i) ) not real positive
|
||||
C .AND. I < N ) DO
|
||||
40 IF ( .NOT.RNEG .AND. I.LT.N ) THEN
|
||||
TEMP = ABS( DWORK(IWI+I) )
|
||||
IF ( TOL1.GT.SFMN ) TEMP = TEMP / TOL1
|
||||
RNEG = ( ( DWORK(IWR+I).LT.ZERO ) .AND. ( TEMP.LE.TOL2 ) )
|
||||
I = I + 1
|
||||
GO TO 40
|
||||
C END WHILE 40
|
||||
END IF
|
||||
|
||||
IF ( RNEG ) THEN
|
||||
HIGH = SIGMA
|
||||
ELSE
|
||||
LOW = SIGMA
|
||||
END IF
|
||||
GO TO 10
|
||||
C END WHILE 10
|
||||
END IF
|
||||
C
|
||||
C Set optimal workspace dimension.
|
||||
C
|
||||
DWORK(1) = DBLE( MAX( 4*N2 + N, MINWRK ) )
|
||||
C
|
||||
C *** Last line of AB13ED ***
|
||||
END
|
||||
|
|
@ -0,0 +1,403 @@
|
|||
SUBROUTINE AB13FD( N, A, LDA, BETA, OMEGA, TOL, DWORK, LDWORK,
|
||||
$ CWORK, LCWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,456 @@
|
|||
SUBROUTINE AB8NXZ( N, M, P, RO, SIGMA, SVLMAX, ABCD, LDABCD,
|
||||
$ NINFZ, INFZ, KRONL, MU, NU, NKROL, TOL, IWORK,
|
||||
$ DWORK, ZWORK, LZWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,273 @@
|
|||
SUBROUTINE AG07BD( JOBE, N, M, A, LDA, E, LDE, B, LDB, C, LDC,
|
||||
$ D, LDD, AI, LDAI, EI, LDEI, BI, LDBI, CI, LDCI,
|
||||
$ DI, LDDI, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,628 @@
|
|||
SUBROUTINE AG08BD( EQUIL, L, N, M, P, A, LDA, E, LDE, B, LDB,
|
||||
$ C, LDC, D, LDD, NFZ, NRANK, NIZ, DINFZ, NKROR,
|
||||
$ NINFE, NKROL, INFZ, KRONR, INFE, KRONL,
|
||||
$ TOL, IWORK, DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,680 @@
|
|||
SUBROUTINE AG08BY( FIRST, N, M, P, SVLMAX, ABCD, LDABCD, E, LDE,
|
||||
$ NR, PR, NINFZ, DINFZ, NKRONL, INFZ, KRONL,
|
||||
$ TOL, IWORK, DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,641 @@
|
|||
SUBROUTINE AG08BZ( EQUIL, L, N, M, P, A, LDA, E, LDE, B, LDB,
|
||||
$ C, LDC, D, LDD, NFZ, NRANK, NIZ, DINFZ, NKROR,
|
||||
$ NINFE, NKROL, INFZ, KRONR, INFE, KRONL,
|
||||
$ TOL, IWORK, DWORK, ZWORK, LZWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,692 @@
|
|||
SUBROUTINE AG8BYZ( FIRST, N, M, P, SVLMAX, ABCD, LDABCD, E, LDE,
|
||||
$ NR, PR, NINFZ, DINFZ, NKRONL, INFZ, KRONL,
|
||||
$ TOL, IWORK, DWORK, ZWORK, LZWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,490 @@
|
|||
SUBROUTINE BB03AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA,
|
||||
1 Y, LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK,
|
||||
2 LDWORK, INFO)
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,476 @@
|
|||
SUBROUTINE BB04AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA,
|
||||
1 Y, LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK,
|
||||
2 LDWORK, INFO)
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,601 @@
|
|||
SUBROUTINE BD02AD( DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A,
|
||||
1 LDA, B, LDB, C, LDC, D, LDD, NOTE, DWORK,
|
||||
2 LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,203 @@
|
|||
SUBROUTINE DE01OD( CONV, N, A, B, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,236 @@
|
|||
SUBROUTINE DE01PD( CONV, WGHT, N, A, B, W, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,299 @@
|
|||
SUBROUTINE DF01MD( SICO, N, DT, A, DWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,235 @@
|
|||
SUBROUTINE DG01MD( INDI, N, XR, XI, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,247 @@
|
|||
SUBROUTINE DG01ND( INDI, N, XR, XI, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,94 @@
|
|||
SUBROUTINE DG01NY( INDI, N, XR, XI )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,357 @@
|
|||
SUBROUTINE DG01OD( SCR, WGHT, N, A, W, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,183 @@
|
|||
SUBROUTINE DK01MD( TYPE, N, A, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,464 @@
|
|||
SUBROUTINE FB01QD( JOBK, MULTBQ, N, M, P, S, LDS, A, LDA, B,
|
||||
$ LDB, Q, LDQ, C, LDC, R, LDR, K, LDK, TOL,
|
||||
$ IWORK, DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,535 @@
|
|||
SUBROUTINE FB01RD( JOBK, MULTBQ, N, M, P, S, LDS, A, LDA, B,
|
||||
$ LDB, Q, LDQ, C, LDC, R, LDR, K, LDK, TOL,
|
||||
$ IWORK, DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,597 @@
|
|||
SUBROUTINE FB01SD( JOBX, MULTAB, MULTRC, N, M, P, SINV, LDSINV,
|
||||
$ AINV, LDAINV, B, LDB, RINV, LDRINV, C, LDC,
|
||||
$ QINV, LDQINV, X, RINVY, Z, E, TOL, IWORK,
|
||||
$ DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,641 @@
|
|||
SUBROUTINE FB01TD( JOBX, MULTRC, N, M, P, SINV, LDSINV, AINV,
|
||||
$ LDAINV, AINVB, LDAINB, RINV, LDRINV, C, LDC,
|
||||
$ QINV, LDQINV, X, RINVY, Z, E, TOL, IWORK,
|
||||
$ DWORK, LDWORK, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,391 @@
|
|||
SUBROUTINE FB01VD( N, M, L, P, LDP, A, LDA, B, LDB, C, LDC, Q,
|
||||
$ LDQ, R, LDR, K, LDK, TOL, IWORK, DWORK, LDWORK,
|
||||
$ INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,367 @@
|
|||
SUBROUTINE FD01AD( JP, L, LAMBDA, XIN, YIN, EFOR, XF, EPSBCK,
|
||||
$ CTETA, STETA, YQ, EPOS, EOUT, SALPH, IWARN,
|
||||
$ INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,686 @@
|
|||
SUBROUTINE IB01AD( METH, ALG, JOBD, BATCH, CONCT, CTRL, NOBR, M,
|
||||
$ L, NSMP, U, LDU, Y, LDY, N, R, LDR, SV, RCOND,
|
||||
$ TOL, IWORK, DWORK, LDWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,791 @@
|
|||
SUBROUTINE IB01BD( METH, JOB, JOBCK, NOBR, N, M, L, NSMPL, R,
|
||||
$ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ,
|
||||
$ RY, LDRY, S, LDS, K, LDK, TOL, IWORK, DWORK,
|
||||
$ LDWORK, BWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,823 @@
|
|||
SUBROUTINE IB01CD( JOBX0, COMUSE, JOB, N, M, L, NSMP, A, LDA, B,
|
||||
$ LDB, C, LDC, D, LDD, U, LDU, Y, LDY, X0, V,
|
||||
$ LDV, TOL, IWORK, DWORK, LDWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,731 @@
|
|||
SUBROUTINE IB01ND( METH, JOBD, NOBR, M, L, R, LDR, SV, TOL, IWORK,
|
||||
$ DWORK, LDWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,214 @@
|
|||
SUBROUTINE IB01OD( CTRL, NOBR, L, SV, N, TOL, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,175 @@
|
|||
SUBROUTINE IB01OY( NS, NMAX, N, SV, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,474 @@
|
|||
SUBROUTINE IB01PX( JOB, NOBR, N, M, L, UF, LDUF, UN, LDUN, UL,
|
||||
$ LDUL, PGAL, LDPGAL, K, LDK, R, LDR, X, B, LDB,
|
||||
$ D, LDD, TOL, IWORK, DWORK, LDWORK, IWARN,
|
||||
$ INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
|
|
@ -0,0 +1,768 @@
|
|||
SUBROUTINE IB01PY( METH, JOB, NOBR, N, M, L, RANKR1, UL, LDUL,
|
||||
$ R1, LDR1, TAU1, PGAL, LDPGAL, K, LDK, R, LDR,
|
||||
$ H, LDH, B, LDB, D, LDD, TOL, IWORK, DWORK,
|
||||
$ LDWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,762 @@
|
|||
SUBROUTINE IB01RD( JOB, N, M, L, NSMP, A, LDA, B, LDB, C, LDC, D,
|
||||
$ LDD, U, LDU, Y, LDY, X0, TOL, IWORK, DWORK,
|
||||
$ LDWORK, IWARN, INFO )
|
||||
C
|
||||
C SLICOT RELEASE 5.0.
|
||||
C
|
||||
C Copyright (c) 2002-2009 NICONET e.V.
|
||||
C
|
||||
C This program is free software: you can redistribute it and/or
|
||||
C modify it under the terms of the GNU General Public License as
|
||||
C published by the Free Software Foundation, either version 2 of
|
||||
C the License, or (at your option) any later version.
|
||||
C
|
||||
C This program is distributed in the hope that it will be useful,
|
||||
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
C GNU General Public License for more details.
|
||||
C
|
||||
C You should have received a copy of the GNU General Public License
|
||||
C along with this program. If not, see
|
||||
C <http://www.gnu.org/licenses/>.
|
||||
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
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue