From 382ab96cde0003aee842be5fce736d98562bee8d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?St=C3=A9phane=20Adjemian=20=28Charybdis=29?= Date: Thu, 18 Nov 2010 10:11:27 +0100 Subject: [PATCH] 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. --- m4/ax_mexopts.m4 | 3 + mex/build/libslicot.am | 484 +++++ mex/build/matlab/Makefile.am | 2 +- mex/build/matlab/configure.ac | 6 +- mex/build/matlab/libslicot/Makefile.am | 2 + mex/build/octave/Makefile.am | 2 +- mex/build/octave/configure.ac | 6 +- mex/build/octave/libslicot/Makefile.am | 3 + mex/sources/libslicot/AB01MD.f | 402 ++++ mex/sources/libslicot/AB01ND.f | 470 +++++ mex/sources/libslicot/AB01OD.f | 535 ++++++ mex/sources/libslicot/AB04MD.f | 345 ++++ mex/sources/libslicot/AB05MD.f | 547 ++++++ mex/sources/libslicot/AB05ND.f | 564 ++++++ mex/sources/libslicot/AB05OD.f | 418 +++++ mex/sources/libslicot/AB05PD.f | 385 ++++ mex/sources/libslicot/AB05QD.f | 419 +++++ mex/sources/libslicot/AB05RD.f | 393 ++++ mex/sources/libslicot/AB05SD.f | 371 ++++ mex/sources/libslicot/AB07MD.f | 224 +++ mex/sources/libslicot/AB07ND.f | 303 +++ mex/sources/libslicot/AB08MD.f | 299 +++ mex/sources/libslicot/AB08MZ.f | 303 +++ mex/sources/libslicot/AB08ND.f | 568 ++++++ mex/sources/libslicot/AB08NX.f | 446 +++++ mex/sources/libslicot/AB08NZ.f | 576 ++++++ mex/sources/libslicot/AB09AD.f | 363 ++++ mex/sources/libslicot/AB09AX.f | 564 ++++++ mex/sources/libslicot/AB09BD.f | 385 ++++ mex/sources/libslicot/AB09BX.f | 662 +++++++ mex/sources/libslicot/AB09CD.f | 375 ++++ mex/sources/libslicot/AB09CX.f | 558 ++++++ mex/sources/libslicot/AB09DD.f | 278 +++ mex/sources/libslicot/AB09ED.f | 493 +++++ mex/sources/libslicot/AB09FD.f | 649 +++++++ mex/sources/libslicot/AB09GD.f | 681 +++++++ mex/sources/libslicot/AB09HD.f | 671 +++++++ mex/sources/libslicot/AB09HX.f | 690 +++++++ mex/sources/libslicot/AB09HY.f | 396 ++++ mex/sources/libslicot/AB09ID.f | 1048 +++++++++++ mex/sources/libslicot/AB09IX.f | 695 +++++++ mex/sources/libslicot/AB09IY.f | 859 +++++++++ mex/sources/libslicot/AB09JD.f | 1482 +++++++++++++++ mex/sources/libslicot/AB09JV.f | 958 ++++++++++ mex/sources/libslicot/AB09JW.f | 972 ++++++++++ mex/sources/libslicot/AB09JX.f | 253 +++ mex/sources/libslicot/AB09KD.f | 864 +++++++++ mex/sources/libslicot/AB09KX.f | 869 +++++++++ mex/sources/libslicot/AB09MD.f | 474 +++++ mex/sources/libslicot/AB09ND.f | 497 +++++ mex/sources/libslicot/AB13AD.f | 349 ++++ mex/sources/libslicot/AB13AX.f | 308 ++++ mex/sources/libslicot/AB13BD.f | 390 ++++ mex/sources/libslicot/AB13CD.f | 601 ++++++ mex/sources/libslicot/AB13DD.f | 1870 +++++++++++++++++++ mex/sources/libslicot/AB13DX.f | 544 ++++++ mex/sources/libslicot/AB13ED.f | 347 ++++ mex/sources/libslicot/AB13FD.f | 403 ++++ mex/sources/libslicot/AB13MD.f | 1782 ++++++++++++++++++ mex/sources/libslicot/AB8NXZ.f | 456 +++++ mex/sources/libslicot/AG07BD.f | 273 +++ mex/sources/libslicot/AG08BD.f | 628 +++++++ mex/sources/libslicot/AG08BY.f | 680 +++++++ mex/sources/libslicot/AG08BZ.f | 641 +++++++ mex/sources/libslicot/AG8BYZ.f | 692 +++++++ mex/sources/libslicot/BB01AD.f | 1286 +++++++++++++ mex/sources/libslicot/BB02AD.f | 1017 +++++++++++ mex/sources/libslicot/BB03AD.f | 490 +++++ mex/sources/libslicot/BB04AD.f | 476 +++++ mex/sources/libslicot/BD01AD.f | 1017 +++++++++++ mex/sources/libslicot/BD02AD.f | 601 ++++++ mex/sources/libslicot/DE01OD.f | 203 ++ mex/sources/libslicot/DE01PD.f | 236 +++ mex/sources/libslicot/DF01MD.f | 299 +++ mex/sources/libslicot/DG01MD.f | 235 +++ mex/sources/libslicot/DG01ND.f | 247 +++ mex/sources/libslicot/DG01NY.f | 94 + mex/sources/libslicot/DG01OD.f | 357 ++++ mex/sources/libslicot/DK01MD.f | 183 ++ mex/sources/libslicot/FB01QD.f | 464 +++++ mex/sources/libslicot/FB01RD.f | 535 ++++++ mex/sources/libslicot/FB01SD.f | 597 ++++++ mex/sources/libslicot/FB01TD.f | 641 +++++++ mex/sources/libslicot/FB01VD.f | 391 ++++ mex/sources/libslicot/FD01AD.f | 367 ++++ mex/sources/libslicot/IB01AD.f | 686 +++++++ mex/sources/libslicot/IB01BD.f | 791 ++++++++ mex/sources/libslicot/IB01CD.f | 823 +++++++++ mex/sources/libslicot/IB01MD.f | 1433 +++++++++++++++ mex/sources/libslicot/IB01MY.f | 1094 +++++++++++ mex/sources/libslicot/IB01ND.f | 731 ++++++++ mex/sources/libslicot/IB01OD.f | 214 +++ mex/sources/libslicot/IB01OY.f | 175 ++ mex/sources/libslicot/IB01PD.f | 1232 +++++++++++++ mex/sources/libslicot/IB01PX.f | 474 +++++ mex/sources/libslicot/IB01PY.f | 768 ++++++++ mex/sources/libslicot/IB01QD.f | 1081 +++++++++++ mex/sources/libslicot/IB01RD.f | 762 ++++++++ mex/sources/libslicot/IB03AD.f | 1076 +++++++++++ mex/sources/libslicot/IB03BD.f | 1087 +++++++++++ mex/sources/libslicot/MA01AD.f | 95 + mex/sources/libslicot/MA02AD.f | 108 ++ mex/sources/libslicot/MA02BD.f | 113 ++ mex/sources/libslicot/MA02BZ.f | 114 ++ mex/sources/libslicot/MA02CD.f | 113 ++ mex/sources/libslicot/MA02CZ.f | 113 ++ mex/sources/libslicot/MA02DD.f | 157 ++ mex/sources/libslicot/MA02ED.f | 99 + mex/sources/libslicot/MA02FD.f | 104 ++ mex/sources/libslicot/MA02GD.f | 158 ++ mex/sources/libslicot/MA02HD.f | 180 ++ mex/sources/libslicot/MA02ID.f | 293 +++ mex/sources/libslicot/MA02JD.f | 164 ++ mex/sources/libslicot/MB01MD.f | 279 +++ mex/sources/libslicot/MB01ND.f | 249 +++ mex/sources/libslicot/MB01PD.f | 271 +++ mex/sources/libslicot/MB01QD.f | 334 ++++ mex/sources/libslicot/MB01RD.f | 345 ++++ mex/sources/libslicot/MB01RU.f | 282 +++ mex/sources/libslicot/MB01RW.f | 249 +++ mex/sources/libslicot/MB01RX.f | 315 ++++ mex/sources/libslicot/MB01RY.f | 429 +++++ mex/sources/libslicot/MB01SD.f | 123 ++ mex/sources/libslicot/MB01TD.f | 173 ++ mex/sources/libslicot/MB01UD.f | 238 +++ mex/sources/libslicot/MB01UW.f | 377 ++++ mex/sources/libslicot/MB01UX.f | 373 ++++ mex/sources/libslicot/MB01VD.f | 1693 +++++++++++++++++ mex/sources/libslicot/MB01WD.f | 343 ++++ mex/sources/libslicot/MB01XD.f | 207 +++ mex/sources/libslicot/MB01XY.f | 191 ++ mex/sources/libslicot/MB01YD.f | 352 ++++ mex/sources/libslicot/MB01ZD.f | 475 +++++ mex/sources/libslicot/MB02CD.f | 597 ++++++ mex/sources/libslicot/MB02CU.f | 1015 ++++++++++ mex/sources/libslicot/MB02CV.f | 795 ++++++++ mex/sources/libslicot/MB02CX.f | 318 ++++ mex/sources/libslicot/MB02CY.f | 372 ++++ mex/sources/libslicot/MB02DD.f | 564 ++++++ mex/sources/libslicot/MB02ED.f | 445 +++++ mex/sources/libslicot/MB02FD.f | 383 ++++ mex/sources/libslicot/MB02GD.f | 558 ++++++ mex/sources/libslicot/MB02HD.f | 545 ++++++ mex/sources/libslicot/MB02ID.f | 508 +++++ mex/sources/libslicot/MB02JD.f | 486 +++++ mex/sources/libslicot/MB02JX.f | 737 ++++++++ mex/sources/libslicot/MB02KD.f | 842 +++++++++ mex/sources/libslicot/MB02MD.f | 577 ++++++ mex/sources/libslicot/MB02ND.f | 889 +++++++++ mex/sources/libslicot/MB02NY.f | 261 +++ mex/sources/libslicot/MB02OD.f | 267 +++ mex/sources/libslicot/MB02PD.f | 553 ++++++ mex/sources/libslicot/MB02QD.f | 502 +++++ mex/sources/libslicot/MB02QY.f | 339 ++++ mex/sources/libslicot/MB02RD.f | 197 ++ mex/sources/libslicot/MB02RZ.f | 216 +++ mex/sources/libslicot/MB02SD.f | 164 ++ mex/sources/libslicot/MB02SZ.f | 169 ++ mex/sources/libslicot/MB02TD.f | 236 +++ mex/sources/libslicot/MB02TZ.f | 247 +++ mex/sources/libslicot/MB02UD.f | 624 +++++++ mex/sources/libslicot/MB02UU.f | 162 ++ mex/sources/libslicot/MB02UV.f | 195 ++ mex/sources/libslicot/MB02VD.f | 187 ++ mex/sources/libslicot/MB02WD.f | 458 +++++ mex/sources/libslicot/MB02XD.f | 409 +++++ mex/sources/libslicot/MB02YD.f | 371 ++++ mex/sources/libslicot/MB03MD.f | 343 ++++ mex/sources/libslicot/MB03MY.f | 91 + mex/sources/libslicot/MB03ND.f | 217 +++ mex/sources/libslicot/MB03NY.f | 208 +++ mex/sources/libslicot/MB03OD.f | 306 ++++ mex/sources/libslicot/MB03OY.f | 388 ++++ mex/sources/libslicot/MB03PD.f | 339 ++++ mex/sources/libslicot/MB03PY.f | 392 ++++ mex/sources/libslicot/MB03QD.f | 316 ++++ mex/sources/libslicot/MB03QX.f | 122 ++ mex/sources/libslicot/MB03QY.f | 164 ++ mex/sources/libslicot/MB03RD.f | 613 +++++++ mex/sources/libslicot/MB03RX.f | 226 +++ mex/sources/libslicot/MB03RY.f | 261 +++ mex/sources/libslicot/MB03SD.f | 348 ++++ mex/sources/libslicot/MB03TD.f | 641 +++++++ mex/sources/libslicot/MB03TS.f | 746 ++++++++ mex/sources/libslicot/MB03UD.f | 318 ++++ mex/sources/libslicot/MB03VD.f | 306 ++++ mex/sources/libslicot/MB03VY.f | 216 +++ mex/sources/libslicot/MB03WA.f | 538 ++++++ mex/sources/libslicot/MB03WD.f | 966 ++++++++++ mex/sources/libslicot/MB03WX.f | 170 ++ mex/sources/libslicot/MB03XD.f | 826 +++++++++ mex/sources/libslicot/MB03XP.f | 659 +++++++ mex/sources/libslicot/MB03XU.f | 2338 ++++++++++++++++++++++++ mex/sources/libslicot/MB03YA.f | 297 +++ mex/sources/libslicot/MB03YD.f | 540 ++++++ mex/sources/libslicot/MB03YT.f | 331 ++++ mex/sources/libslicot/MB03ZA.f | 1371 ++++++++++++++ mex/sources/libslicot/MB03ZD.f | 908 +++++++++ mex/sources/libslicot/MB04DD.f | 440 +++++ mex/sources/libslicot/MB04DI.f | 216 +++ mex/sources/libslicot/MB04DS.f | 450 +++++ mex/sources/libslicot/MB04DY.f | 329 ++++ mex/sources/libslicot/MB04GD.f | 258 +++ mex/sources/libslicot/MB04ID.f | 278 +++ mex/sources/libslicot/MB04IY.f | 327 ++++ mex/sources/libslicot/MB04IZ.f | 282 +++ mex/sources/libslicot/MB04JD.f | 248 +++ mex/sources/libslicot/MB04KD.f | 209 +++ mex/sources/libslicot/MB04LD.f | 209 +++ mex/sources/libslicot/MB04MD.f | 290 +++ mex/sources/libslicot/MB04ND.f | 257 +++ mex/sources/libslicot/MB04NY.f | 437 +++++ mex/sources/libslicot/MB04OD.f | 257 +++ mex/sources/libslicot/MB04OW.f | 251 +++ mex/sources/libslicot/MB04OX.f | 106 ++ mex/sources/libslicot/MB04OY.f | 370 ++++ mex/sources/libslicot/MB04PA.f | 1105 +++++++++++ mex/sources/libslicot/MB04PB.f | 333 ++++ mex/sources/libslicot/MB04PU.f | 369 ++++ mex/sources/libslicot/MB04PY.f | 648 +++++++ mex/sources/libslicot/MB04QB.f | 454 +++++ mex/sources/libslicot/MB04QC.f | 1223 +++++++++++++ mex/sources/libslicot/MB04QF.f | 532 ++++++ mex/sources/libslicot/MB04QU.f | 472 +++++ mex/sources/libslicot/MB04TB.f | 677 +++++++ mex/sources/libslicot/MB04TS.f | 519 ++++++ mex/sources/libslicot/MB04TT.f | 413 +++++ mex/sources/libslicot/MB04TU.f | 96 + mex/sources/libslicot/MB04TV.f | 171 ++ mex/sources/libslicot/MB04TW.f | 180 ++ mex/sources/libslicot/MB04TX.f | 394 ++++ mex/sources/libslicot/MB04TY.f | 241 +++ mex/sources/libslicot/MB04UD.f | 375 ++++ mex/sources/libslicot/MB04VD.f | 540 ++++++ mex/sources/libslicot/MB04VX.f | 384 ++++ mex/sources/libslicot/MB04WD.f | 411 +++++ mex/sources/libslicot/MB04WP.f | 211 +++ mex/sources/libslicot/MB04WR.f | 340 ++++ mex/sources/libslicot/MB04WU.f | 402 ++++ mex/sources/libslicot/MB04XD.f | 652 +++++++ mex/sources/libslicot/MB04XY.f | 274 +++ mex/sources/libslicot/MB04YD.f | 623 +++++++ mex/sources/libslicot/MB04YW.f | 513 ++++++ mex/sources/libslicot/MB04ZD.f | 486 +++++ mex/sources/libslicot/MB05MD.f | 356 ++++ mex/sources/libslicot/MB05MY.f | 327 ++++ mex/sources/libslicot/MB05ND.f | 377 ++++ mex/sources/libslicot/MB05OD.f | 574 ++++++ mex/sources/libslicot/MB05OY.f | 179 ++ mex/sources/libslicot/MB3OYZ.f | 395 ++++ mex/sources/libslicot/MB3PYZ.f | 398 ++++ mex/sources/libslicot/MC01MD.f | 162 ++ mex/sources/libslicot/MC01ND.f | 146 ++ mex/sources/libslicot/MC01OD.f | 147 ++ mex/sources/libslicot/MC01PD.f | 159 ++ mex/sources/libslicot/MC01PY.f | 157 ++ mex/sources/libslicot/MC01QD.f | 207 +++ mex/sources/libslicot/MC01RD.f | 299 +++ mex/sources/libslicot/MC01SD.f | 281 +++ mex/sources/libslicot/MC01SW.f | 104 ++ mex/sources/libslicot/MC01SX.f | 68 + mex/sources/libslicot/MC01SY.f | 146 ++ mex/sources/libslicot/MC01TD.f | 305 ++++ mex/sources/libslicot/MC01VD.f | 304 +++ mex/sources/libslicot/MC01WD.f | 156 ++ mex/sources/libslicot/MC03MD.f | 351 ++++ mex/sources/libslicot/MC03ND.f | 495 +++++ mex/sources/libslicot/MC03NX.f | 146 ++ mex/sources/libslicot/MC03NY.f | 412 +++++ mex/sources/libslicot/MD03AD.f | 973 ++++++++++ mex/sources/libslicot/MD03BA.f | 151 ++ mex/sources/libslicot/MD03BB.f | 203 ++ mex/sources/libslicot/MD03BD.f | 1206 ++++++++++++ mex/sources/libslicot/MD03BF.f | 122 ++ mex/sources/libslicot/MD03BX.f | 255 +++ mex/sources/libslicot/MD03BY.f | 514 ++++++ mex/sources/libslicot/NF01AD.f | 230 +++ mex/sources/libslicot/NF01AY.f | 353 ++++ mex/sources/libslicot/NF01BA.f | 104 ++ mex/sources/libslicot/NF01BB.f | 138 ++ mex/sources/libslicot/NF01BD.f | 381 ++++ mex/sources/libslicot/NF01BE.f | 105 ++ mex/sources/libslicot/NF01BF.f | 157 ++ mex/sources/libslicot/NF01BP.f | 666 +++++++ mex/sources/libslicot/NF01BQ.f | 477 +++++ mex/sources/libslicot/NF01BR.f | 711 +++++++ mex/sources/libslicot/NF01BS.f | 610 +++++++ mex/sources/libslicot/NF01BU.f | 398 ++++ mex/sources/libslicot/NF01BV.f | 249 +++ mex/sources/libslicot/NF01BW.f | 242 +++ mex/sources/libslicot/NF01BX.f | 174 ++ mex/sources/libslicot/NF01BY.f | 294 +++ mex/sources/libslicot/SB01BD.f | 776 ++++++++ mex/sources/libslicot/SB01BX.f | 150 ++ mex/sources/libslicot/SB01BY.f | 332 ++++ mex/sources/libslicot/SB01DD.f | 643 +++++++ mex/sources/libslicot/SB01FY.f | 315 ++++ mex/sources/libslicot/SB01MD.f | 397 ++++ mex/sources/libslicot/SB02CX.f | 94 + mex/sources/libslicot/SB02MD.f | 559 ++++++ mex/sources/libslicot/SB02MR.f | 75 + mex/sources/libslicot/SB02MS.f | 79 + mex/sources/libslicot/SB02MT.f | 581 ++++++ mex/sources/libslicot/SB02MU.f | 486 +++++ mex/sources/libslicot/SB02MV.f | 75 + mex/sources/libslicot/SB02MW.f | 79 + mex/sources/libslicot/SB02ND.f | 755 ++++++++ mex/sources/libslicot/SB02OD.f | 856 +++++++++ mex/sources/libslicot/SB02OU.f | 83 + mex/sources/libslicot/SB02OV.f | 88 + mex/sources/libslicot/SB02OW.f | 83 + mex/sources/libslicot/SB02OX.f | 87 + mex/sources/libslicot/SB02OY.f | 791 ++++++++ mex/sources/libslicot/SB02PD.f | 756 ++++++++ mex/sources/libslicot/SB02QD.f | 804 ++++++++ mex/sources/libslicot/SB02RD.f | 1133 ++++++++++++ mex/sources/libslicot/SB02RU.f | 508 +++++ mex/sources/libslicot/SB02SD.f | 859 +++++++++ mex/sources/libslicot/SB03MD.f | 556 ++++++ mex/sources/libslicot/SB03MU.f | 467 +++++ mex/sources/libslicot/SB03MV.f | 295 +++ mex/sources/libslicot/SB03MW.f | 293 +++ mex/sources/libslicot/SB03MX.f | 711 +++++++ mex/sources/libslicot/SB03MY.f | 613 +++++++ mex/sources/libslicot/SB03OD.f | 662 +++++++ mex/sources/libslicot/SB03OR.f | 429 +++++ mex/sources/libslicot/SB03OT.f | 984 ++++++++++ mex/sources/libslicot/SB03OU.f | 410 +++++ mex/sources/libslicot/SB03OV.f | 105 ++ mex/sources/libslicot/SB03OY.f | 693 +++++++ mex/sources/libslicot/SB03PD.f | 410 +++++ mex/sources/libslicot/SB03QD.f | 676 +++++++ mex/sources/libslicot/SB03QX.f | 394 ++++ mex/sources/libslicot/SB03QY.f | 443 +++++ mex/sources/libslicot/SB03RD.f | 404 ++++ mex/sources/libslicot/SB03SD.f | 674 +++++++ mex/sources/libslicot/SB03SX.f | 398 ++++ mex/sources/libslicot/SB03SY.f | 451 +++++ mex/sources/libslicot/SB03TD.f | 545 ++++++ mex/sources/libslicot/SB03UD.f | 554 ++++++ mex/sources/libslicot/SB04MD.f | 347 ++++ mex/sources/libslicot/SB04MR.f | 222 +++ mex/sources/libslicot/SB04MU.f | 190 ++ mex/sources/libslicot/SB04MW.f | 194 ++ mex/sources/libslicot/SB04MY.f | 168 ++ mex/sources/libslicot/SB04ND.f | 405 ++++ mex/sources/libslicot/SB04NV.f | 165 ++ mex/sources/libslicot/SB04NW.f | 155 ++ mex/sources/libslicot/SB04NX.f | 320 ++++ mex/sources/libslicot/SB04NY.f | 260 +++ mex/sources/libslicot/SB04OD.f | 1028 +++++++++++ mex/sources/libslicot/SB04OW.f | 568 ++++++ mex/sources/libslicot/SB04PD.f | 672 +++++++ mex/sources/libslicot/SB04PX.f | 468 +++++ mex/sources/libslicot/SB04PY.f | 1111 +++++++++++ mex/sources/libslicot/SB04QD.f | 376 ++++ mex/sources/libslicot/SB04QR.f | 224 +++ mex/sources/libslicot/SB04QU.f | 218 +++ mex/sources/libslicot/SB04QY.f | 185 ++ mex/sources/libslicot/SB04RD.f | 406 ++++ mex/sources/libslicot/SB04RV.f | 198 ++ mex/sources/libslicot/SB04RW.f | 178 ++ mex/sources/libslicot/SB04RX.f | 375 ++++ mex/sources/libslicot/SB04RY.f | 261 +++ mex/sources/libslicot/SB06ND.f | 325 ++++ mex/sources/libslicot/SB08CD.f | 355 ++++ mex/sources/libslicot/SB08DD.f | 583 ++++++ mex/sources/libslicot/SB08ED.f | 359 ++++ mex/sources/libslicot/SB08FD.f | 630 +++++++ mex/sources/libslicot/SB08GD.f | 256 +++ mex/sources/libslicot/SB08HD.f | 267 +++ mex/sources/libslicot/SB08MD.f | 471 +++++ mex/sources/libslicot/SB08MY.f | 102 ++ mex/sources/libslicot/SB08ND.f | 382 ++++ mex/sources/libslicot/SB08NY.f | 83 + mex/sources/libslicot/SB09MD.f | 251 +++ mex/sources/libslicot/SB10AD.f | 827 +++++++++ mex/sources/libslicot/SB10DD.f | 1007 ++++++++++ mex/sources/libslicot/SB10ED.f | 468 +++++ mex/sources/libslicot/SB10FD.f | 469 +++++ mex/sources/libslicot/SB10HD.f | 390 ++++ mex/sources/libslicot/SB10ID.f | 584 ++++++ mex/sources/libslicot/SB10JD.f | 355 ++++ mex/sources/libslicot/SB10KD.f | 650 +++++++ mex/sources/libslicot/SB10LD.f | 438 +++++ mex/sources/libslicot/SB10MD.f | 670 +++++++ mex/sources/libslicot/SB10PD.f | 505 +++++ mex/sources/libslicot/SB10QD.f | 602 ++++++ mex/sources/libslicot/SB10RD.f | 706 +++++++ mex/sources/libslicot/SB10SD.f | 629 +++++++ mex/sources/libslicot/SB10TD.f | 350 ++++ mex/sources/libslicot/SB10UD.f | 419 +++++ mex/sources/libslicot/SB10VD.f | 393 ++++ mex/sources/libslicot/SB10WD.f | 299 +++ mex/sources/libslicot/SB10YD.f | 689 +++++++ mex/sources/libslicot/SB10ZD.f | 914 +++++++++ mex/sources/libslicot/SB10ZP.f | 339 ++++ mex/sources/libslicot/SB16AD.f | 719 ++++++++ mex/sources/libslicot/SB16AY.f | 909 +++++++++ mex/sources/libslicot/SB16BD.f | 652 +++++++ mex/sources/libslicot/SB16CD.f | 526 ++++++ mex/sources/libslicot/SB16CY.f | 409 +++++ mex/sources/libslicot/SG02AD.f | 939 ++++++++++ mex/sources/libslicot/SG03AD.f | 639 +++++++ mex/sources/libslicot/SG03AX.f | 687 +++++++ mex/sources/libslicot/SG03AY.f | 686 +++++++ mex/sources/libslicot/SG03BD.f | 814 +++++++++ mex/sources/libslicot/SG03BU.f | 696 +++++++ mex/sources/libslicot/SG03BV.f | 645 +++++++ mex/sources/libslicot/SG03BW.f | 459 +++++ mex/sources/libslicot/SG03BX.f | 764 ++++++++ mex/sources/libslicot/SG03BY.f | 93 + mex/sources/libslicot/TB01ID.f | 402 ++++ mex/sources/libslicot/TB01IZ.f | 409 +++++ mex/sources/libslicot/TB01KD.f | 334 ++++ mex/sources/libslicot/TB01LD.f | 348 ++++ mex/sources/libslicot/TB01MD.f | 338 ++++ mex/sources/libslicot/TB01ND.f | 349 ++++ mex/sources/libslicot/TB01PD.f | 352 ++++ mex/sources/libslicot/TB01TD.f | 308 ++++ mex/sources/libslicot/TB01TY.f | 136 ++ mex/sources/libslicot/TB01UD.f | 491 +++++ mex/sources/libslicot/TB01VD.f | 503 +++++ mex/sources/libslicot/TB01VY.f | 317 ++++ mex/sources/libslicot/TB01WD.f | 259 +++ mex/sources/libslicot/TB01XD.f | 284 +++ mex/sources/libslicot/TB01XZ.f | 280 +++ mex/sources/libslicot/TB01YD.f | 188 ++ mex/sources/libslicot/TB01ZD.f | 440 +++++ mex/sources/libslicot/TB03AD.f | 746 ++++++++ mex/sources/libslicot/TB03AY.f | 159 ++ mex/sources/libslicot/TB04AD.f | 395 ++++ mex/sources/libslicot/TB04AY.f | 246 +++ mex/sources/libslicot/TB04BD.f | 600 ++++++ mex/sources/libslicot/TB04BV.f | 343 ++++ mex/sources/libslicot/TB04BW.f | 280 +++ mex/sources/libslicot/TB04BX.f | 246 +++ mex/sources/libslicot/TB04CD.f | 568 ++++++ mex/sources/libslicot/TB05AD.f | 545 ++++++ mex/sources/libslicot/TC01OD.f | 236 +++ mex/sources/libslicot/TC04AD.f | 483 +++++ mex/sources/libslicot/TC05AD.f | 403 ++++ mex/sources/libslicot/TD03AD.f | 581 ++++++ mex/sources/libslicot/TD03AY.f | 171 ++ mex/sources/libslicot/TD04AD.f | 425 +++++ mex/sources/libslicot/TD05AD.f | 314 ++++ mex/sources/libslicot/TF01MD.f | 233 +++ mex/sources/libslicot/TF01MX.f | 457 +++++ mex/sources/libslicot/TF01MY.f | 358 ++++ mex/sources/libslicot/TF01ND.f | 278 +++ mex/sources/libslicot/TF01OD.f | 179 ++ mex/sources/libslicot/TF01PD.f | 178 ++ mex/sources/libslicot/TF01QD.f | 234 +++ mex/sources/libslicot/TF01RD.f | 230 +++ mex/sources/libslicot/TG01AD.f | 513 ++++++ mex/sources/libslicot/TG01AZ.f | 523 ++++++ mex/sources/libslicot/TG01BD.f | 434 +++++ mex/sources/libslicot/TG01CD.f | 292 +++ mex/sources/libslicot/TG01DD.f | 295 +++ mex/sources/libslicot/TG01ED.f | 793 ++++++++ mex/sources/libslicot/TG01FD.f | 725 ++++++++ mex/sources/libslicot/TG01FZ.f | 733 ++++++++ mex/sources/libslicot/TG01HD.f | 545 ++++++ mex/sources/libslicot/TG01HX.f | 694 +++++++ mex/sources/libslicot/TG01ID.f | 587 ++++++ mex/sources/libslicot/TG01JD.f | 613 +++++++ mex/sources/libslicot/TG01WD.f | 319 ++++ mex/sources/libslicot/UD01BD.f | 149 ++ mex/sources/libslicot/UD01CD.f | 174 ++ mex/sources/libslicot/UD01DD.f | 138 ++ mex/sources/libslicot/UD01MD.f | 175 ++ mex/sources/libslicot/UD01MZ.f | 175 ++ mex/sources/libslicot/UD01ND.f | 203 ++ mex/sources/libslicot/UE01MD.f | 266 +++ mex/sources/libslicot/dcabs1.f | 16 + mex/sources/libslicot/delctg.f | 27 + mex/sources/libslicot/dhgeqz.f | 1249 +++++++++++++ mex/sources/libslicot/dtgsy2.f | 956 ++++++++++ mex/sources/libslicot/readme | 8 + mex/sources/libslicot/select.f | 27 + 480 files changed, 211317 insertions(+), 4 deletions(-) create mode 100644 mex/build/libslicot.am create mode 100644 mex/build/matlab/libslicot/Makefile.am create mode 100644 mex/build/octave/libslicot/Makefile.am create mode 100644 mex/sources/libslicot/AB01MD.f create mode 100644 mex/sources/libslicot/AB01ND.f create mode 100644 mex/sources/libslicot/AB01OD.f create mode 100644 mex/sources/libslicot/AB04MD.f create mode 100644 mex/sources/libslicot/AB05MD.f create mode 100644 mex/sources/libslicot/AB05ND.f create mode 100644 mex/sources/libslicot/AB05OD.f create mode 100644 mex/sources/libslicot/AB05PD.f create mode 100644 mex/sources/libslicot/AB05QD.f create mode 100644 mex/sources/libslicot/AB05RD.f create mode 100644 mex/sources/libslicot/AB05SD.f create mode 100644 mex/sources/libslicot/AB07MD.f create mode 100644 mex/sources/libslicot/AB07ND.f create mode 100644 mex/sources/libslicot/AB08MD.f create mode 100644 mex/sources/libslicot/AB08MZ.f create mode 100644 mex/sources/libslicot/AB08ND.f create mode 100644 mex/sources/libslicot/AB08NX.f create mode 100644 mex/sources/libslicot/AB08NZ.f create mode 100644 mex/sources/libslicot/AB09AD.f create mode 100644 mex/sources/libslicot/AB09AX.f create mode 100644 mex/sources/libslicot/AB09BD.f create mode 100644 mex/sources/libslicot/AB09BX.f create mode 100644 mex/sources/libslicot/AB09CD.f create mode 100644 mex/sources/libslicot/AB09CX.f create mode 100644 mex/sources/libslicot/AB09DD.f create mode 100644 mex/sources/libslicot/AB09ED.f create mode 100644 mex/sources/libslicot/AB09FD.f create mode 100644 mex/sources/libslicot/AB09GD.f create mode 100644 mex/sources/libslicot/AB09HD.f create mode 100644 mex/sources/libslicot/AB09HX.f create mode 100644 mex/sources/libslicot/AB09HY.f create mode 100644 mex/sources/libslicot/AB09ID.f create mode 100644 mex/sources/libslicot/AB09IX.f create mode 100644 mex/sources/libslicot/AB09IY.f create mode 100644 mex/sources/libslicot/AB09JD.f create mode 100644 mex/sources/libslicot/AB09JV.f create mode 100644 mex/sources/libslicot/AB09JW.f create mode 100644 mex/sources/libslicot/AB09JX.f create mode 100644 mex/sources/libslicot/AB09KD.f create mode 100644 mex/sources/libslicot/AB09KX.f create mode 100644 mex/sources/libslicot/AB09MD.f create mode 100644 mex/sources/libslicot/AB09ND.f create mode 100644 mex/sources/libslicot/AB13AD.f create mode 100644 mex/sources/libslicot/AB13AX.f create mode 100644 mex/sources/libslicot/AB13BD.f create mode 100644 mex/sources/libslicot/AB13CD.f create mode 100644 mex/sources/libslicot/AB13DD.f create mode 100644 mex/sources/libslicot/AB13DX.f create mode 100644 mex/sources/libslicot/AB13ED.f create mode 100644 mex/sources/libslicot/AB13FD.f create mode 100644 mex/sources/libslicot/AB13MD.f create mode 100644 mex/sources/libslicot/AB8NXZ.f create mode 100644 mex/sources/libslicot/AG07BD.f create mode 100644 mex/sources/libslicot/AG08BD.f create mode 100644 mex/sources/libslicot/AG08BY.f create mode 100644 mex/sources/libslicot/AG08BZ.f create mode 100644 mex/sources/libslicot/AG8BYZ.f create mode 100644 mex/sources/libslicot/BB01AD.f create mode 100644 mex/sources/libslicot/BB02AD.f create mode 100644 mex/sources/libslicot/BB03AD.f create mode 100644 mex/sources/libslicot/BB04AD.f create mode 100644 mex/sources/libslicot/BD01AD.f create mode 100644 mex/sources/libslicot/BD02AD.f create mode 100644 mex/sources/libslicot/DE01OD.f create mode 100644 mex/sources/libslicot/DE01PD.f create mode 100644 mex/sources/libslicot/DF01MD.f create mode 100644 mex/sources/libslicot/DG01MD.f create mode 100644 mex/sources/libslicot/DG01ND.f create mode 100644 mex/sources/libslicot/DG01NY.f create mode 100644 mex/sources/libslicot/DG01OD.f create mode 100644 mex/sources/libslicot/DK01MD.f create mode 100644 mex/sources/libslicot/FB01QD.f create mode 100644 mex/sources/libslicot/FB01RD.f create mode 100644 mex/sources/libslicot/FB01SD.f create mode 100644 mex/sources/libslicot/FB01TD.f create mode 100644 mex/sources/libslicot/FB01VD.f create mode 100644 mex/sources/libslicot/FD01AD.f create mode 100644 mex/sources/libslicot/IB01AD.f create mode 100644 mex/sources/libslicot/IB01BD.f create mode 100644 mex/sources/libslicot/IB01CD.f create mode 100644 mex/sources/libslicot/IB01MD.f create mode 100644 mex/sources/libslicot/IB01MY.f create mode 100644 mex/sources/libslicot/IB01ND.f create mode 100644 mex/sources/libslicot/IB01OD.f create mode 100644 mex/sources/libslicot/IB01OY.f create mode 100644 mex/sources/libslicot/IB01PD.f create mode 100644 mex/sources/libslicot/IB01PX.f create mode 100644 mex/sources/libslicot/IB01PY.f create mode 100644 mex/sources/libslicot/IB01QD.f create mode 100644 mex/sources/libslicot/IB01RD.f create mode 100644 mex/sources/libslicot/IB03AD.f create mode 100644 mex/sources/libslicot/IB03BD.f create mode 100644 mex/sources/libslicot/MA01AD.f create mode 100644 mex/sources/libslicot/MA02AD.f create mode 100644 mex/sources/libslicot/MA02BD.f create mode 100644 mex/sources/libslicot/MA02BZ.f create mode 100644 mex/sources/libslicot/MA02CD.f create mode 100644 mex/sources/libslicot/MA02CZ.f create mode 100644 mex/sources/libslicot/MA02DD.f create mode 100644 mex/sources/libslicot/MA02ED.f create mode 100644 mex/sources/libslicot/MA02FD.f create mode 100644 mex/sources/libslicot/MA02GD.f create mode 100644 mex/sources/libslicot/MA02HD.f create mode 100644 mex/sources/libslicot/MA02ID.f create mode 100644 mex/sources/libslicot/MA02JD.f create mode 100644 mex/sources/libslicot/MB01MD.f create mode 100644 mex/sources/libslicot/MB01ND.f create mode 100644 mex/sources/libslicot/MB01PD.f create mode 100644 mex/sources/libslicot/MB01QD.f create mode 100644 mex/sources/libslicot/MB01RD.f create mode 100644 mex/sources/libslicot/MB01RU.f create mode 100644 mex/sources/libslicot/MB01RW.f create mode 100644 mex/sources/libslicot/MB01RX.f create mode 100644 mex/sources/libslicot/MB01RY.f create mode 100644 mex/sources/libslicot/MB01SD.f create mode 100644 mex/sources/libslicot/MB01TD.f create mode 100644 mex/sources/libslicot/MB01UD.f create mode 100644 mex/sources/libslicot/MB01UW.f create mode 100644 mex/sources/libslicot/MB01UX.f create mode 100644 mex/sources/libslicot/MB01VD.f create mode 100644 mex/sources/libslicot/MB01WD.f create mode 100644 mex/sources/libslicot/MB01XD.f create mode 100644 mex/sources/libslicot/MB01XY.f create mode 100644 mex/sources/libslicot/MB01YD.f create mode 100644 mex/sources/libslicot/MB01ZD.f create mode 100644 mex/sources/libslicot/MB02CD.f create mode 100644 mex/sources/libslicot/MB02CU.f create mode 100644 mex/sources/libslicot/MB02CV.f create mode 100644 mex/sources/libslicot/MB02CX.f create mode 100644 mex/sources/libslicot/MB02CY.f create mode 100644 mex/sources/libslicot/MB02DD.f create mode 100644 mex/sources/libslicot/MB02ED.f create mode 100644 mex/sources/libslicot/MB02FD.f create mode 100644 mex/sources/libslicot/MB02GD.f create mode 100644 mex/sources/libslicot/MB02HD.f create mode 100644 mex/sources/libslicot/MB02ID.f create mode 100644 mex/sources/libslicot/MB02JD.f create mode 100644 mex/sources/libslicot/MB02JX.f create mode 100644 mex/sources/libslicot/MB02KD.f create mode 100644 mex/sources/libslicot/MB02MD.f create mode 100644 mex/sources/libslicot/MB02ND.f create mode 100644 mex/sources/libslicot/MB02NY.f create mode 100644 mex/sources/libslicot/MB02OD.f create mode 100644 mex/sources/libslicot/MB02PD.f create mode 100644 mex/sources/libslicot/MB02QD.f create mode 100644 mex/sources/libslicot/MB02QY.f create mode 100644 mex/sources/libslicot/MB02RD.f create mode 100644 mex/sources/libslicot/MB02RZ.f create mode 100644 mex/sources/libslicot/MB02SD.f create mode 100644 mex/sources/libslicot/MB02SZ.f create mode 100644 mex/sources/libslicot/MB02TD.f create mode 100644 mex/sources/libslicot/MB02TZ.f create mode 100644 mex/sources/libslicot/MB02UD.f create mode 100644 mex/sources/libslicot/MB02UU.f create mode 100644 mex/sources/libslicot/MB02UV.f create mode 100644 mex/sources/libslicot/MB02VD.f create mode 100644 mex/sources/libslicot/MB02WD.f create mode 100644 mex/sources/libslicot/MB02XD.f create mode 100644 mex/sources/libslicot/MB02YD.f create mode 100644 mex/sources/libslicot/MB03MD.f create mode 100644 mex/sources/libslicot/MB03MY.f create mode 100644 mex/sources/libslicot/MB03ND.f create mode 100644 mex/sources/libslicot/MB03NY.f create mode 100644 mex/sources/libslicot/MB03OD.f create mode 100644 mex/sources/libslicot/MB03OY.f create mode 100644 mex/sources/libslicot/MB03PD.f create mode 100644 mex/sources/libslicot/MB03PY.f create mode 100644 mex/sources/libslicot/MB03QD.f create mode 100644 mex/sources/libslicot/MB03QX.f create mode 100644 mex/sources/libslicot/MB03QY.f create mode 100644 mex/sources/libslicot/MB03RD.f create mode 100644 mex/sources/libslicot/MB03RX.f create mode 100644 mex/sources/libslicot/MB03RY.f create mode 100644 mex/sources/libslicot/MB03SD.f create mode 100644 mex/sources/libslicot/MB03TD.f create mode 100644 mex/sources/libslicot/MB03TS.f create mode 100644 mex/sources/libslicot/MB03UD.f create mode 100644 mex/sources/libslicot/MB03VD.f create mode 100644 mex/sources/libslicot/MB03VY.f create mode 100644 mex/sources/libslicot/MB03WA.f create mode 100644 mex/sources/libslicot/MB03WD.f create mode 100644 mex/sources/libslicot/MB03WX.f create mode 100644 mex/sources/libslicot/MB03XD.f create mode 100644 mex/sources/libslicot/MB03XP.f create mode 100644 mex/sources/libslicot/MB03XU.f create mode 100644 mex/sources/libslicot/MB03YA.f create mode 100644 mex/sources/libslicot/MB03YD.f create mode 100644 mex/sources/libslicot/MB03YT.f create mode 100644 mex/sources/libslicot/MB03ZA.f create mode 100644 mex/sources/libslicot/MB03ZD.f create mode 100644 mex/sources/libslicot/MB04DD.f create mode 100644 mex/sources/libslicot/MB04DI.f create mode 100644 mex/sources/libslicot/MB04DS.f create mode 100644 mex/sources/libslicot/MB04DY.f create mode 100644 mex/sources/libslicot/MB04GD.f create mode 100644 mex/sources/libslicot/MB04ID.f create mode 100644 mex/sources/libslicot/MB04IY.f create mode 100644 mex/sources/libslicot/MB04IZ.f create mode 100644 mex/sources/libslicot/MB04JD.f create mode 100644 mex/sources/libslicot/MB04KD.f create mode 100644 mex/sources/libslicot/MB04LD.f create mode 100644 mex/sources/libslicot/MB04MD.f create mode 100644 mex/sources/libslicot/MB04ND.f create mode 100644 mex/sources/libslicot/MB04NY.f create mode 100644 mex/sources/libslicot/MB04OD.f create mode 100644 mex/sources/libslicot/MB04OW.f create mode 100644 mex/sources/libslicot/MB04OX.f create mode 100644 mex/sources/libslicot/MB04OY.f create mode 100644 mex/sources/libslicot/MB04PA.f create mode 100644 mex/sources/libslicot/MB04PB.f create mode 100644 mex/sources/libslicot/MB04PU.f create mode 100644 mex/sources/libslicot/MB04PY.f create mode 100644 mex/sources/libslicot/MB04QB.f create mode 100644 mex/sources/libslicot/MB04QC.f create mode 100644 mex/sources/libslicot/MB04QF.f create mode 100644 mex/sources/libslicot/MB04QU.f create mode 100644 mex/sources/libslicot/MB04TB.f create mode 100644 mex/sources/libslicot/MB04TS.f create mode 100644 mex/sources/libslicot/MB04TT.f create mode 100644 mex/sources/libslicot/MB04TU.f create mode 100644 mex/sources/libslicot/MB04TV.f create mode 100644 mex/sources/libslicot/MB04TW.f create mode 100644 mex/sources/libslicot/MB04TX.f create mode 100644 mex/sources/libslicot/MB04TY.f create mode 100644 mex/sources/libslicot/MB04UD.f create mode 100644 mex/sources/libslicot/MB04VD.f create mode 100644 mex/sources/libslicot/MB04VX.f create mode 100644 mex/sources/libslicot/MB04WD.f create mode 100644 mex/sources/libslicot/MB04WP.f create mode 100644 mex/sources/libslicot/MB04WR.f create mode 100644 mex/sources/libslicot/MB04WU.f create mode 100644 mex/sources/libslicot/MB04XD.f create mode 100644 mex/sources/libslicot/MB04XY.f create mode 100644 mex/sources/libslicot/MB04YD.f create mode 100644 mex/sources/libslicot/MB04YW.f create mode 100644 mex/sources/libslicot/MB04ZD.f create mode 100644 mex/sources/libslicot/MB05MD.f create mode 100644 mex/sources/libslicot/MB05MY.f create mode 100644 mex/sources/libslicot/MB05ND.f create mode 100644 mex/sources/libslicot/MB05OD.f create mode 100644 mex/sources/libslicot/MB05OY.f create mode 100644 mex/sources/libslicot/MB3OYZ.f create mode 100644 mex/sources/libslicot/MB3PYZ.f create mode 100644 mex/sources/libslicot/MC01MD.f create mode 100644 mex/sources/libslicot/MC01ND.f create mode 100644 mex/sources/libslicot/MC01OD.f create mode 100644 mex/sources/libslicot/MC01PD.f create mode 100644 mex/sources/libslicot/MC01PY.f create mode 100644 mex/sources/libslicot/MC01QD.f create mode 100644 mex/sources/libslicot/MC01RD.f create mode 100644 mex/sources/libslicot/MC01SD.f create mode 100644 mex/sources/libslicot/MC01SW.f create mode 100644 mex/sources/libslicot/MC01SX.f create mode 100644 mex/sources/libslicot/MC01SY.f create mode 100644 mex/sources/libslicot/MC01TD.f create mode 100644 mex/sources/libslicot/MC01VD.f create mode 100644 mex/sources/libslicot/MC01WD.f create mode 100644 mex/sources/libslicot/MC03MD.f create mode 100644 mex/sources/libslicot/MC03ND.f create mode 100644 mex/sources/libslicot/MC03NX.f create mode 100644 mex/sources/libslicot/MC03NY.f create mode 100644 mex/sources/libslicot/MD03AD.f create mode 100644 mex/sources/libslicot/MD03BA.f create mode 100644 mex/sources/libslicot/MD03BB.f create mode 100644 mex/sources/libslicot/MD03BD.f create mode 100644 mex/sources/libslicot/MD03BF.f create mode 100644 mex/sources/libslicot/MD03BX.f create mode 100644 mex/sources/libslicot/MD03BY.f create mode 100644 mex/sources/libslicot/NF01AD.f create mode 100644 mex/sources/libslicot/NF01AY.f create mode 100644 mex/sources/libslicot/NF01BA.f create mode 100644 mex/sources/libslicot/NF01BB.f create mode 100644 mex/sources/libslicot/NF01BD.f create mode 100644 mex/sources/libslicot/NF01BE.f create mode 100644 mex/sources/libslicot/NF01BF.f create mode 100644 mex/sources/libslicot/NF01BP.f create mode 100644 mex/sources/libslicot/NF01BQ.f create mode 100644 mex/sources/libslicot/NF01BR.f create mode 100644 mex/sources/libslicot/NF01BS.f create mode 100644 mex/sources/libslicot/NF01BU.f create mode 100644 mex/sources/libslicot/NF01BV.f create mode 100644 mex/sources/libslicot/NF01BW.f create mode 100644 mex/sources/libslicot/NF01BX.f create mode 100644 mex/sources/libslicot/NF01BY.f create mode 100644 mex/sources/libslicot/SB01BD.f create mode 100644 mex/sources/libslicot/SB01BX.f create mode 100644 mex/sources/libslicot/SB01BY.f create mode 100644 mex/sources/libslicot/SB01DD.f create mode 100644 mex/sources/libslicot/SB01FY.f create mode 100644 mex/sources/libslicot/SB01MD.f create mode 100644 mex/sources/libslicot/SB02CX.f create mode 100644 mex/sources/libslicot/SB02MD.f create mode 100644 mex/sources/libslicot/SB02MR.f create mode 100644 mex/sources/libslicot/SB02MS.f create mode 100644 mex/sources/libslicot/SB02MT.f create mode 100644 mex/sources/libslicot/SB02MU.f create mode 100644 mex/sources/libslicot/SB02MV.f create mode 100644 mex/sources/libslicot/SB02MW.f create mode 100644 mex/sources/libslicot/SB02ND.f create mode 100644 mex/sources/libslicot/SB02OD.f create mode 100644 mex/sources/libslicot/SB02OU.f create mode 100644 mex/sources/libslicot/SB02OV.f create mode 100644 mex/sources/libslicot/SB02OW.f create mode 100644 mex/sources/libslicot/SB02OX.f create mode 100644 mex/sources/libslicot/SB02OY.f create mode 100644 mex/sources/libslicot/SB02PD.f create mode 100644 mex/sources/libslicot/SB02QD.f create mode 100644 mex/sources/libslicot/SB02RD.f create mode 100644 mex/sources/libslicot/SB02RU.f create mode 100644 mex/sources/libslicot/SB02SD.f create mode 100644 mex/sources/libslicot/SB03MD.f create mode 100644 mex/sources/libslicot/SB03MU.f create mode 100644 mex/sources/libslicot/SB03MV.f create mode 100644 mex/sources/libslicot/SB03MW.f create mode 100644 mex/sources/libslicot/SB03MX.f create mode 100644 mex/sources/libslicot/SB03MY.f create mode 100644 mex/sources/libslicot/SB03OD.f create mode 100644 mex/sources/libslicot/SB03OR.f create mode 100644 mex/sources/libslicot/SB03OT.f create mode 100644 mex/sources/libslicot/SB03OU.f create mode 100644 mex/sources/libslicot/SB03OV.f create mode 100644 mex/sources/libslicot/SB03OY.f create mode 100644 mex/sources/libslicot/SB03PD.f create mode 100644 mex/sources/libslicot/SB03QD.f create mode 100644 mex/sources/libslicot/SB03QX.f create mode 100644 mex/sources/libslicot/SB03QY.f create mode 100644 mex/sources/libslicot/SB03RD.f create mode 100644 mex/sources/libslicot/SB03SD.f create mode 100644 mex/sources/libslicot/SB03SX.f create mode 100644 mex/sources/libslicot/SB03SY.f create mode 100644 mex/sources/libslicot/SB03TD.f create mode 100644 mex/sources/libslicot/SB03UD.f create mode 100644 mex/sources/libslicot/SB04MD.f create mode 100644 mex/sources/libslicot/SB04MR.f create mode 100644 mex/sources/libslicot/SB04MU.f create mode 100644 mex/sources/libslicot/SB04MW.f create mode 100644 mex/sources/libslicot/SB04MY.f create mode 100644 mex/sources/libslicot/SB04ND.f create mode 100644 mex/sources/libslicot/SB04NV.f create mode 100644 mex/sources/libslicot/SB04NW.f create mode 100644 mex/sources/libslicot/SB04NX.f create mode 100644 mex/sources/libslicot/SB04NY.f create mode 100644 mex/sources/libslicot/SB04OD.f create mode 100644 mex/sources/libslicot/SB04OW.f create mode 100644 mex/sources/libslicot/SB04PD.f create mode 100644 mex/sources/libslicot/SB04PX.f create mode 100644 mex/sources/libslicot/SB04PY.f create mode 100644 mex/sources/libslicot/SB04QD.f create mode 100644 mex/sources/libslicot/SB04QR.f create mode 100644 mex/sources/libslicot/SB04QU.f create mode 100644 mex/sources/libslicot/SB04QY.f create mode 100644 mex/sources/libslicot/SB04RD.f create mode 100644 mex/sources/libslicot/SB04RV.f create mode 100644 mex/sources/libslicot/SB04RW.f create mode 100644 mex/sources/libslicot/SB04RX.f create mode 100644 mex/sources/libslicot/SB04RY.f create mode 100644 mex/sources/libslicot/SB06ND.f create mode 100644 mex/sources/libslicot/SB08CD.f create mode 100644 mex/sources/libslicot/SB08DD.f create mode 100644 mex/sources/libslicot/SB08ED.f create mode 100644 mex/sources/libslicot/SB08FD.f create mode 100644 mex/sources/libslicot/SB08GD.f create mode 100644 mex/sources/libslicot/SB08HD.f create mode 100644 mex/sources/libslicot/SB08MD.f create mode 100644 mex/sources/libslicot/SB08MY.f create mode 100644 mex/sources/libslicot/SB08ND.f create mode 100644 mex/sources/libslicot/SB08NY.f create mode 100644 mex/sources/libslicot/SB09MD.f create mode 100644 mex/sources/libslicot/SB10AD.f create mode 100644 mex/sources/libslicot/SB10DD.f create mode 100644 mex/sources/libslicot/SB10ED.f create mode 100644 mex/sources/libslicot/SB10FD.f create mode 100644 mex/sources/libslicot/SB10HD.f create mode 100644 mex/sources/libslicot/SB10ID.f create mode 100644 mex/sources/libslicot/SB10JD.f create mode 100644 mex/sources/libslicot/SB10KD.f create mode 100644 mex/sources/libslicot/SB10LD.f create mode 100644 mex/sources/libslicot/SB10MD.f create mode 100644 mex/sources/libslicot/SB10PD.f create mode 100644 mex/sources/libslicot/SB10QD.f create mode 100644 mex/sources/libslicot/SB10RD.f create mode 100644 mex/sources/libslicot/SB10SD.f create mode 100644 mex/sources/libslicot/SB10TD.f create mode 100644 mex/sources/libslicot/SB10UD.f create mode 100644 mex/sources/libslicot/SB10VD.f create mode 100644 mex/sources/libslicot/SB10WD.f create mode 100644 mex/sources/libslicot/SB10YD.f create mode 100644 mex/sources/libslicot/SB10ZD.f create mode 100644 mex/sources/libslicot/SB10ZP.f create mode 100644 mex/sources/libslicot/SB16AD.f create mode 100644 mex/sources/libslicot/SB16AY.f create mode 100644 mex/sources/libslicot/SB16BD.f create mode 100644 mex/sources/libslicot/SB16CD.f create mode 100644 mex/sources/libslicot/SB16CY.f create mode 100644 mex/sources/libslicot/SG02AD.f create mode 100644 mex/sources/libslicot/SG03AD.f create mode 100644 mex/sources/libslicot/SG03AX.f create mode 100644 mex/sources/libslicot/SG03AY.f create mode 100644 mex/sources/libslicot/SG03BD.f create mode 100644 mex/sources/libslicot/SG03BU.f create mode 100644 mex/sources/libslicot/SG03BV.f create mode 100644 mex/sources/libslicot/SG03BW.f create mode 100644 mex/sources/libslicot/SG03BX.f create mode 100644 mex/sources/libslicot/SG03BY.f create mode 100644 mex/sources/libslicot/TB01ID.f create mode 100644 mex/sources/libslicot/TB01IZ.f create mode 100644 mex/sources/libslicot/TB01KD.f create mode 100644 mex/sources/libslicot/TB01LD.f create mode 100644 mex/sources/libslicot/TB01MD.f create mode 100644 mex/sources/libslicot/TB01ND.f create mode 100644 mex/sources/libslicot/TB01PD.f create mode 100644 mex/sources/libslicot/TB01TD.f create mode 100644 mex/sources/libslicot/TB01TY.f create mode 100644 mex/sources/libslicot/TB01UD.f create mode 100644 mex/sources/libslicot/TB01VD.f create mode 100644 mex/sources/libslicot/TB01VY.f create mode 100644 mex/sources/libslicot/TB01WD.f create mode 100644 mex/sources/libslicot/TB01XD.f create mode 100644 mex/sources/libslicot/TB01XZ.f create mode 100644 mex/sources/libslicot/TB01YD.f create mode 100644 mex/sources/libslicot/TB01ZD.f create mode 100644 mex/sources/libslicot/TB03AD.f create mode 100644 mex/sources/libslicot/TB03AY.f create mode 100644 mex/sources/libslicot/TB04AD.f create mode 100644 mex/sources/libslicot/TB04AY.f create mode 100644 mex/sources/libslicot/TB04BD.f create mode 100644 mex/sources/libslicot/TB04BV.f create mode 100644 mex/sources/libslicot/TB04BW.f create mode 100644 mex/sources/libslicot/TB04BX.f create mode 100644 mex/sources/libslicot/TB04CD.f create mode 100644 mex/sources/libslicot/TB05AD.f create mode 100644 mex/sources/libslicot/TC01OD.f create mode 100644 mex/sources/libslicot/TC04AD.f create mode 100644 mex/sources/libslicot/TC05AD.f create mode 100644 mex/sources/libslicot/TD03AD.f create mode 100644 mex/sources/libslicot/TD03AY.f create mode 100644 mex/sources/libslicot/TD04AD.f create mode 100644 mex/sources/libslicot/TD05AD.f create mode 100644 mex/sources/libslicot/TF01MD.f create mode 100644 mex/sources/libslicot/TF01MX.f create mode 100644 mex/sources/libslicot/TF01MY.f create mode 100644 mex/sources/libslicot/TF01ND.f create mode 100644 mex/sources/libslicot/TF01OD.f create mode 100644 mex/sources/libslicot/TF01PD.f create mode 100644 mex/sources/libslicot/TF01QD.f create mode 100644 mex/sources/libslicot/TF01RD.f create mode 100644 mex/sources/libslicot/TG01AD.f create mode 100644 mex/sources/libslicot/TG01AZ.f create mode 100644 mex/sources/libslicot/TG01BD.f create mode 100644 mex/sources/libslicot/TG01CD.f create mode 100644 mex/sources/libslicot/TG01DD.f create mode 100644 mex/sources/libslicot/TG01ED.f create mode 100644 mex/sources/libslicot/TG01FD.f create mode 100644 mex/sources/libslicot/TG01FZ.f create mode 100644 mex/sources/libslicot/TG01HD.f create mode 100644 mex/sources/libslicot/TG01HX.f create mode 100644 mex/sources/libslicot/TG01ID.f create mode 100644 mex/sources/libslicot/TG01JD.f create mode 100644 mex/sources/libslicot/TG01WD.f create mode 100644 mex/sources/libslicot/UD01BD.f create mode 100644 mex/sources/libslicot/UD01CD.f create mode 100644 mex/sources/libslicot/UD01DD.f create mode 100644 mex/sources/libslicot/UD01MD.f create mode 100644 mex/sources/libslicot/UD01MZ.f create mode 100644 mex/sources/libslicot/UD01ND.f create mode 100644 mex/sources/libslicot/UE01MD.f create mode 100644 mex/sources/libslicot/dcabs1.f create mode 100644 mex/sources/libslicot/delctg.f create mode 100644 mex/sources/libslicot/dhgeqz.f create mode 100644 mex/sources/libslicot/dtgsy2.f create mode 100644 mex/sources/libslicot/readme create mode 100644 mex/sources/libslicot/select.f diff --git a/m4/ax_mexopts.m4 b/m4/ax_mexopts.m4 index c0fbd1145..e6ccd40c5 100644 --- a/m4/ax_mexopts.m4 +++ b/m4/ax_mexopts.m4 @@ -33,6 +33,7 @@ case ${MATLAB_ARCH} in MATLAB_DEFS="$MATLAB_DEFS -D_GNU_SOURCE -DNDEBUG" MATLAB_CFLAGS="-ansi -fexceptions -fPIC -pthread -g -O2" MATLAB_CXXFLAGS="-ansi -fPIC -pthread -g -O2" + MATLAB_FFLAGS="-fPIC -g -O2 -fexceptions" MATLAB_LDFLAGS="-shared -Wl,--version-script,$MATLAB/extern/lib/${MATLAB_ARCH}/mexFunction.map -Wl,--no-undefined -Wl,-rpath-link,$MATLAB/bin/${MATLAB_ARCH} -L$MATLAB/bin/${MATLAB_ARCH}" MATLAB_LIBS="-lmx -lmex -lmat -lm -lstdc++ -lmwlapack" # Starting from MATLAB 7.5, BLAS and LAPACK are in distinct libraries @@ -50,6 +51,7 @@ case ${MATLAB_ARCH} in win32 | win64) MATLAB_CFLAGS="-fexceptions -g -O2" MATLAB_CXXFLAGS="-g -O2" + MATLAB_FFLAGS="-fexceptions -g -O2" AX_COMPARE_VERSION([$MATLAB_VERSION], [eq], [7.0.1], [AC_MSG_ERROR([MATLAB version 7.0.1 (R14SP1) is buggy (LAPACK library missing for MSVC), and can't be used for compiling MEX files])]) MATLAB_DEFS="$MATLAB_DEFS -DNDEBUG" # Note that static-libstdc++ is only supported since GCC 4.5 (but generates no error on older versions) @@ -72,6 +74,7 @@ case ${MATLAB_ARCH} in MATLAB_LDFLAGS="-L$MATLAB/bin/${MATLAB_ARCH} -Wl,-twolevel_namespace -undefined error -arch $ARCHS -Wl,-syslibroot,$SDKROOT -mmacosx-version-min=$MACOSX_DEPLOYMENT_TARGET -bundle -Wl,-exported_symbols_list,\$(top_srcdir)/mexFunction-MacOSX.map" MATLAB_LIBS="-lmx -lmex -lmat -lstdc++ -lmwlapack" MATLAB_CXXFLAGS="-fno-common -no-cpp-precomp -fexceptions -arch $ARCHS -isysroot $SDKROOT -mmacosx-version-min=$MACOSX_DEPLOYMENT_TARGET -O2" + MATLAB_CXXFLAGS="-fexceptions -fbackslash -g -O2" # Starting from MATLAB 7.5, BLAS and LAPACK are in distinct libraries AX_COMPARE_VERSION([$MATLAB_VERSION], [ge], [7.5], [MATLAB_LIBS="${MATLAB_LIBS} -lmwblas"]) ax_mexopts_ok="yes" diff --git a/mex/build/libslicot.am b/mex/build/libslicot.am new file mode 100644 index 000000000..295d931dd --- /dev/null +++ b/mex/build/libslicot.am @@ -0,0 +1,484 @@ +vpath %.f $(top_srcdir)/../../sources/libslicot + +noinst_LIBRARIES = libslicot.a libauxslicot.a + +SLICOT_SRC = \ + AB01MD.f \ + AB01ND.f \ + AB01OD.f \ + AB04MD.f \ + AB05MD.f \ + AB05ND.f \ + AB05OD.f \ + AB05PD.f \ + AB05QD.f \ + AB05RD.f \ + AB05SD.f \ + AB07MD.f \ + AB07ND.f \ + AB08MD.f \ + AB08MZ.f \ + AB08ND.f \ + AB08NX.f \ + AB08NZ.f \ + AB09AD.f \ + AB09AX.f \ + AB09BD.f \ + AB09BX.f \ + AB09CD.f \ + AB09CX.f \ + AB09DD.f \ + AB09ED.f \ + AB09FD.f \ + AB09GD.f \ + AB09HD.f \ + AB09HX.f \ + AB09HY.f \ + AB09ID.f \ + AB09IX.f \ + AB09IY.f \ + AB09JD.f \ + AB09JV.f \ + AB09JW.f \ + AB09JX.f \ + AB09KD.f \ + AB09KX.f \ + AB09MD.f \ + AB09ND.f \ + AB13AD.f \ + AB13AX.f \ + AB13BD.f \ + AB13CD.f \ + AB13DD.f \ + AB13DX.f \ + AB13ED.f \ + AB13FD.f \ + AB13MD.f \ + AB8NXZ.f \ + AG07BD.f \ + AG08BD.f \ + AG08BY.f \ + AG08BZ.f \ + AG8BYZ.f \ + BB01AD.f \ + BB02AD.f \ + BB03AD.f \ + BB04AD.f \ + BD01AD.f \ + BD02AD.f \ + DE01OD.f \ + DE01PD.f \ + delctg.f \ + DF01MD.f \ + DG01MD.f \ + DG01ND.f \ + DG01NY.f \ + DG01OD.f \ + DK01MD.f \ + FB01QD.f \ + FB01RD.f \ + FB01SD.f \ + FB01TD.f \ + FB01VD.f \ + FD01AD.f \ + IB01AD.f \ + IB01BD.f \ + IB01CD.f \ + IB01MD.f \ + IB01MY.f \ + IB01ND.f \ + IB01OD.f \ + IB01OY.f \ + IB01PD.f \ + IB01PX.f \ + IB01PY.f \ + IB01QD.f \ + IB01RD.f \ + IB03AD.f \ + IB03BD.f \ + MA01AD.f \ + MA02AD.f \ + MA02BD.f \ + MA02BZ.f \ + MA02CD.f \ + MA02CZ.f \ + MA02DD.f \ + MA02ED.f \ + MA02FD.f \ + MA02GD.f \ + MA02HD.f \ + MA02ID.f \ + MA02JD.f \ + MB01MD.f \ + MB01ND.f \ + MB01PD.f \ + MB01QD.f \ + MB01RD.f \ + MB01RU.f \ + MB01RW.f \ + MB01RX.f \ + MB01RY.f \ + MB01SD.f \ + MB01TD.f \ + MB01UD.f \ + MB01UW.f \ + MB01UX.f \ + MB01VD.f \ + MB01WD.f \ + MB01XD.f \ + MB01XY.f \ + MB01YD.f \ + MB01ZD.f \ + MB02CD.f \ + MB02CU.f \ + MB02CV.f \ + MB02CX.f \ + MB02CY.f \ + MB02DD.f \ + MB02ED.f \ + MB02FD.f \ + MB02GD.f \ + MB02HD.f \ + MB02ID.f \ + MB02JD.f \ + MB02JX.f \ + MB02KD.f \ + MB02MD.f \ + MB02ND.f \ + MB02NY.f \ + MB02OD.f \ + MB02PD.f \ + MB02QD.f \ + MB02QY.f \ + MB02RD.f \ + MB02RZ.f \ + MB02SD.f \ + MB02SZ.f \ + MB02TD.f \ + MB02TZ.f \ + MB02UD.f \ + MB02UU.f \ + MB02UV.f \ + MB02VD.f \ + MB02WD.f \ + MB02XD.f \ + MB02YD.f \ + MB03MD.f \ + MB03MY.f \ + MB03ND.f \ + MB03NY.f \ + MB03OD.f \ + MB03OY.f \ + MB03PD.f \ + MB03PY.f \ + MB03QD.f \ + MB03QX.f \ + MB03QY.f \ + MB03RD.f \ + MB03RX.f \ + MB03RY.f \ + MB03SD.f \ + MB03TD.f \ + MB03TS.f \ + MB03UD.f \ + MB03VD.f \ + MB03VY.f \ + MB03WA.f \ + MB03WD.f \ + MB03WX.f \ + MB03XD.f \ + MB03XP.f \ + MB03XU.f \ + MB03YA.f \ + MB03YD.f \ + MB03YT.f \ + MB03ZA.f \ + MB03ZD.f \ + MB04DD.f \ + MB04DI.f \ + MB04DS.f \ + MB04DY.f \ + MB04GD.f \ + MB04ID.f \ + MB04IY.f \ + MB04IZ.f \ + MB04JD.f \ + MB04KD.f \ + MB04LD.f \ + MB04MD.f \ + MB04ND.f \ + MB04NY.f \ + MB04OD.f \ + MB04OW.f \ + MB04OX.f \ + MB04OY.f \ + MB04PA.f \ + MB04PB.f \ + MB04PU.f \ + MB04PY.f \ + MB04QB.f \ + MB04QC.f \ + MB04QF.f \ + MB04QU.f \ + MB04TB.f \ + MB04TS.f \ + MB04TT.f \ + MB04TU.f \ + MB04TV.f \ + MB04TW.f \ + MB04TX.f \ + MB04TY.f \ + MB04UD.f \ + MB04VD.f \ + MB04VX.f \ + MB04WD.f \ + MB04WP.f \ + MB04WR.f \ + MB04WU.f \ + MB04XD.f \ + MB04XY.f \ + MB04YD.f \ + MB04YW.f \ + MB04ZD.f \ + MB05MD.f \ + MB05MY.f \ + MB05ND.f \ + MB05OD.f \ + MB05OY.f \ + MB3OYZ.f \ + MB3PYZ.f \ + MC01MD.f \ + MC01ND.f \ + MC01OD.f \ + MC01PD.f \ + MC01PY.f \ + MC01QD.f \ + MC01RD.f \ + MC01SD.f \ + MC01SW.f \ + MC01SX.f \ + MC01SY.f \ + MC01TD.f \ + MC01VD.f \ + MC01WD.f \ + MC03MD.f \ + MC03ND.f \ + MC03NX.f \ + MC03NY.f \ + MD03AD.f \ + MD03BA.f \ + MD03BB.f \ + MD03BD.f \ + MD03BF.f \ + MD03BX.f \ + MD03BY.f \ + NF01AD.f \ + NF01AY.f \ + NF01BA.f \ + NF01BB.f \ + NF01BD.f \ + NF01BE.f \ + NF01BF.f \ + NF01BP.f \ + NF01BQ.f \ + NF01BR.f \ + NF01BS.f \ + NF01BU.f \ + NF01BV.f \ + NF01BW.f \ + NF01BX.f \ + NF01BY.f \ + SB01BD.f \ + SB01BX.f \ + SB01BY.f \ + SB01DD.f \ + SB01FY.f \ + SB01MD.f \ + SB02CX.f \ + SB02MD.f \ + SB02MR.f \ + SB02MS.f \ + SB02MT.f \ + SB02MU.f \ + SB02MV.f \ + SB02MW.f \ + SB02ND.f \ + SB02OD.f \ + SB02OU.f \ + SB02OV.f \ + SB02OW.f \ + SB02OX.f \ + SB02OY.f \ + SB02PD.f \ + SB02QD.f \ + SB02RD.f \ + SB02RU.f \ + SB02SD.f \ + SB03MD.f \ + SB03MU.f \ + SB03MV.f \ + SB03MW.f \ + SB03MX.f \ + SB03MY.f \ + SB03OD.f \ + SB03OR.f \ + SB03OT.f \ + SB03OU.f \ + SB03OV.f \ + SB03OY.f \ + SB03PD.f \ + SB03QD.f \ + SB03QX.f \ + SB03QY.f \ + SB03RD.f \ + SB03SD.f \ + SB03SX.f \ + SB03SY.f \ + SB03TD.f \ + SB03UD.f \ + SB04MD.f \ + SB04MR.f \ + SB04MU.f \ + SB04MW.f \ + SB04MY.f \ + SB04ND.f \ + SB04NV.f \ + SB04NW.f \ + SB04NX.f \ + SB04NY.f \ + SB04OD.f \ + SB04OW.f \ + SB04PD.f \ + SB04PX.f \ + SB04PY.f \ + SB04QD.f \ + SB04QR.f \ + SB04QU.f \ + SB04QY.f \ + SB04RD.f \ + SB04RV.f \ + SB04RW.f \ + SB04RX.f \ + SB04RY.f \ + SB06ND.f \ + SB08CD.f \ + SB08DD.f \ + SB08ED.f \ + SB08FD.f \ + SB08GD.f \ + SB08HD.f \ + SB08MD.f \ + SB08MY.f \ + SB08ND.f \ + SB08NY.f \ + SB09MD.f \ + SB10AD.f \ + SB10DD.f \ + SB10ED.f \ + SB10FD.f \ + SB10HD.f \ + SB10ID.f \ + SB10JD.f \ + SB10KD.f \ + SB10LD.f \ + SB10MD.f \ + SB10PD.f \ + SB10QD.f \ + SB10RD.f \ + SB10SD.f \ + SB10TD.f \ + SB10UD.f \ + SB10VD.f \ + SB10WD.f \ + SB10YD.f \ + SB10ZD.f \ + SB10ZP.f \ + SB16AD.f \ + SB16AY.f \ + SB16BD.f \ + SB16CD.f \ + SB16CY.f \ + select.f \ + SG02AD.f \ + SG03AD.f \ + SG03AX.f \ + SG03AY.f \ + SG03BD.f \ + SG03BU.f \ + SG03BV.f \ + SG03BW.f \ + SG03BX.f \ + SG03BY.f \ + TB01ID.f \ + TB01IZ.f \ + TB01KD.f \ + TB01LD.f \ + TB01MD.f \ + TB01ND.f \ + TB01PD.f \ + TB01TD.f \ + TB01TY.f \ + TB01UD.f \ + TB01VD.f \ + TB01VY.f \ + TB01WD.f \ + TB01XD.f \ + TB01XZ.f \ + TB01YD.f \ + TB01ZD.f \ + TB03AD.f \ + TB03AY.f \ + TB04AD.f \ + TB04AY.f \ + TB04BD.f \ + TB04BV.f \ + TB04BW.f \ + TB04BX.f \ + TB04CD.f \ + TB05AD.f \ + TC01OD.f \ + TC04AD.f \ + TC05AD.f \ + TD03AD.f \ + TD03AY.f \ + TD04AD.f \ + TD05AD.f \ + TF01MD.f \ + TF01MX.f \ + TF01MY.f \ + TF01ND.f \ + TF01OD.f \ + TF01PD.f \ + TF01QD.f \ + TF01RD.f \ + TG01AD.f \ + TG01AZ.f \ + TG01BD.f \ + TG01CD.f \ + TG01DD.f \ + TG01ED.f \ + TG01FD.f \ + TG01FZ.f \ + TG01HD.f \ + TG01HX.f \ + TG01ID.f \ + TG01JD.f \ + TG01WD.f \ + UD01BD.f \ + UD01CD.f \ + UD01DD.f \ + UD01MD.f \ + UD01MZ.f \ + UD01ND.f \ + UE01MD.f + +SLICOT_AUX = \ + dcabs1.f \ + dhgeqz.f \ + dtgsy2.f + +nodist_libslicot_a_SOURCES = \ + $(SLICOT_SRC) + +nodist_libauxslicot_a_SOURCES = \ + $(SLICOT_AUX) \ No newline at end of file diff --git a/mex/build/matlab/Makefile.am b/mex/build/matlab/Makefile.am index 3a4bd041f..f63264b81 100644 --- a/mex/build/matlab/Makefile.am +++ b/mex/build/matlab/Makefile.am @@ -2,7 +2,7 @@ ACLOCAL_AMFLAGS = -I ../../../m4 # libdynare++ must come before gensylv, k_order_perturbation, dynare_simul_ if DO_SOMETHING -SUBDIRS = mjdgges kronecker bytecode libdynare++ gensylv k_order_perturbation dynare_simul_ logposterior logMHMCMCposterior +SUBDIRS = mjdgges kronecker bytecode libdynare++ gensylv k_order_perturbation dynare_simul_ logposterior logMHMCMCposterior libslicot if HAVE_GSL SUBDIRS += swz endif diff --git a/mex/build/matlab/configure.ac b/mex/build/matlab/configure.ac index 2008a8d08..ad3795b77 100644 --- a/mex/build/matlab/configure.ac +++ b/mex/build/matlab/configure.ac @@ -38,6 +38,7 @@ if test "x$ax_enable_matlab" = "xyes"; then CFLAGS="$MATLAB_CFLAGS" CXXFLAGS="$MATLAB_CXXFLAGS" + FFLAGS="$MATLAB_FFLAGS" fi case ${host_os} in @@ -49,8 +50,10 @@ case ${host_os} in esac CFLAGS="$CFLAGS -Wall" +FFLAGS="$FFLAGS -Wall" CXXFLAGS="$CXXFLAGS -Wall" +AC_PROG_F77 AC_PROG_CC AC_PROG_CXX AC_PROG_RANLIB @@ -130,6 +133,7 @@ AC_CONFIG_FILES([Makefile dynare_simul_/Makefile swz/Makefile logposterior/Makefile - logMHMCMCposterior/Makefile]) + logMHMCMCposterior/Makefile + libslicot/Makefile]) AC_OUTPUT diff --git a/mex/build/matlab/libslicot/Makefile.am b/mex/build/matlab/libslicot/Makefile.am new file mode 100644 index 000000000..680519fea --- /dev/null +++ b/mex/build/matlab/libslicot/Makefile.am @@ -0,0 +1,2 @@ +include ../mex.am +include ../../libslicot.am diff --git a/mex/build/octave/Makefile.am b/mex/build/octave/Makefile.am index ebbc7e7c9..09a31661b 100644 --- a/mex/build/octave/Makefile.am +++ b/mex/build/octave/Makefile.am @@ -2,7 +2,7 @@ ACLOCAL_AMFLAGS = -I ../../../m4 # libdynare++ must come before gensylv, k_order_perturbation, dynare_simul_ if DO_SOMETHING -SUBDIRS = mjdgges kronecker bytecode libdynare++ gensylv k_order_perturbation dynare_simul_ logposterior logMHMCMCposterior qzcomplex ordschur +SUBDIRS = mjdgges kronecker bytecode libdynare++ gensylv k_order_perturbation dynare_simul_ logposterior logMHMCMCposterior qzcomplex ordschur libslicot if HAVE_GSL SUBDIRS += swz endif diff --git a/mex/build/octave/configure.ac b/mex/build/octave/configure.ac index 3b3177740..d41de1e3f 100644 --- a/mex/build/octave/configure.ac +++ b/mex/build/octave/configure.ac @@ -28,12 +28,15 @@ if test "x$MKOCTFILE" != "x"; then CC=`$MKOCTFILE -p CC` CXX=`$MKOCTFILE -p CXX` CFLAGS=`$MKOCTFILE -p CFLAGS` + FFLAGS=`$MKOCTFILE -p FFLAGS` CXXFLAGS=`$MKOCTFILE -p CXXFLAGS` fi CFLAGS="$CFLAGS -Wall" +FFLAGS="$FFLAGS -Wall" CXXFLAGS="$CXXFLAGS -Wall" +AC_PROG_F77 AC_PROG_CC AC_PROG_CXX AC_PROG_RANLIB @@ -104,6 +107,7 @@ AC_CONFIG_FILES([Makefile logposterior/Makefile logMHMCMCposterior/Makefile qzcomplex/Makefile - ordschur/Makefile]) + ordschur/Makefile + libslicot/Makefile]) AC_OUTPUT diff --git a/mex/build/octave/libslicot/Makefile.am b/mex/build/octave/libslicot/Makefile.am new file mode 100644 index 000000000..47b05ecff --- /dev/null +++ b/mex/build/octave/libslicot/Makefile.am @@ -0,0 +1,3 @@ +EXEEXT = .mex +include ../mex.am +include ../../libslicot.am diff --git a/mex/sources/libslicot/AB01MD.f b/mex/sources/libslicot/AB01MD.f new file mode 100644 index 000000000..d00d02a82 --- /dev/null +++ b/mex/sources/libslicot/AB01MD.f @@ -0,0 +1,402 @@ + SUBROUTINE AB01MD( JOBZ, N, A, LDA, B, NCONT, Z, LDZ, TAU, TOL, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a controllable realization for the linear time-invariant +C single-input system +C +C dX/dt = A * X + B * U, +C +C where A is an N-by-N matrix and B is an N element vector which +C are reduced by this routine to orthogonal canonical form using +C (and optionally accumulating) orthogonal similarity +C transformations. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBZ CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal similarity transformations for +C reducing the system, as follows: +C = 'N': Do not form Z and do not store the orthogonal +C transformations; +C = 'F': Do not form Z, but store the orthogonal +C transformations in the factored form; +C = 'I': Z is initialized to the unit matrix and the +C orthogonal transformation matrix Z is returned. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e. the order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading NCONT-by-NCONT upper Hessenberg +C part of this array contains the canonical form of the +C state dynamics matrix, given by Z' * A * Z, of a +C controllable realization for the original system. The +C elements below the first subdiagonal are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, the original input/state vector B. +C On exit, the leading NCONT elements of this array contain +C canonical form of the input/state vector, given by Z' * B, +C with all elements but B(1) set to zero. +C +C NCONT (output) INTEGER +C The order of the controllable state-space representation. +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C If JOBZ = 'I', then the leading N-by-N part of this array +C contains the matrix of accumulated orthogonal similarity +C transformations which reduces the given system to +C orthogonal canonical form. +C If JOBZ = 'F', the elements below the diagonal, with the +C array TAU, represent the orthogonal transformation matrix +C as a product of elementary reflectors. The transformation +C matrix can then be obtained by calling the LAPACK Library +C routine DORGQR. +C If JOBZ = 'N', the array Z is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDZ = 1 and +C declare this array to be Z(1,1) in the calling program). +C +C LDZ INTEGER +C The leading dimension of array Z. If JOBZ = 'I' or +C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The elements of TAU contain the scalar factors of the +C elementary reflectors used in the reduction of B and A. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the +C controllability of (A,B). If the user sets TOL > 0, then +C the given value of TOL is used as an absolute tolerance; +C elements with absolute value less than TOL are considered +C neglijible. If the user sets TOL <= 0, then an implicitly +C computed, default tolerance, defined by +C TOLDEF = N*EPS*MAX( NORM(A), NORM(B) ) is used instead, +C where EPS is the machine precision (see LAPACK Library +C routine DLAMCH). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The Householder matrix which reduces all but the first element +C of vector B to zero is found and this orthogonal similarity +C transformation is applied to the matrix A. The resulting A is then +C reduced to upper Hessenberg form by a sequence of Householder +C transformations. Finally, the order of the controllable state- +C space representation (NCONT) is determined by finding the position +C of the first sub-diagonal element of A which is below an +C appropriate zero threshold, either TOL or TOLDEF (see parameter +C TOL); if NORM(B) is smaller than this threshold, NCONT is set to +C zero, and no computations for reducing the system to orthogonal +C canonical form are performed. +C +C REFERENCES +C +C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. +C Orthogonal Invariants and Canonical Forms for Linear +C Controllable Systems. +C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. +C +C [2] Hammarling, S.J. +C Notes on the use of orthogonal similarity transformations in +C control. +C NPL Report DITC 8/82, August 1982. +C +C [3] Paige, C.C +C Properties of numerical algorithms related to computing +C controllability. +C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1996. +C Supersedes Release 2.0 routine AB01AD by T.W.C. Williams, +C Kingston Polytechnic, United Kingdom, October 1982. +C +C REVISIONS +C +C V. Sima, February 16, 1998, October 19, 2001, February 2, 2005. +C +C KEYWORDS +C +C Controllability, minimal realization, orthogonal canonical form, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBZ + INTEGER INFO, LDA, LDZ, LDWORK, N, NCONT + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(*), DWORK(*), TAU(*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL LJOBF, LJOBI, LJOBZ + INTEGER ITAU, J + DOUBLE PRECISION ANORM, B1, BNORM, FANORM, FBNORM, H, THRESH, + $ TOLDEF, WRKOPT +C .. Local Arrays .. + DOUBLE PRECISION NBLK(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DGEHRD, DLACPY, DLARF, DLARFG, DLASET, DORGQR, + $ MB01PD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX +C .. Executable Statements .. +C + INFO = 0 + LJOBF = LSAME( JOBZ, 'F' ) + LJOBI = LSAME( JOBZ, 'I' ) + LJOBZ = LJOBF.OR.LJOBI +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX(1,N) ) THEN + INFO = -4 + ELSE IF( .NOT.LJOBZ .AND. LDZ.LT.1 .OR. + $ LJOBZ .AND. LDZ.LT.MAX(1,N) ) THEN + INFO = -8 + ELSE IF( LDWORK.LT.MAX( 1, N ) ) THEN + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB01MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + NCONT = 0 + DWORK(1) = ONE + IF ( N.EQ.0 ) + $ RETURN +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + WRKOPT = ONE +C +C Calculate the absolute norms of A and B (used for scaling). +C + ANORM = DLANGE( 'M', N, N, A, LDA, DWORK ) + BNORM = DLANGE( 'M', N, 1, B, N, DWORK ) +C +C Return if matrix B is zero. +C + IF( BNORM.EQ.ZERO ) THEN + IF( LJOBF ) THEN + CALL DLASET( 'F', N, N, ZERO, ZERO, Z, LDZ ) + CALL DLASET( 'F', N, 1, ZERO, ZERO, TAU, N ) + ELSE IF( LJOBI ) THEN + CALL DLASET( 'F', N, N, ZERO, ONE, Z, LDZ ) + END IF + RETURN + END IF +C +C Scale (if needed) the matrices A and B. +C + CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO ) + CALL MB01PD( 'S', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) +C +C Calculate the Frobenius norm of A and the 1-norm of B (used for +C controlability test). +C + FANORM = DLANGE( 'F', N, N, A, LDA, DWORK ) + FBNORM = DLANGE( '1', N, 1, B, N, DWORK ) +C + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance in controllability determination. +C + THRESH = DBLE(N)*DLAMCH( 'EPSILON' ) + TOLDEF = THRESH*MAX( FANORM, FBNORM ) + END IF +C + ITAU = 1 + IF ( FBNORM.GT.TOLDEF ) THEN +C +C B is not negligible compared with A. +C + IF ( N.GT.1 ) THEN +C +C Transform B by a Householder matrix Z1: store vector +C describing this temporarily in B and in the local scalar H. +C + CALL DLARFG( N, B(1), B(2), 1, H ) +C + B1 = B(1) + B(1) = ONE +C +C Form Z1 * A * Z1. +C + CALL DLARF( 'R', N, N, B, 1, H, A, LDA, DWORK ) + CALL DLARF( 'L', N, N, B, 1, H, A, LDA, DWORK ) +C + B(1) = B1 + TAU(1) = H + ITAU = ITAU + 1 + ELSE + B1 = B(1) + END IF +C +C Reduce modified A to upper Hessenberg form by an orthogonal +C similarity transformation with matrix Z2. +C Workspace: need N; prefer N*NB. +C + CALL DGEHRD( N, 1, N, A, LDA, TAU(ITAU), DWORK, LDWORK, INFO ) + WRKOPT = DWORK(1) +C + IF ( LJOBZ ) THEN +C +C Save the orthogonal transformations used, so that they could +C be accumulated by calling DORGQR routine. +C + IF ( N.GT.1 ) + $ CALL DLACPY( 'F', N-1, 1, B(2), N-1, Z(2,1), LDZ ) + IF ( N.GT.2 ) + $ CALL DLACPY( 'L', N-2, N-2, A(3,1), LDA, Z(3,2), LDZ ) + IF ( LJOBI ) THEN +C +C Form the orthogonal transformation matrix Z = Z1 * Z2. +C Workspace: need N; prefer N*NB. +C + CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, DWORK(1) ) + END IF + END IF +C +C Annihilate the lower part of A and B. +C + IF ( N.GT.2 ) + $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) + IF ( N.GT.1 ) + $ CALL DLASET( 'F', N-1, 1, ZERO, ZERO, B(2), N-1 ) +C +C Find NCONT by checking sizes of the sub-diagonal elements of +C transformed A. +C + IF ( TOL.LE.ZERO ) TOLDEF = THRESH*MAX( FANORM, ABS( B1 ) ) +C + J = 1 +C +C WHILE ( J < N and ABS( A(J+1,J) ) > TOLDEF ) DO +C + 10 CONTINUE + IF ( J.LT.N ) THEN + IF ( ABS( A(J+1,J) ).GT.TOLDEF ) THEN + J = J + 1 + GO TO 10 + END IF + END IF +C +C END WHILE 10 +C +C First negligible sub-diagonal element found, if any: set NCONT. +C + NCONT = J + IF ( J.LT.N ) A(J+1,J) = ZERO +C +C Undo scaling of A and B. +C + CALL MB01PD( 'U', 'H', NCONT, NCONT, 0, 0, ANORM, 0, NBLK, A, + $ LDA, INFO ) + CALL MB01PD( 'U', 'G', 1, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) + IF ( NCONT.LT.N ) + $ CALL MB01PD( 'U', 'G', N, N-NCONT, 0, 0, ANORM, 0, NBLK, + $ A(1,NCONT+1), LDA, INFO ) + ELSE +C +C B is negligible compared with A. No computations for reducing +C the system to orthogonal canonical form have been performed, +C except scaling (which is undoed). +C + IF( LJOBF ) THEN + CALL DLASET( 'F', N, N, ZERO, ZERO, Z, LDZ ) + CALL DLASET( 'F', N, 1, ZERO, ZERO, TAU, N ) + ELSE IF( LJOBI ) THEN + CALL DLASET( 'F', N, N, ZERO, ONE, Z, LDZ ) + END IF + CALL MB01PD( 'U', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, + $ INFO ) + CALL MB01PD( 'U', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) + END IF +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB01MD *** + END diff --git a/mex/sources/libslicot/AB01ND.f b/mex/sources/libslicot/AB01ND.f new file mode 100644 index 000000000..c6280fcbe --- /dev/null +++ b/mex/sources/libslicot/AB01ND.f @@ -0,0 +1,470 @@ + SUBROUTINE AB01ND( JOBZ, N, M, A, LDA, B, LDB, NCONT, INDCON, + $ NBLK, Z, LDZ, TAU, TOL, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a controllable realization for the linear time-invariant +C multi-input system +C +C dX/dt = A * X + B * U, +C +C where A and B are N-by-N and N-by-M matrices, respectively, +C which are reduced by this routine to orthogonal canonical form +C using (and optionally accumulating) orthogonal similarity +C transformations. Specifically, the pair (A, B) is reduced to +C the pair (Ac, Bc), Ac = Z' * A * Z, Bc = Z' * B, given by +C +C [ Acont * ] [ Bcont ] +C Ac = [ ], Bc = [ ], +C [ 0 Auncont ] [ 0 ] +C +C and +C +C [ A11 A12 . . . A1,p-1 A1p ] [ B1 ] +C [ A21 A22 . . . A2,p-1 A2p ] [ 0 ] +C [ 0 A32 . . . A3,p-1 A3p ] [ 0 ] +C Acont = [ . . . . . . . ], Bc = [ . ], +C [ . . . . . . ] [ . ] +C [ . . . . . ] [ . ] +C [ 0 0 . . . Ap,p-1 App ] [ 0 ] +C +C where the blocks B1, A21, ..., Ap,p-1 have full row ranks and +C p is the controllability index of the pair. The size of the +C block Auncont is equal to the dimension of the uncontrollable +C subspace of the pair (A, B). +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBZ CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal similarity transformations for +C reducing the system, as follows: +C = 'N': Do not form Z and do not store the orthogonal +C transformations; +C = 'F': Do not form Z, but store the orthogonal +C transformations in the factored form; +C = 'I': Z is initialized to the unit matrix and the +C orthogonal transformation matrix Z is returned. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e. the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs, or of columns of B. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading NCONT-by-NCONT part contains the +C upper block Hessenberg state dynamics matrix Acont in Ac, +C given by Z' * A * Z, of a controllable realization for +C the original system. The elements below the first block- +C subdiagonal are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B. +C On exit, the leading NCONT-by-M part of this array +C contains the transformed input matrix Bcont in Bc, given +C by Z' * B, with all elements but the first block set to +C zero. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C NCONT (output) INTEGER +C The order of the controllable state-space representation. +C +C INDCON (output) INTEGER +C The controllability index of the controllable part of the +C system representation. +C +C NBLK (output) INTEGER array, dimension (N) +C The leading INDCON elements of this array contain the +C the orders of the diagonal blocks of Acont. +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C If JOBZ = 'I', then the leading N-by-N part of this +C array contains the matrix of accumulated orthogonal +C similarity transformations which reduces the given system +C to orthogonal canonical form. +C If JOBZ = 'F', the elements below the diagonal, with the +C array TAU, represent the orthogonal transformation matrix +C as a product of elementary reflectors. The transformation +C matrix can then be obtained by calling the LAPACK Library +C routine DORGQR. +C If JOBZ = 'N', the array Z is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDZ = 1 and +C declare this array to be Z(1,1) in the calling program). +C +C LDZ INTEGER +C The leading dimension of array Z. If JOBZ = 'I' or +C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The elements of TAU contain the scalar factors of the +C elementary reflectors used in the reduction of B and A. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determination when +C transforming (A, B). If the user sets TOL > 0, then +C the given value of TOL is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*N*EPS, is used instead, where EPS +C is the machine precision (see LAPACK Library routine +C DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N, 3*M). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Matrix B is first QR-decomposed and the appropriate orthogonal +C similarity transformation applied to the matrix A. Leaving the +C first rank(B) states unchanged, the remaining lower left block +C of A is then QR-decomposed and the new orthogonal matrix, Q1, +C is also applied to the right of A to complete the similarity +C transformation. By continuing in this manner, a completely +C controllable state-space pair (Acont, Bcont) is found for the +C given (A, B), where Acont is upper block Hessenberg with each +C subdiagonal block of full row rank, and Bcont is zero apart from +C its (independent) first rank(B) rows. +C NOTE that the system controllability indices are easily +C calculated from the dimensions of the blocks of Acont. +C +C REFERENCES +C +C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. +C Orthogonal Invariants and Canonical Forms for Linear +C Controllable Systems. +C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. +C +C [2] Paige, C.C. +C Properties of numerical algorithms related to computing +C controllablity. +C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. +C +C [3] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and +C Postlethwaite, I. +C Optimal Pole Assignment Design of Linear Multi-Input Systems. +C Leicester University, Report 99-11, May 1996. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C If the system matrices A and B are badly scaled, it would be +C useful to scale them with SLICOT routine TB01ID, before calling +C the routine. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C Supersedes Release 2.0 routine AB01BD by P.Hr. Petkov. +C +C REVISIONS +C +C January 14, 1997, June 4, 1997, February 13, 1998, +C September 22, 2003, February 29, 2004. +C +C KEYWORDS +C +C Controllability, minimal realization, orthogonal canonical form, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBZ + INTEGER INDCON, INFO, LDA, LDB, LDWORK, LDZ, M, N, NCONT + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*), Z(LDZ,*) + INTEGER IWORK(*), NBLK(*) +C .. Local Scalars .. + LOGICAL LJOBF, LJOBI, LJOBZ + INTEGER IQR, ITAU, J, MCRT, NBL, NCRT, NI, NJ, RANK, + $ WRKOPT + DOUBLE PRECISION ANORM, BNORM, FNRM, TOLDEF +C .. Local Arrays .. + DOUBLE PRECISION SVAL(3) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 + EXTERNAL DLAMCH, DLANGE, DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DLAPMT, DLASET, DORGQR, DORMQR, + $ MB01PD, MB03OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C + INFO = 0 + LJOBF = LSAME( JOBZ, 'F' ) + LJOBI = LSAME( JOBZ, 'I' ) + LJOBZ = LJOBF.OR.LJOBI +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDZ.LT.1 .OR. ( LJOBZ .AND. LDZ.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDWORK.LT.MAX( 1, N, 3*M ) ) THEN + INFO = -17 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB01ND', -INFO ) + RETURN + END IF +C + NCONT = 0 + INDCON = 0 +C +C Quick return if possible. +C + IF ( MIN( N, M ).EQ.0 ) THEN + IF( N.GT.0 ) THEN + IF ( LJOBI ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) + ELSE IF ( LJOBF ) THEN + CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) + END IF + END IF + DWORK(1) = ONE + RETURN + END IF +C +C Calculate the absolute norms of A and B (used for scaling). +C + ANORM = DLANGE( 'M', N, N, A, LDA, DWORK ) + BNORM = DLANGE( 'M', N, M, B, LDB, DWORK ) +C +C Return if matrix B is zero. +C + IF( BNORM.EQ.ZERO ) THEN + IF ( LJOBI ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) + ELSE IF ( LJOBF ) THEN + CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) + END IF + DWORK(1) = ONE + RETURN + END IF +C +C Scale (if needed) the matrices A and B. +C + CALL MB01PD( 'Scale', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, + $ INFO ) + CALL MB01PD( 'Scale', 'G', N, M, 0, 0, BNORM, 0, NBLK, B, LDB, + $ INFO ) +C +C Compute the Frobenius norm of [ B A ] (used for rank estimation). +C + FNRM = DLAPY2( DLANGE( 'F', N, M, B, LDB, DWORK ), + $ DLANGE( 'F', N, N, A, LDA, DWORK ) ) +C + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance in controllability determination. +C + TOLDEF = DBLE( N*N )*DLAMCH( 'EPSILON' ) + END IF +C + WRKOPT = 1 + NI = 0 + ITAU = 1 + NCRT = N + MCRT = M + IQR = 1 +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + 10 CONTINUE +C +C Rank-revealing QR decomposition with column pivoting. +C The calculation is performed in NCRT rows of B starting from +C the row IQR (initialized to 1 and then set to rank(B)+1). +C Workspace: 3*MCRT. +C + CALL MB03OY( NCRT, MCRT, B(IQR,1), LDB, TOLDEF, FNRM, RANK, + $ SVAL, IWORK, TAU(ITAU), DWORK, INFO ) +C + IF ( RANK.NE.0 ) THEN + NJ = NI + NI = NCONT + NCONT = NCONT + RANK + INDCON = INDCON + 1 + NBLK(INDCON) = RANK +C +C Premultiply and postmultiply the appropriate block row +C and block column of A by Q' and Q, respectively. +C Workspace: need NCRT; +C prefer NCRT*NB. +C + CALL DORMQR( 'Left', 'Transpose', NCRT, NCRT, RANK, + $ B(IQR,1), LDB, TAU(ITAU), A(NI+1,NI+1), LDA, + $ DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Workspace: need N; +C prefer N*NB. +C + CALL DORMQR( 'Right', 'No transpose', N, NCRT, RANK, + $ B(IQR,1), LDB, TAU(ITAU), A(1,NI+1), LDA, + $ DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C If required, save transformations. +C + IF ( LJOBZ.AND.NCRT.GT.1 ) THEN + CALL DLACPY( 'L', NCRT-1, MIN( RANK, NCRT-1 ), + $ B(IQR+1,1), LDB, Z(NI+2,ITAU), LDZ ) + END IF +C +C Zero the subdiagonal elements of the current matrix. +C + IF ( RANK.GT.1 ) + $ CALL DLASET( 'L', RANK-1, RANK-1, ZERO, ZERO, B(IQR+1,1), + $ LDB ) +C +C Backward permutation of the columns of B or A. +C + IF ( INDCON.EQ.1 ) THEN + CALL DLAPMT( .FALSE., RANK, M, B(IQR,1), LDB, IWORK ) + IQR = RANK + 1 + ELSE + DO 20 J = 1, MCRT + CALL DCOPY( RANK, B(IQR,J), 1, A(NI+1,NJ+IWORK(J)), + $ 1 ) + 20 CONTINUE + END IF +C + ITAU = ITAU + RANK + IF ( RANK.NE.NCRT ) THEN + MCRT = RANK + NCRT = NCRT - RANK + CALL DLACPY( 'G', NCRT, MCRT, A(NCONT+1,NI+1), LDA, + $ B(IQR,1), LDB ) + CALL DLASET( 'G', NCRT, MCRT, ZERO, ZERO, + $ A(NCONT+1,NI+1), LDA ) + GO TO 10 + END IF + END IF +C +C If required, accumulate transformations. +C Workspace: need N; prefer N*NB. +C + IF ( LJOBI ) THEN + CALL DORGQR( N, N, MAX( 1, ITAU-1 ), Z, LDZ, TAU, DWORK, + $ LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + END IF +C +C Annihilate the trailing blocks of B. +C + IF ( N.GE.IQR ) + $ CALL DLASET( 'G', N-IQR+1, M, ZERO, ZERO, B(IQR,1), LDB ) +C +C Annihilate the trailing elements of TAU, if JOBZ = 'F'. +C + IF ( LJOBF ) THEN + DO 30 J = ITAU, N + TAU(J) = ZERO + 30 CONTINUE + END IF +C +C Undo scaling of A and B. +C + IF ( INDCON.LT.N ) THEN + NBL = INDCON + 1 + NBLK(NBL) = N - NCONT + ELSE + NBL = 0 + END IF + CALL MB01PD( 'Undo', 'H', N, N, 0, 0, ANORM, NBL, NBLK, A, + $ LDA, INFO ) + CALL MB01PD( 'Undo', 'G', NBLK(1), M, 0, 0, BNORM, 0, NBLK, B, + $ LDB, INFO ) +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of AB01ND *** + END diff --git a/mex/sources/libslicot/AB01OD.f b/mex/sources/libslicot/AB01OD.f new file mode 100644 index 000000000..f85ed5626 --- /dev/null +++ b/mex/sources/libslicot/AB01OD.f @@ -0,0 +1,535 @@ + SUBROUTINE AB01OD( STAGES, JOBU, JOBV, N, M, A, LDA, B, LDB, U, + $ LDU, V, LDV, NCONT, INDCON, KSTAIR, TOL, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the matrices A and B using (and optionally accumulating) +C state-space and input-space transformations U and V respectively, +C such that the pair of matrices +C +C Ac = U' * A * U, Bc = U' * B * V +C +C are in upper "staircase" form. Specifically, +C +C [ Acont * ] [ Bcont ] +C Ac = [ ], Bc = [ ], +C [ 0 Auncont ] [ 0 ] +C +C and +C +C [ A11 A12 . . . A1,p-1 A1p ] [ B1 ] +C [ A21 A22 . . . A2,p-1 A2p ] [ 0 ] +C [ 0 A32 . . . A3,p-1 A3p ] [ 0 ] +C Acont = [ . . . . . . . ], Bc = [ . ], +C [ . . . . . . ] [ . ] +C [ . . . . . ] [ . ] +C [ 0 0 . . . Ap,p-1 App ] [ 0 ] +C +C where the blocks B1, A21, ..., Ap,p-1 have full row ranks and +C p is the controllability index of the pair. The size of the +C block Auncont is equal to the dimension of the uncontrollable +C subspace of the pair (A, B). The first stage of the reduction, +C the "forward" stage, accomplishes the reduction to the orthogonal +C canonical form (see SLICOT library routine AB01ND). The blocks +C B1, A21, ..., Ap,p-1 are further reduced in a second, "backward" +C stage to upper triangular form using RQ factorization. Each of +C these stages is optional. +C +C ARGUMENTS +C +C Mode Parameters +C +C STAGES CHARACTER*1 +C Specifies the reduction stages to be performed as follows: +C = 'F': Perform the forward stage only; +C = 'B': Perform the backward stage only; +C = 'A': Perform both (all) stages. +C +C JOBU CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix U the state-space transformations as follows: +C = 'N': Do not form U; +C = 'I': U is internally initialized to the unit matrix (if +C STAGES <> 'B'), or updated (if STAGES = 'B'), and +C the orthogonal transformation matrix U is +C returned. +C +C JOBV CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix V the input-space transformations as follows: +C = 'N': Do not form V; +C = 'I': V is initialized to the unit matrix and the +C orthogonal transformation matrix V is returned. +C JOBV is not referenced if STAGES = 'F'. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e. the order of the +C matrix A. N >= 0. +C +C M (input) INTEGER +C The actual input dimension. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state transition matrix A to be transformed. +C If STAGES = 'B', A should be in the orthogonal canonical +C form, as returned by SLICOT library routine AB01ND. +C On exit, the leading N-by-N part of this array contains +C the transformed state transition matrix U' * A * U. +C The leading NCONT-by-NCONT part contains the upper block +C Hessenberg state matrix Acont in Ac, given by U' * A * U, +C of a controllable realization for the original system. +C The elements below the first block-subdiagonal are set to +C zero. If STAGES <> 'F', the subdiagonal blocks of A are +C triangularized by RQ factorization, and the annihilated +C elements are explicitly zeroed. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B to be transformed. +C If STAGES = 'B', B should be in the orthogonal canonical +C form, as returned by SLICOT library routine AB01ND. +C On exit with STAGES = 'F', the leading N-by-M part of +C this array contains the transformed input matrix U' * B, +C with all elements but the first block set to zero. +C On exit with STAGES <> 'F', the leading N-by-M part of +C this array contains the transformed input matrix +C U' * B * V, with all elements but the first block set to +C zero and the first block in upper triangular form. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) +C If STAGES <> 'B' or JOBU = 'N', then U need not be set +C on entry. +C If STAGES = 'B' and JOBU = 'I', then, on entry, the +C leading N-by-N part of this array must contain the +C transformation matrix U that reduced the pair to the +C orthogonal canonical form. +C On exit, if JOBU = 'I', the leading N-by-N part of this +C array contains the transformation matrix U that performed +C the specified reduction. +C If JOBU = 'N', the array U is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDU = 1 and +C declare this array to be U(1,1) in the calling program). +C +C LDU INTEGER +C The leading dimension of array U. +C If JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1. +C +C V (output) DOUBLE PRECISION array, dimension (LDV,M) +C If JOBV = 'I', then the leading M-by-M part of this array +C contains the transformation matrix V. +C If STAGES = 'F', or JOBV = 'N', the array V is not +C referenced and can be supplied as a dummy array (i.e. set +C parameter LDV = 1 and declare this array to be V(1,1) in +C the calling program). +C +C LDV INTEGER +C The leading dimension of array V. +C If STAGES <> 'F' and JOBV = 'I', LDV >= MAX(1,M); +C if STAGES = 'F' or JOBV = 'N', LDV >= 1. +C +C NCONT (input/output) INTEGER +C The order of the controllable state-space representation. +C NCONT is input only if STAGES = 'B'. +C +C INDCON (input/output) INTEGER +C The number of stairs in the staircase form (also, the +C controllability index of the controllable part of the +C system representation). +C INDCON is input only if STAGES = 'B'. +C +C KSTAIR (input/output) INTEGER array, dimension (N) +C The leading INDCON elements of this array contain the +C dimensions of the stairs, or, also, the orders of the +C diagonal blocks of Acont. +C KSTAIR is input if STAGES = 'B', and output otherwise. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determination when +C transforming (A, B). If the user sets TOL > 0, then +C the given value of TOL is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*N*EPS, is used instead, where EPS +C is the machine precision (see LAPACK Library routine +C DLAMCH). +C TOL is not referenced if STAGES = 'B'. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C IWORK is not referenced if STAGES = 'B'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C If STAGES <> 'B', LDWORK >= MAX(1, N + MAX(N,3*M)); +C If STAGES = 'B', LDWORK >= MAX(1, M + MAX(N,M)). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Staircase reduction of the pencil [B|sI - A] is used. Orthogonal +C transformations U and V are constructed such that +C +C +C |B |sI-A * . . . * * | +C | 1| 11 . . . | +C | | A sI-A . . . | +C | | 21 22 . . . | +C | | . . * * | +C [U'BV|sI - U'AU] = |0 | 0 . . | +C | | A sI-A * | +C | | p,p-1 pp | +C | | | +C |0 | 0 0 sI-A | +C | | p+1,p+1| +C +C +C where the i-th diagonal block of U'AU has dimension KSTAIR(i), +C for i = 1,...,p. The value of p is returned in INDCON. The last +C block contains the uncontrollable modes of the (A,B)-pair which +C are also the generalized eigenvalues of the above pencil. +C +C The complete reduction is performed in two stages. The first, +C forward stage accomplishes the reduction to the orthogonal +C canonical form. The second, backward stage consists in further +C reduction to triangular form by applying left and right orthogonal +C transformations. +C +C REFERENCES +C +C [1] Van Dooren, P. +C The generalized eigenvalue problem in linear system theory. +C IEEE Trans. Auto. Contr., AC-26, pp. 111-129, 1981. +C +C [2] Miminis, G. and Paige, C. +C An algorithm for pole assignment of time-invariant multi-input +C linear systems. +C Proc. 21st IEEE CDC, Orlando, Florida, 1, pp. 62-67, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O((N + M) x N**2) operations and is +C backward stable (see [1]). +C +C FURTHER COMMENTS +C +C If the system matrices A and B are badly scaled, it would be +C useful to scale them with SLICOT routine TB01ID, before calling +C the routine. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C Supersedes Release 2.0 routine AB01CD by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C January 14, 1997, February 12, 1998, September 22, 2003. +C +C KEYWORDS +C +C Controllability, generalized eigenvalue problem, orthogonal +C transformation, staircase form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBU, JOBV, STAGES + INTEGER INDCON, INFO, LDA, LDB, LDU, LDV, LDWORK, M, N, + $ NCONT + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*), KSTAIR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), U(LDU,*), V(LDV,*) +C .. Local Scalars .. + LOGICAL LJOBUI, LJOBVI, LSTAGB, LSTGAB + INTEGER I, I0, IBSTEP, ITAU, J0, JINI, JWORK, MCRT, MM, + $ NCRT, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB01ND, DGERQF, DLACPY, DLASET, DORGRQ, DORMRQ, + $ DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LJOBUI = LSAME( JOBU, 'I' ) +C + LSTAGB = LSAME( STAGES, 'B' ) + LSTGAB = LSAME( STAGES, 'A' ).OR.LSTAGB +C + IF ( LSTGAB ) THEN + LJOBVI = LSAME( JOBV, 'I' ) + END IF +C +C Test the input scalar arguments. +C + IF( .NOT.LSTGAB .AND. .NOT.LSAME( STAGES, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LJOBUI .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDU.LT.1 .OR. ( LJOBUI .AND. LDU.LT.N ) ) THEN + INFO = -11 + ELSE IF( .NOT.LSTAGB .AND. LDWORK.LT.MAX( 1, N + MAX( N, 3*M ) ) + $ .OR. LSTAGB .AND. LDWORK.LT.MAX( 1, M + MAX( N, M ) ) ) + $ THEN + INFO = -20 + ELSE IF( LSTAGB .AND. NCONT.GT.N ) THEN + INFO = -14 + ELSE IF( LSTAGB .AND. INDCON.GT.N ) THEN + INFO = -15 + ELSE IF( LSTGAB ) THEN + IF( .NOT.LJOBVI .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN + INFO = -3 + ELSE IF( LDV.LT.1 .OR. ( LJOBVI .AND. LDV.LT.M ) ) THEN + INFO = -13 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB01OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( N, M ).EQ.0 ) THEN + NCONT = 0 + INDCON = 0 + IF( N.GT.0 .AND. LJOBUI ) + $ CALL DLASET( 'F', N, N, ZERO, ONE, U, LDU ) + IF( LSTGAB ) THEN + IF( M.GT.0 .AND. LJOBVI ) + $ CALL DLASET( 'F', M, M, ZERO, ONE, V, LDV ) + END IF + DWORK(1) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + ITAU = 1 + WRKOPT = 1 +C + IF ( .NOT.LSTAGB ) THEN +C +C Perform the forward stage computations of the staircase +C algorithm on B and A: reduce the (A, B) pair to orthogonal +C canonical form. +C +C Workspace: N + MAX(N,3*M). +C + JWORK = N + 1 + CALL AB01ND( JOBU, N, M, A, LDA, B, LDB, NCONT, INDCON, + $ KSTAIR, U, LDU, DWORK(ITAU), TOL, IWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 + END IF +C +C Exit if no further reduction to triangularize B1 and subdiagonal +C blocks of A is required, or if the order of the controllable part +C is 0. +C + IF ( .NOT.LSTGAB ) THEN + DWORK(1) = WRKOPT + RETURN + ELSE IF ( NCONT.EQ.0 .OR. INDCON.EQ.0 ) THEN + IF( LJOBVI ) + $ CALL DLASET( 'F', M, M, ZERO, ONE, V, LDV ) + DWORK(1) = WRKOPT + RETURN + END IF +C +C Now perform the backward steps except the last one. +C + MCRT = KSTAIR(INDCON) + I0 = NCONT - MCRT + 1 + JWORK = M + 1 +C + DO 10 IBSTEP = INDCON, 2, -1 + NCRT = KSTAIR(IBSTEP-1) + J0 = I0 - NCRT + MM = MIN( NCRT, MCRT ) +C +C Compute the RQ factorization of the current subdiagonal block +C of A, Ai,i-1 = R*Q (where i is IBSTEP), of dimension +C MCRT-by-NCRT, starting in position (I0,J0). +C The matrix Q' should postmultiply U, if required. +C Workspace: need M + MCRT; +C prefer M + MCRT*NB. +C + CALL DGERQF( MCRT, NCRT, A(I0,J0), LDA, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Set JINI to the first column number in A where the current +C transformation Q is to be applied, taking the block Hessenberg +C form into account. +C + IF ( IBSTEP.GT.2 ) THEN + JINI = J0 - KSTAIR(IBSTEP-2) + ELSE + JINI = 1 +C +C Premultiply the first block row (B1) of B by Q. +C Workspace: need 2*M; +C prefer M + M*NB. +C + CALL DORMRQ( 'Left', 'No transpose', NCRT, M, MM, A(I0,J0), + $ LDA, DWORK(ITAU), B, LDB, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) + END IF +C +C Premultiply the appropriate block row of A by Q. +C Workspace: need M + N; +C prefer M + N*NB. +C + CALL DORMRQ( 'Left', 'No transpose', NCRT, N-JINI+1, MM, + $ A(I0,J0), LDA, DWORK(ITAU), A(J0,JINI), LDA, + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Postmultiply the appropriate block column of A by Q'. +C Workspace: need M + I0-1; +C prefer M + (I0-1)*NB. +C + CALL DORMRQ( 'Right', 'Transpose', I0-1, NCRT, MM, A(I0,J0), + $ LDA, DWORK(ITAU), A(1,J0), LDA, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( LJOBUI ) THEN +C +C Update U, postmultiplying it by Q'. +C Workspace: need M + N; +C prefer M + N*NB. +C + CALL DORMRQ( 'Right', 'Transpose', N, NCRT, MM, A(I0,J0), + $ LDA, DWORK(ITAU), U(1,J0), LDU, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) + END IF +C +C Zero the subdiagonal elements of the current subdiagonal block +C of A. +C + CALL DLASET( 'F', MCRT, NCRT-MCRT, ZERO, ZERO, A(I0,J0), LDA ) + IF ( I0.LT.N ) + $ CALL DLASET( 'L', MCRT-1, MCRT-1, ZERO, ZERO, + $ A(I0+1,I0-MCRT), LDA ) +C + MCRT = NCRT + I0 = J0 +C + 10 CONTINUE +C +C Now perform the last backward step on B, V = Qb'. +C +C Compute the RQ factorization of the first block of B, B1 = R*Qb. +C Workspace: need M + MCRT; +C prefer M + MCRT*NB. +C + CALL DGERQF( MCRT, M, B, LDB, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( LJOBVI ) THEN +C +C Accumulate the input-space transformations V. +C Workspace: need 2*M; prefer M + M*NB. +C + CALL DLACPY( 'F', MCRT, M-MCRT, B, LDB, V(M-MCRT+1,1), LDV ) + IF ( MCRT.GT.1 ) + $ CALL DLACPY( 'L', MCRT-1, MCRT-1, B(2,M-MCRT+1), LDB, + $ V(M-MCRT+2,M-MCRT+1), LDV ) + CALL DORGRQ( M, M, MCRT, V, LDV, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) +C + DO 20 I = 2, M + CALL DSWAP( I-1, V(I,1), LDV, V(1,I), 1 ) + 20 CONTINUE +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) + END IF +C +C Zero the subdiagonal elements of the submatrix B1. +C + CALL DLASET( 'F', MCRT, M-MCRT, ZERO, ZERO, B, LDB ) + IF ( MCRT.GT.1 ) + $ CALL DLASET( 'L', MCRT-1, MCRT-1, ZERO, ZERO, B(2,M-MCRT+1), + $ LDB ) +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of AB01OD *** + END diff --git a/mex/sources/libslicot/AB04MD.f b/mex/sources/libslicot/AB04MD.f new file mode 100644 index 000000000..b5856fcd9 --- /dev/null +++ b/mex/sources/libslicot/AB04MD.f @@ -0,0 +1,345 @@ + SUBROUTINE AB04MD( TYPE, N, M, P, ALPHA, BETA, A, LDA, B, LDB, C, + $ LDC, D, LDD, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform a transformation on the parameters (A,B,C,D) of a +C system, which is equivalent to a bilinear transformation of the +C corresponding transfer function matrix. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPE CHARACTER*1 +C Indicates the type of the original system and the +C transformation to be performed as follows: +C = 'D': discrete-time -> continuous-time; +C = 'C': continuous-time -> discrete-time. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C ALPHA, (input) DOUBLE PRECISION +C BETA Parameters specifying the bilinear transformation. +C Recommended values for stable systems: ALPHA = 1, +C BETA = 1. ALPHA <> 0, BETA <> 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state matrix A of the original system. +C On exit, the leading N-by-N part of this array contains +C _ +C the state matrix A of the transformed system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B of the original system. +C On exit, the leading N-by-M part of this array contains +C _ +C the input matrix B of the transformed system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C of the original system. +C On exit, the leading P-by-N part of this array contains +C _ +C the output matrix C of the transformed system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the input/output matrix D for the original system. +C On exit, the leading P-by-M part of this array contains +C _ +C the input/output matrix D of the transformed system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C For optimum performance LDWORK >= MAX(1,N*NB), where NB +C is the optimal blocksize. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix (ALPHA*I + A) is exactly singular; +C = 2: if the matrix (BETA*I - A) is exactly singular. +C +C METHOD +C +C The parameters of the discrete-time system are transformed into +C the parameters of the continuous-time system (TYPE = 'D'), or +C vice-versa (TYPE = 'C') by the transformation: +C +C 1. Discrete -> continuous +C _ -1 +C A = beta*(alpha*I + A) * (A - alpha*I) +C _ -1 +C B = sqrt(2*alpha*beta) * (alpha*I + A) * B +C _ -1 +C C = sqrt(2*alpha*beta) * C * (alpha*I + A) +C _ -1 +C D = D - C * (alpha*I + A) * B +C +C which is equivalent to the bilinear transformation +C +C z - alpha +C z -> s = beta --------- . +C z + alpha +C +C of one transfer matrix onto the other. +C +C 2. Continuous -> discrete +C _ -1 +C A = alpha*(beta*I - A) * (beta*I + A) +C _ -1 +C B = sqrt(2*alpha*beta) * (beta*I - A) * B +C _ -1 +C C = sqrt(2*alpha*beta) * C * (beta*I - A) +C _ -1 +C D = D + C * (beta*I - A) * B +C +C which is equivalent to the bilinear transformation +C +C beta + s +C s -> z = alpha -------- . +C beta - s +C +C of one transfer matrix onto the other. +C +C REFERENCES +C +C [1] Al-Saggaf, U.M. and Franklin, G.F. +C Model reduction via balanced realizations: a extension and +C frequency weighting techniques. +C IEEE Trans. Autom. Contr., AC-33, pp. 687-692, 1988. +C +C NUMERICAL ASPECTS +C 3 +C The time taken is approximately proportional to N . +C The accuracy depends mainly on the condition number of the matrix +C to be inverted. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, and +C A. Varga, German Aerospace Research Establishment, +C Oberpfaffenhofen, Germany, Nov. 1996. +C Supersedes Release 2.0 routine AB04AD by W. van der Linden, and +C A.J. Geurts, Technische Hogeschool Eindhoven, Holland. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Bilinear transformation, continuous-time system, discrete-time +C system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO=0.0D0, ONE=1.0D0, TWO=2.0D0 ) +C .. Scalar Arguments .. + CHARACTER TYPE + INTEGER INFO, LDA, LDB, LDC, LDD, LDWORK, M, N, P + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) +C .. Local Scalars .. + LOGICAL LTYPE + INTEGER I, IP + DOUBLE PRECISION AB2, PALPHA, PBETA, SQRAB2 +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DGETRF, DGETRS, DGETRI, DLASCL, DSCAL, + $ DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +C .. Executable Statements .. +C + INFO = 0 + LTYPE = LSAME( TYPE, 'D' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LTYPE .AND. .NOT.LSAME( TYPE, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( ALPHA.EQ.ZERO ) THEN + INFO = -5 + ELSE IF( BETA.EQ.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -14 + ELSE IF( LDWORK.LT.MAX( 1, N ) ) THEN + INFO = -17 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB04MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, M, P ).EQ.0 ) + $ RETURN +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF (LTYPE) THEN +C +C Discrete-time to continuous-time with (ALPHA, BETA). +C + PALPHA = ALPHA + PBETA = BETA + ELSE +C +C Continuous-time to discrete-time with (ALPHA, BETA) is +C equivalent with discrete-time to continuous-time with +C (-BETA, -ALPHA), if B and C change the sign. +C + PALPHA = -BETA + PBETA = -ALPHA + END IF +C + AB2 = PALPHA*PBETA*TWO + SQRAB2 = SIGN( SQRT( ABS( AB2 ) ), PALPHA ) +C -1 +C Compute (alpha*I + A) . +C + DO 10 I = 1, N + A(I,I) = A(I,I) + PALPHA + 10 CONTINUE +C + CALL DGETRF( N, N, A, LDA, IWORK, INFO ) +C + IF (INFO.NE.0) THEN +C +C Error return. +C + IF (LTYPE) THEN + INFO = 1 + ELSE + INFO = 2 + END IF + RETURN + END IF +C -1 +C Compute (alpha*I+A) *B. +C + CALL DGETRS( 'No transpose', N, M, A, LDA, IWORK, B, LDB, INFO ) +C -1 +C Compute D - C*(alpha*I+A) *B. +C + CALL DGEMM( 'No transpose', 'No transpose', P, M, N, -ONE, C, + $ LDC, B, LDB, ONE, D, LDD ) +C +C Scale B by sqrt(2*alpha*beta). +C + CALL DLASCL( 'General', 0, 0, ONE, SQRAB2, N, M, B, LDB, INFO ) +C -1 +C Compute sqrt(2*alpha*beta)*C*(alpha*I + A) . +C + CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', P, N, + $ SQRAB2, A, LDA, C, LDC ) +C + CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', P, N, ONE, + $ A, LDA, C, LDC ) +C +C Apply column interchanges to the solution matrix. +C + DO 20 I = N-1, 1, -1 + IP = IWORK(I) + IF ( IP.NE.I ) + $ CALL DSWAP( P, C(1,I), 1, C(1,IP), 1 ) + 20 CONTINUE +C -1 +C Compute beta*(alpha*I + A) *(A - alpha*I) as +C -1 +C beta*I - 2*alpha*beta*(alpha*I + A) . +C +C Workspace: need N; prefer N*NB. +C + CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO ) +C + DO 30 I = 1, N + CALL DSCAL(N, -AB2, A(1,I), 1) + A(I,I) = A(I,I) + PBETA + 30 CONTINUE +C + RETURN +C *** Last line of AB04MD *** + END diff --git a/mex/sources/libslicot/AB05MD.f b/mex/sources/libslicot/AB05MD.f new file mode 100644 index 000000000..0324368bf --- /dev/null +++ b/mex/sources/libslicot/AB05MD.f @@ -0,0 +1,547 @@ + SUBROUTINE AB05MD( UPLO, OVER, N1, M1, P1, N2, P2, A1, LDA1, B1, + $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, + $ C2, LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC, + $ D, LDD, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To obtain the state-space model (A,B,C,D) for the cascaded +C inter-connection of two systems, each given in state-space form. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Indicates whether the user wishes to obtain the matrix A +C in the upper or lower block diagonal form, as follows: +C = 'U': Obtain A in the upper block diagonal form; +C = 'L': Obtain A in the lower block diagonal form. +C +C OVER CHARACTER*1 +C Indicates whether the user wishes to overlap pairs of +C arrays, as follows: +C = 'N': Do not overlap; +C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, +C C1 and C, and D1 and D (for UPLO = 'L'), or A2 +C and A, B2 and B, C2 and C, and D2 and D (for +C UPLO = 'U'), i.e. the same name is effectively +C used for each pair (for all pairs) in the routine +C call. In this case, setting LDA1 = LDA, +C LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD, or +C LDA2 = LDA, LDB2 = LDB, LDC2 = LDC, and LDD2 = LDD +C will give maximum efficiency. +C +C Input/Output Parameters +C +C N1 (input) INTEGER +C The number of state variables in the first system, i.e. +C the order of the matrix A1. N1 >= 0. +C +C M1 (input) INTEGER +C The number of input variables for the first system. +C M1 >= 0. +C +C P1 (input) INTEGER +C The number of output variables from the first system and +C the number of input variables for the second system. +C P1 >= 0. +C +C N2 (input) INTEGER +C The number of state variables in the second system, i.e. +C the order of the matrix A2. N2 >= 0. +C +C P2 (input) INTEGER +C The number of output variables from the second system. +C P2 >= 0. +C +C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) +C The leading N1-by-N1 part of this array must contain the +C state transition matrix A1 for the first system. +C +C LDA1 INTEGER +C The leading dimension of array A1. LDA1 >= MAX(1,N1). +C +C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) +C The leading N1-by-M1 part of this array must contain the +C input/state matrix B1 for the first system. +C +C LDB1 INTEGER +C The leading dimension of array B1. LDB1 >= MAX(1,N1). +C +C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) +C The leading P1-by-N1 part of this array must contain the +C state/output matrix C1 for the first system. +C +C LDC1 INTEGER +C The leading dimension of array C1. +C LDC1 >= MAX(1,P1) if N1 > 0. +C LDC1 >= 1 if N1 = 0. +C +C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) +C The leading P1-by-M1 part of this array must contain the +C input/output matrix D1 for the first system. +C +C LDD1 INTEGER +C The leading dimension of array D1. LDD1 >= MAX(1,P1). +C +C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) +C The leading N2-by-N2 part of this array must contain the +C state transition matrix A2 for the second system. +C +C LDA2 INTEGER +C The leading dimension of array A2. LDA2 >= MAX(1,N2). +C +C B2 (input) DOUBLE PRECISION array, dimension (LDB2,P1) +C The leading N2-by-P1 part of this array must contain the +C input/state matrix B2 for the second system. +C +C LDB2 INTEGER +C The leading dimension of array B2. LDB2 >= MAX(1,N2). +C +C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) +C The leading P2-by-N2 part of this array must contain the +C state/output matrix C2 for the second system. +C +C LDC2 INTEGER +C The leading dimension of array C2. +C LDC2 >= MAX(1,P2) if N2 > 0. +C LDC2 >= 1 if N2 = 0. +C +C D2 (input) DOUBLE PRECISION array, dimension (LDD2,P1) +C The leading P2-by-P1 part of this array must contain the +C input/output matrix D2 for the second system. +C +C LDD2 INTEGER +C The leading dimension of array D2. LDD2 >= MAX(1,P2). +C +C N (output) INTEGER +C The number of state variables (N1 + N2) in the resulting +C system, i.e. the order of the matrix A, the number of rows +C of B and the number of columns of C. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) +C The leading N-by-N part of this array contains the state +C transition matrix A for the cascaded system. +C If OVER = 'O', the array A can overlap A1, if UPLO = 'L', +C or A2, if UPLO = 'U'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N1+N2). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M1) +C The leading N-by-M1 part of this array contains the +C input/state matrix B for the cascaded system. +C If OVER = 'O', the array B can overlap B1, if UPLO = 'L', +C or B2, if UPLO = 'U'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N1+N2). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) +C The leading P2-by-N part of this array contains the +C state/output matrix C for the cascaded system. +C If OVER = 'O', the array C can overlap C1, if UPLO = 'L', +C or C2, if UPLO = 'U'. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,P2) if N1+N2 > 0. +C LDC >= 1 if N1+N2 = 0. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M1) +C The leading P2-by-M1 part of this array contains the +C input/output matrix D for the cascaded system. +C If OVER = 'O', the array D can overlap D1, if UPLO = 'L', +C or D2, if UPLO = 'U'. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P2). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C The array DWORK is not referenced if OVER = 'N'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, P1*MAX(N1, M1, N2, P2) ) if OVER = 'O'. +C LDWORK >= 1 if OVER = 'N'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C After cascaded inter-connection of the two systems +C +C X1' = A1*X1 + B1*U +C V = C1*X1 + D1*U +C +C X2' = A2*X2 + B2*V +C Y = C2*X2 + D2*V +C +C (where ' denotes differentiation with respect to time) +C +C the following state-space model will be obtained: +C +C X' = A*X + B*U +C Y = C*X + D*U +C +C where matrix A has the form ( A1 0 ), +C ( B2*C1 A2) +C +C matrix B has the form ( B1 ), +C ( B2*D1 ) +C +C matrix C has the form ( D2*C1 C2 ) and +C +C matrix D has the form ( D2*D1 ). +C +C This form is returned by the routine when UPLO = 'L'. Note that +C when A1 and A2 are block lower triangular, the resulting state +C matrix is also block lower triangular. +C +C By applying a similarity transformation to the system above, +C using the matrix ( 0 I ), where I is the identity matrix of +C ( J 0 ) +C order N2, and J is the identity matrix of order N1, the +C system matrices become +C +C A = ( A2 B2*C1 ), +C ( 0 A1 ) +C +C B = ( B2*D1 ), +C ( B1 ) +C +C C = ( C2 D2*C1 ) and +C +C D = ( D2*D1 ). +C +C This form is returned by the routine when UPLO = 'U'. Note that +C when A1 and A2 are block upper triangular (for instance, in the +C real Schur form), the resulting state matrix is also block upper +C triangular. +C +C REFERENCES +C +C None +C +C NUMERICAL ASPECTS +C +C The algorithm requires P1*(N1+M1)*(N2+P2) operations. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, and +C A. Varga, German Aerospace Research Establishment, +C Oberpfaffenhofen, Germany, Nov. 1996. +C Supersedes Release 2.0 routine AB05AD by C.J.Benson, Kingston +C Polytechnic, United Kingdom, January 1982. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 2003, +C Feb. 2004. +C +C KEYWORDS +C +C Cascade control, continuous-time system, multivariable +C system, state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER OVER, UPLO + INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, + $ LDC1, LDC2, LDD, LDD1, LDD2, LDWORK, M1, N, N1, + $ N2, P1, P2 +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), + $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), + $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*), + $ DWORK(*) +C .. Local Scalars .. + LOGICAL LOVER, LUPLO + INTEGER I, I1, I2, J, LDWN2, LDWP1, LDWP2 +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + LOVER = LSAME( OVER, 'O' ) + LUPLO = LSAME( UPLO, 'L' ) + N = N1 + N2 + INFO = 0 +C +C Test the input scalar arguments. +C + IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN + INFO = -2 + ELSE IF( N1.LT.0 ) THEN + INFO = -3 + ELSE IF( M1.LT.0 ) THEN + INFO = -4 + ELSE IF( P1.LT.0 ) THEN + INFO = -5 + ELSE IF( N2.LT.0 ) THEN + INFO = -6 + ELSE IF( P2.LT.0 ) THEN + INFO = -7 + ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN + INFO = -9 + ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN + INFO = -11 + ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. + $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN + INFO = -13 + ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN + INFO = -15 + ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN + INFO = -17 + ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN + INFO = -19 + ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P2 ) ) .OR. + $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN + INFO = -21 + ELSE IF( LDD2.LT.MAX( 1, P2 ) ) THEN + INFO = -23 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -26 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -28 + ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P2 ) ) .OR. + $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN + INFO = -30 + ELSE IF( LDD.LT.MAX( 1, P2 ) ) THEN + INFO = -32 + ELSE IF( ( LOVER.AND.LDWORK.LT.MAX( 1, P1*MAX( N1, M1, N2, P2 )) ) + $.OR.( .NOT.LOVER.AND.LDWORK.LT.1 ) ) THEN + INFO = -34 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB05MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, MIN( M1, P2 ) ).EQ.0 ) + $ RETURN +C +C Set row/column indices for storing the results. +C + IF ( LUPLO ) THEN + I1 = 1 + I2 = MIN( N1 + 1, N ) + ELSE + I1 = MIN( N2 + 1, N ) + I2 = 1 + END IF +C + LDWN2 = MAX( 1, N2 ) + LDWP1 = MAX( 1, P1 ) + LDWP2 = MAX( 1, P2 ) +C +C Construct the cascaded system matrices, taking the desired block +C structure and possible overwriting into account. +C +C Form the diagonal blocks of matrix A. +C + IF ( LUPLO ) THEN +C +C Lower block diagonal structure. +C + IF ( LOVER .AND. LDA1.LE.LDA ) THEN + IF ( LDA1.LT.LDA ) THEN +C + DO 20 J = N1, 1, -1 + DO 10 I = N1, 1, -1 + A(I,J) = A1(I,J) + 10 CONTINUE + 20 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) + END IF + IF ( N2.GT.0 ) + $ CALL DLACPY( 'F', N2, N2, A2, LDA2, A(I2,I2), LDA ) + ELSE +C +C Upper block diagonal structure. +C + IF ( LOVER .AND. LDA2.LE.LDA ) THEN + IF ( LDA2.LT.LDA ) THEN +C + DO 40 J = N2, 1, -1 + DO 30 I = N2, 1, -1 + A(I,J) = A2(I,J) + 30 CONTINUE + 40 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N2, N2, A2, LDA2, A, LDA ) + END IF + IF ( N1.GT.0 ) + $ CALL DLACPY( 'F', N1, N1, A1, LDA1, A(I1,I1), LDA ) + END IF +C +C Form the off-diagonal blocks of matrix A. +C + IF ( MIN( N1, N2 ).GT.0 ) THEN + CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(I1,I2), LDA ) + CALL DGEMM ( 'No transpose', 'No transpose', N2, N1, P1, ONE, + $ B2, LDB2, C1, LDC1, ZERO, A(I2,I1), LDA ) + END IF +C + IF ( LUPLO ) THEN +C +C Form the matrix B. +C + IF ( LOVER .AND. LDB1.LE.LDB ) THEN + IF ( LDB1.LT.LDB ) THEN +C + DO 60 J = M1, 1, -1 + DO 50 I = N1, 1, -1 + B(I,J) = B1(I,J) + 50 CONTINUE + 60 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, M1, B1, LDB1, B, LDB ) + END IF +C + IF ( MIN( N2, M1 ).GT.0 ) + $ CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, + $ ONE, B2, LDB2, D1, LDD1, ZERO, B(I2,1), LDB ) +C +C Form the matrix C. +C + IF ( N1.GT.0 ) THEN + IF ( LOVER ) THEN +C +C Workspace: P1*N1. +C + CALL DLACPY( 'F', P1, N1, C1, LDC1, DWORK, LDWP1 ) + CALL DGEMM ( 'No transpose', 'No transpose', P2, N1, P1, + $ ONE, D2, LDD2, DWORK, LDWP1, ZERO, C, LDC ) + ELSE + CALL DGEMM ( 'No transpose', 'No transpose', P2, N1, P1, + $ ONE, D2, LDD2, C1, LDC1, ZERO, C, LDC ) + END IF + END IF +C + IF ( MIN( P2, N2 ).GT.0 ) + $ CALL DLACPY( 'F', P2, N2, C2, LDC2, C(1,I2), LDC ) +C +C Now form the matrix D. +C + IF ( LOVER ) THEN +C +C Workspace: P1*M1. +C + CALL DLACPY( 'F', P1, M1, D1, LDD1, DWORK, LDWP1 ) + CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, + $ ONE, D2, LDD2, DWORK, LDWP1, ZERO, D, LDD ) + ELSE + CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, + $ ONE, D2, LDD2, D1, LDD1, ZERO, D, LDD ) + END IF +C + ELSE +C +C Form the matrix B. +C + IF ( LOVER ) THEN +C +C Workspace: N2*P1. +C + CALL DLACPY( 'F', N2, P1, B2, LDB2, DWORK, LDWN2 ) + IF ( MIN( N2, M1 ).GT.0 ) + $ CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, + $ ONE, DWORK, LDWN2, D1, LDD1, ZERO, B(I2,1), + $ LDB ) + ELSE + CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, + $ ONE, B2, LDB2, D1, LDD1, ZERO, B, LDB ) + END IF +C + IF ( MIN( N1, M1 ).GT.0 ) + $ CALL DLACPY( 'F', N1, M1, B1, LDB1, B(I1,1), LDB ) +C +C Form the matrix C. +C + IF ( LOVER .AND. LDC2.LE.LDC ) THEN + IF ( LDC2.LT.LDC ) THEN +C + DO 80 J = N2, 1, -1 + DO 70 I = P2, 1, -1 + C(I,J) = C2(I,J) + 70 CONTINUE + 80 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', P2, N2, C2, LDC2, C, LDC ) + END IF +C + IF ( MIN( P2, N1 ).GT.0 ) + $ CALL DGEMM ( 'No transpose', 'No transpose', P2, N1, P1, + $ ONE, D2, LDD2, C1, LDC1, ZERO, C(1,I1), LDC ) +C +C Now form the matrix D. +C + IF ( LOVER ) THEN +C +C Workspace: P2*P1. +C + CALL DLACPY( 'F', P2, P1, D2, LDD2, DWORK, LDWP2 ) + CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, + $ ONE, DWORK, LDWP2, D1, LDD1, ZERO, D, LDD ) + ELSE + CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, + $ ONE, D2, LDD2, D1, LDD1, ZERO, D, LDD ) + END IF + END IF +C + RETURN +C *** Last line of AB05MD *** + END diff --git a/mex/sources/libslicot/AB05ND.f b/mex/sources/libslicot/AB05ND.f new file mode 100644 index 000000000..507d6ea16 --- /dev/null +++ b/mex/sources/libslicot/AB05ND.f @@ -0,0 +1,564 @@ + SUBROUTINE AB05ND( OVER, N1, M1, P1, N2, ALPHA, A1, LDA1, B1, + $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, + $ C2, LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC, + $ D, LDD, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To obtain the state-space model (A,B,C,D) for the feedback +C inter-connection of two systems, each given in state-space form. +C +C ARGUMENTS +C +C Mode Parameters +C +C OVER CHARACTER*1 +C Indicates whether the user wishes to overlap pairs of +C arrays, as follows: +C = 'N': Do not overlap; +C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, +C C1 and C, and D1 and D, i.e. the same name is +C effectively used for each pair (for all pairs) +C in the routine call. In this case, setting +C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD +C will give maximum efficiency. +C +C Input/Output Parameters +C +C N1 (input) INTEGER +C The number of state variables in the first system, i.e. +C the order of the matrix A1. N1 >= 0. +C +C M1 (input) INTEGER +C The number of input variables for the first system and the +C number of output variables from the second system. +C M1 >= 0. +C +C P1 (input) INTEGER +C The number of output variables from the first system and +C the number of input variables for the second system. +C P1 >= 0. +C +C N2 (input) INTEGER +C The number of state variables in the second system, i.e. +C the order of the matrix A2. N2 >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C A coefficient multiplying the transfer-function matrix +C (or the output equation) of the second system. +C ALPHA = +1 corresponds to positive feedback, and +C ALPHA = -1 corresponds to negative feedback. +C +C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) +C The leading N1-by-N1 part of this array must contain the +C state transition matrix A1 for the first system. +C +C LDA1 INTEGER +C The leading dimension of array A1. LDA1 >= MAX(1,N1). +C +C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) +C The leading N1-by-M1 part of this array must contain the +C input/state matrix B1 for the first system. +C +C LDB1 INTEGER +C The leading dimension of array B1. LDB1 >= MAX(1,N1). +C +C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) +C The leading P1-by-N1 part of this array must contain the +C state/output matrix C1 for the first system. +C +C LDC1 INTEGER +C The leading dimension of array C1. +C LDC1 >= MAX(1,P1) if N1 > 0. +C LDC1 >= 1 if N1 = 0. +C +C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) +C The leading P1-by-M1 part of this array must contain the +C input/output matrix D1 for the first system. +C +C LDD1 INTEGER +C The leading dimension of array D1. LDD1 >= MAX(1,P1). +C +C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) +C The leading N2-by-N2 part of this array must contain the +C state transition matrix A2 for the second system. +C +C LDA2 INTEGER +C The leading dimension of array A2. LDA2 >= MAX(1,N2). +C +C B2 (input) DOUBLE PRECISION array, dimension (LDB2,P1) +C The leading N2-by-P1 part of this array must contain the +C input/state matrix B2 for the second system. +C +C LDB2 INTEGER +C The leading dimension of array B2. LDB2 >= MAX(1,N2). +C +C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) +C The leading M1-by-N2 part of this array must contain the +C state/output matrix C2 for the second system. +C +C LDC2 INTEGER +C The leading dimension of array C2. +C LDC2 >= MAX(1,M1) if N2 > 0. +C LDC2 >= 1 if N2 = 0. +C +C D2 (input) DOUBLE PRECISION array, dimension (LDD2,P1) +C The leading M1-by-P1 part of this array must contain the +C input/output matrix D2 for the second system. +C +C LDD2 INTEGER +C The leading dimension of array D2. LDD2 >= MAX(1,M1). +C +C N (output) INTEGER +C The number of state variables (N1 + N2) in the connected +C system, i.e. the order of the matrix A, the number of rows +C of B and the number of columns of C. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) +C The leading N-by-N part of this array contains the state +C transition matrix A for the connected system. +C The array A can overlap A1 if OVER = 'O'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N1+N2). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M1) +C The leading N-by-M1 part of this array contains the +C input/state matrix B for the connected system. +C The array B can overlap B1 if OVER = 'O'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N1+N2). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) +C The leading P1-by-N part of this array contains the +C state/output matrix C for the connected system. +C The array C can overlap C1 if OVER = 'O'. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,P1) if N1+N2 > 0. +C LDC >= 1 if N1+N2 = 0. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M1) +C The leading P1-by-M1 part of this array contains the +C input/output matrix D for the connected system. +C The array D can overlap D1 if OVER = 'O'. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P1). +C +C Workspace +C +C IWORK INTEGER array, dimension (P1) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. If OVER = 'N', +C LDWORK >= MAX(1, P1*P1, M1*M1, N1*P1), and if OVER = 'O', +C LDWORK >= MAX(1, N1*P1 + MAX( P1*P1, M1*M1, N1*P1) ), +C if M1 <= N*N2; +C LDWORK >= MAX(1, N1*P1 + MAX( P1*P1, M1*(M1+1), N1*P1) ), +C if M1 > N*N2. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C > 0: if INFO = i, 1 <= i <= P1, the system is not +C completely controllable. That is, the matrix +C (I + ALPHA*D1*D2) is exactly singular (the element +C U(i,i) of the upper triangular factor of LU +C factorization is exactly zero), possibly due to +C rounding errors. +C +C METHOD +C +C After feedback inter-connection of the two systems, +C +C X1' = A1*X1 + B1*U1 +C Y1 = C1*X1 + D1*U1 +C +C X2' = A2*X2 + B2*U2 +C Y2 = C2*X2 + D2*U2 +C +C (where ' denotes differentiation with respect to time) +C +C the following state-space model will be obtained: +C +C X' = A*X + B*U +C Y = C*X + D*U +C +C where U = U1 + alpha*Y2, X = ( X1 ), +C Y = Y1 = U2, ( X2 ) +C +C matrix A has the form +C +C ( A1 - alpha*B1*E12*D2*C1 - alpha*B1*E12*C2 ), +C ( B2*E21*C1 A2 - alpha*B2*E21*D1*C2 ) +C +C matrix B has the form +C +C ( B1*E12 ), +C ( B2*E21*D1 ) +C +C matrix C has the form +C +C ( E21*C1 - alpha*E21*D1*C2 ), +C +C matrix D has the form +C +C ( E21*D1 ), +C +C E21 = ( I + alpha*D1*D2 )-INVERSE and +C E12 = ( I + alpha*D2*D1 )-INVERSE = I - alpha*D2*E21*D1. +C +C Taking N1 = 0 and/or N2 = 0 on the routine call will solve the +C constant plant and/or constant feedback cases. +C +C REFERENCES +C +C None +C +C NUMERICAL ASPECTS +C +C None +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C Supersedes Release 2.0 routine AB05BD by C.J.Benson, Kingston +C Polytechnic, United Kingdom, January 1982. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 2003, +C Feb. 2004. +C +C KEYWORDS +C +C Continuous-time system, multivariable system, state-space model, +C state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO=0.0D0, ONE=1.0D0 ) +C .. Scalar Arguments .. + CHARACTER OVER + INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, + $ LDC1, LDC2, LDD, LDD1, LDD2, LDWORK, M1, N, N1, + $ N2, P1 + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), + $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), + $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*), + $ DWORK(*) +C .. Local Scalars .. + LOGICAL LOVER + INTEGER I, J, LDW, LDWM1 +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DGETRF, DGETRS, DLACPY, + $ DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + LOVER = LSAME( OVER, 'O' ) + LDWM1 = MAX( 1, M1 ) + N = N1 + N2 + INFO = 0 +C +C Test the input scalar arguments. +C + IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN + INFO = -1 + ELSE IF( N1.LT.0 ) THEN + INFO = -2 + ELSE IF( M1.LT.0 ) THEN + INFO = -3 + ELSE IF( P1.LT.0 ) THEN + INFO = -4 + ELSE IF( N2.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN + INFO = -8 + ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN + INFO = -10 + ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. + $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN + INFO = -12 + ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN + INFO = -14 + ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN + INFO = -16 + ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN + INFO = -18 + ELSE IF( ( N2.GT.0 .AND. LDC2.LT.LDWM1 ) .OR. + $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN + INFO = -20 + ELSE IF( LDD2.LT.LDWM1 ) THEN + INFO = -22 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -25 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -27 + ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P1 ) ) .OR. + $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN + INFO = -29 + ELSE IF( LDD.LT.MAX( 1, P1 ) ) THEN + INFO = -31 + ELSE + LDW = MAX( P1*P1, M1*M1, N1*P1 ) + IF( LOVER ) THEN + IF( M1.GT.N*N2 ) + $ LDW = MAX( LDW, M1*( M1 + 1 ) ) + LDW = N1*P1 + LDW + END IF + IF( LDWORK.LT.MAX( 1, LDW ) ) + $ INFO = -34 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB05ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, MIN( M1, P1 ) ).EQ.0 ) + $ RETURN +C + IF ( P1.GT.0 ) THEN +C +C Form ( I + alpha * D1 * D2 ). +C + CALL DLASET( 'F', P1, P1, ZERO, ONE, DWORK, P1 ) + CALL DGEMM ( 'No transpose', 'No transpose', P1, P1, M1, ALPHA, + $ D1, LDD1, D2, LDD2, ONE, DWORK, P1 ) +C +C Factorize this matrix. +C + CALL DGETRF( P1, P1, DWORK, P1, IWORK, INFO ) +C + IF ( INFO.NE.0 ) + $ RETURN +C +C Form E21 * D1. +C + IF ( LOVER .AND. LDD1.LE.LDD ) THEN + IF ( LDD1.LT.LDD ) THEN +C + DO 20 J = M1, 1, -1 + DO 10 I = P1, 1, -1 + D(I,J) = D1(I,J) + 10 CONTINUE + 20 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', P1, M1, D1, LDD1, D, LDD ) + END IF +C + CALL DGETRS( 'No transpose', P1, M1, DWORK, P1, IWORK, D, LDD, + $ INFO ) + IF ( N1.GT.0 ) THEN +C +C Form E21 * C1. +C + IF ( LOVER ) THEN +C +C First save C1. +C + LDW = LDW - P1*N1 + 1 + CALL DLACPY( 'F', P1, N1, C1, LDC1, DWORK(LDW), P1 ) +C + IF ( LDC1.NE.LDC ) + $ CALL DLACPY( 'F', P1, N1, DWORK(LDW), P1, C, LDC ) + ELSE + CALL DLACPY( 'F', P1, N1, C1, LDC1, C, LDC ) + END IF +C + CALL DGETRS( 'No transpose', P1, N1, DWORK, P1, IWORK, + $ C, LDC, INFO ) + END IF +C +C Form E12 = I - alpha * D2 * ( E21 * D1 ). +C + CALL DLASET( 'F', M1, M1, ZERO, ONE, DWORK, LDWM1 ) + CALL DGEMM ( 'No transpose', 'No transpose', M1, M1, P1, + $ -ALPHA, D2, LDD2, D, LDD, ONE, DWORK, LDWM1 ) +C + ELSE + CALL DLASET( 'F', M1, M1, ZERO, ONE, DWORK, LDWM1 ) + END IF +C + IF ( LOVER .AND. LDA1.LE.LDA ) THEN + IF ( LDA1.LT.LDA ) THEN +C + DO 40 J = N1, 1, -1 + DO 30 I = N1, 1, -1 + A(I,J) = A1(I,J) + 30 CONTINUE + 40 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) + END IF +C + IF ( N1.GT.0 .AND. M1.GT.0 ) THEN +C +C Form B1 * E12. +C + IF ( LOVER ) THEN +C +C Use the blocks (1,2) and (2,2) of A as workspace. +C + IF ( N1*M1.LE.N*N2 ) THEN +C +C Use BLAS 3 code. +C + CALL DLACPY( 'F', N1, M1, B1, LDB1, A(1,N1+1), N1 ) + CALL DGEMM ( 'No transpose', 'No transpose', N1, M1, M1, + $ ONE, A(1,N1+1), N1, DWORK, LDWM1, ZERO, B, + $ LDB ) + ELSE IF ( LDB1.LT.LDB ) THEN +C + DO 60 J = M1, 1, -1 + DO 50 I = N1, 1, -1 + B(I,J) = B1(I,J) + 50 CONTINUE + 60 CONTINUE +C + IF ( M1.LE.N*N2 ) THEN +C +C Use BLAS 2 code. +C + DO 70 J = 1, N1 + CALL DCOPY( M1, B(J,1), LDB, A(1,N1+1), 1 ) + CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, + $ A(1,N1+1), 1, ZERO, B(J,1), LDB ) + 70 CONTINUE +C + ELSE +C +C Use additional workspace. +C + DO 80 J = 1, N1 + CALL DCOPY( M1, B(J,1), LDB, DWORK(M1*M1+1), 1 ) + CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, + $ DWORK(M1*M1+1), 1, ZERO, B(J,1), LDB ) + 80 CONTINUE +C + END IF +C + ELSE IF ( M1.LE.N*N2 ) THEN +C +C Use BLAS 2 code. +C + DO 90 J = 1, N1 + CALL DCOPY( M1, B1(J,1), LDB1, A(1,N1+1), 1 ) + CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, + $ A(1,N1+1), 1, ZERO, B(J,1), LDB ) + 90 CONTINUE +C + ELSE +C +C Use additional workspace. +C + DO 100 J = 1, N1 + CALL DCOPY( M1, B1(J,1), LDB1, DWORK(M1*M1+1), 1 ) + CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, + $ DWORK(M1*M1+1), 1, ZERO, B(J,1), LDB ) + 100 CONTINUE +C + END IF + ELSE + CALL DGEMM ( 'No transpose', 'No transpose', N1, M1, M1, + $ ONE, B1, LDB1, DWORK, LDWM1, ZERO, B, LDB ) + END IF + END IF +C + IF ( N2.GT.0 ) THEN +C +C Complete matrices B and C. +C + IF ( P1.GT.0 ) THEN + CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, + $ ONE, B2, LDB2, D, LDD, ZERO, B(N1+1,1), LDB ) + CALL DGEMM ( 'No transpose', 'No transpose', P1, N2, M1, + $ -ALPHA, D, LDD, C2, LDC2, ZERO, C(1,N1+1), LDC + $ ) + ELSE IF ( M1.GT.0 ) THEN + CALL DLASET( 'F', N2, M1, ZERO, ZERO, B(N1+1,1), LDB ) + END IF + END IF +C + IF ( N1.GT.0 .AND. P1.GT.0 ) THEN +C +C Form upper left quadrant of A. +C + CALL DGEMM ( 'No transpose', 'No transpose', N1, P1, M1, + $ -ALPHA, B, LDB, D2, LDD2, ZERO, DWORK, N1 ) +C + IF ( LOVER ) THEN + CALL DGEMM ( 'No transpose', 'No transpose', N1, N1, P1, + $ ONE, DWORK, N1, DWORK(LDW), P1, ONE, A, LDA ) + ELSE + CALL DGEMM ( 'No transpose', 'No transpose', N1, N1, P1, + $ ONE, DWORK, N1, C1, LDC1, ONE, A, LDA ) + END IF + END IF +C + IF ( N2.GT.0 ) THEN +C +C Form lower right quadrant of A. +C + CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1+1,N1+1), LDA ) + IF ( M1.GT.0 ) + $ CALL DGEMM ( 'No transpose', 'No transpose', N2, N2, M1, + $ -ALPHA, B(N1+1,1), LDB, C2, LDC2, ONE, + $ A(N1+1,N1+1), LDA ) +C +C Complete the matrix A. +C + CALL DGEMM ( 'No transpose', 'No transpose', N2, N1, P1, + $ ONE, B2, LDB2, C, LDC, ZERO, A(N1+1,1), LDA ) + CALL DGEMM ( 'No transpose', 'No transpose', N1, N2, M1, + $ -ALPHA, B, LDB, C2, LDC2, ZERO, A(1,N1+1), LDA ) + END IF +C + RETURN +C *** Last line of AB05ND *** + END diff --git a/mex/sources/libslicot/AB05OD.f b/mex/sources/libslicot/AB05OD.f new file mode 100644 index 000000000..6eafa6949 --- /dev/null +++ b/mex/sources/libslicot/AB05OD.f @@ -0,0 +1,418 @@ + SUBROUTINE AB05OD( OVER, N1, M1, P1, N2, M2, ALPHA, A1, LDA1, B1, + $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, + $ C2, LDC2, D2, LDD2, N, M, A, LDA, B, LDB, C, + $ LDC, D, LDD, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To obtain the state-space model (A,B,C,D) for rowwise +C concatenation (parallel inter-connection on outputs, with separate +C inputs) of two systems, each given in state-space form. +C +C ARGUMENTS +C +C Mode Parameters +C +C OVER CHARACTER*1 +C Indicates whether the user wishes to overlap pairs of +C arrays, as follows: +C = 'N': Do not overlap; +C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, +C C1 and C, and D1 and D, i.e. the same name is +C effectively used for each pair (for all pairs) +C in the routine call. In this case, setting +C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD +C will give maximum efficiency. +C +C Input/Output Parameters +C +C N1 (input) INTEGER +C The number of state variables in the first system, i.e. +C the order of the matrix A1. N1 >= 0. +C +C M1 (input) INTEGER +C The number of input variables for the first system. +C M1 >= 0. +C +C P1 (input) INTEGER +C The number of output variables from each system. P1 >= 0. +C +C N2 (input) INTEGER +C The number of state variables in the second system, i.e. +C the order of the matrix A2. N2 >= 0. +C +C M2 (input) INTEGER +C The number of input variables for the second system. +C M2 >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C A coefficient multiplying the transfer-function matrix +C (or the output equation) of the second system. +C +C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) +C The leading N1-by-N1 part of this array must contain the +C state transition matrix A1 for the first system. +C +C LDA1 INTEGER +C The leading dimension of array A1. LDA1 >= MAX(1,N1). +C +C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) +C The leading N1-by-M1 part of this array must contain the +C input/state matrix B1 for the first system. +C +C LDB1 INTEGER +C The leading dimension of array B1. LDB1 >= MAX(1,N1). +C +C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) +C The leading P1-by-N1 part of this array must contain the +C state/output matrix C1 for the first system. +C +C LDC1 INTEGER +C The leading dimension of array C1. +C LDC1 >= MAX(1,P1) if N1 > 0. +C LDC1 >= 1 if N1 = 0. +C +C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) +C The leading P1-by-M1 part of this array must contain the +C input/output matrix D1 for the first system. +C +C LDD1 INTEGER +C The leading dimension of array D1. LDD1 >= MAX(1,P1). +C +C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) +C The leading N2-by-N2 part of this array must contain the +C state transition matrix A2 for the second system. +C +C LDA2 INTEGER +C The leading dimension of array A2. LDA2 >= MAX(1,N2). +C +C B2 (input) DOUBLE PRECISION array, dimension (LDB2,M2) +C The leading N2-by-M2 part of this array must contain the +C input/state matrix B2 for the second system. +C +C LDB2 INTEGER +C The leading dimension of array B2. LDB2 >= MAX(1,N2). +C +C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) +C The leading P1-by-N2 part of this array must contain the +C state/output matrix C2 for the second system. +C +C LDC2 INTEGER +C The leading dimension of array C2. +C LDC2 >= MAX(1,P1) if N2 > 0. +C LDC2 >= 1 if N2 = 0. +C +C D2 (input) DOUBLE PRECISION array, dimension (LDD2,M2) +C The leading P1-by-M2 part of this array must contain the +C input/output matrix D2 for the second system. +C +C LDD2 INTEGER +C The leading dimension of array D2. LDD2 >= MAX(1,P1). +C +C N (output) INTEGER +C The number of state variables (N1 + N2) in the connected +C system, i.e. the order of the matrix A, the number of rows +C of B and the number of columns of C. +C +C M (output) INTEGER +C The number of input variables (M1 + M2) for the connected +C system, i.e. the number of columns of B and D. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) +C The leading N-by-N part of this array contains the state +C transition matrix A for the connected system. +C The array A can overlap A1 if OVER = 'O'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N1+N2). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M1+M2) +C The leading N-by-M part of this array contains the +C input/state matrix B for the connected system. +C The array B can overlap B1 if OVER = 'O'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N1+N2). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) +C The leading P1-by-N part of this array contains the +C state/output matrix C for the connected system. +C The array C can overlap C1 if OVER = 'O'. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,P1) if N1+N2 > 0. +C LDC >= 1 if N1+N2 = 0. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M1+M2) +C The leading P1-by-M part of this array contains the +C input/output matrix D for the connected system. +C The array D can overlap D1 if OVER = 'O'. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P1). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C After rowwise concatenation (parallel inter-connection with +C separate inputs) of the two systems, +C +C X1' = A1*X1 + B1*U +C Y1 = C1*X1 + D1*U +C +C X2' = A2*X2 + B2*V +C Y2 = C2*X2 + D2*V +C +C (where ' denotes differentiation with respect to time), +C +C with the output equation for the second system multiplied by a +C scalar alpha, the following state-space model will be obtained: +C +C X' = A*X + B*(U) +C (V) +C +C Y = C*X + D*(U) +C (V) +C +C where matrix A has the form ( A1 0 ), +C ( 0 A2 ) +C +C matrix B has the form ( B1 0 ), +C ( 0 B2 ) +C +C matrix C has the form ( C1 alpha*C2 ) and +C +C matrix D has the form ( D1 alpha*D2 ). +C +C REFERENCES +C +C None +C +C NUMERICAL ASPECTS +C +C None +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1996. +C Supersedes Release 2.0 routine AB05CD by C.J.Benson, Kingston +C Polytechnic, United Kingdom, January 1982. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 2003, +C Feb. 2004. +C +C KEYWORDS +C +C Continuous-time system, multivariable system, state-space model, +C state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER OVER + INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, + $ LDC1, LDC2, LDD, LDD1, LDD2, M, M1, M2, N, N1, + $ N2, P1 + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), + $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), + $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*) +C .. Local Scalars .. + LOGICAL LOVER + INTEGER I, J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DLASCL, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + LOVER = LSAME( OVER, 'O' ) + N = N1 + N2 + M = M1 + M2 + INFO = 0 +C +C Test the input scalar arguments. +C + IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN + INFO = -1 + ELSE IF( N1.LT.0 ) THEN + INFO = -2 + ELSE IF( M1.LT.0 ) THEN + INFO = -3 + ELSE IF( P1.LT.0 ) THEN + INFO = -4 + ELSE IF( N2.LT.0 ) THEN + INFO = -5 + ELSE IF( M2.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN + INFO = -9 + ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN + INFO = -11 + ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. + $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN + INFO = -13 + ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN + INFO = -15 + ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN + INFO = -17 + ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN + INFO = -19 + ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P1 ) ) .OR. + $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN + INFO = -21 + ELSE IF( LDD2.LT.MAX( 1, P1 ) ) THEN + INFO = -23 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -27 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -29 + ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P1 ) ) .OR. + $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN + INFO = -31 + ELSE IF( LDD.LT.MAX( 1, P1 ) ) THEN + INFO = -33 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB05OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, MIN( M, P1 ) ).EQ.0 ) + $ RETURN +C +C First form the matrix A. +C + IF ( LOVER .AND. LDA1.LE.LDA ) THEN + IF ( LDA1.LT.LDA ) THEN +C + DO 20 J = N1, 1, -1 + DO 10 I = N1, 1, -1 + A(I,J) = A1(I,J) + 10 CONTINUE + 20 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) + END IF +C + IF ( N2.GT.0 ) THEN + CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1+1,N1+1), LDA ) + CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(1,N1+1), LDA ) + CALL DLASET( 'F', N2, N1, ZERO, ZERO, A(N1+1,1), LDA ) + END IF +C +C Now form the matrix B. +C + IF ( LOVER .AND. LDB1.LE.LDB ) THEN + IF ( LDB1.LT.LDB ) THEN +C + DO 40 J = M1, 1, -1 + DO 30 I = N1, 1, -1 + B(I,J) = B1(I,J) + 30 CONTINUE + 40 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, M1, B1, LDB1, B, LDB ) + END IF +C + IF ( M2.GT.0 ) THEN + IF ( N2.GT.0 ) + $ CALL DLACPY( 'F', N2, M2, B2, LDB2, B(N1+1,M1+1), LDB ) + CALL DLASET( 'F', N1, M2, ZERO, ZERO, B(1,M1+1), LDB ) + END IF + IF ( N2.GT.0 ) + $ CALL DLASET( 'F', N2, M1, ZERO, ZERO, B(N1+1,1), LDB ) +C +C Now form the matrix C. +C + IF ( LOVER .AND. LDC1.LE.LDC ) THEN + IF ( LDC1.LT.LDC ) THEN +C + DO 60 J = N1, 1, -1 + DO 50 I = P1, 1, -1 + C(I,J) = C1(I,J) + 50 CONTINUE + 60 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', P1, N1, C1, LDC1, C, LDC ) + END IF +C + IF ( N2.GT.0 ) THEN + CALL DLACPY( 'F', P1, N2, C2, LDC2, C(1,N1+1), LDC ) + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( 'G', 0, 0, ONE, ALPHA, P1, N2, C(1,N1+1), LDC, + $ INFO ) + END IF +C +C Now form the matrix D. +C + IF ( LOVER .AND. LDD1.LE.LDD ) THEN + IF ( LDD1.LT.LDD ) THEN +C + DO 80 J = M1, 1, -1 + DO 70 I = P1, 1, -1 + D(I,J) = D1(I,J) + 70 CONTINUE + 80 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', P1, M1, D1, LDD1, D, LDD ) + END IF +C + IF ( M2.GT.0 ) THEN + CALL DLACPY( 'F', P1, M2, D2, LDD2, D(1,M1+1), LDD ) + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( 'G', 0, 0, ONE, ALPHA, P1, M2, D(1,M1+1), LDD, + $ INFO ) + END IF +C + RETURN +C *** Last line of AB05OD *** + END diff --git a/mex/sources/libslicot/AB05PD.f b/mex/sources/libslicot/AB05PD.f new file mode 100644 index 000000000..918aed8a0 --- /dev/null +++ b/mex/sources/libslicot/AB05PD.f @@ -0,0 +1,385 @@ + SUBROUTINE AB05PD( OVER, N1, M, P, N2, ALPHA, A1, LDA1, B1, LDB1, + $ C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, C2, + $ LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC, D, + $ LDD, INFO) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the state-space model G = (A,B,C,D) corresponding to +C the sum G = G1 + alpha*G2, where G1 = (A1,B1,C1,D1) and +C G2 = (A2,B2,C2,D2). G, G1, and G2 are the transfer-function +C matrices of the corresponding state-space models. +C +C ARGUMENTS +C +C Mode Parameters +C +C OVER CHARACTER*1 +C Indicates whether the user wishes to overlap pairs of +C arrays, as follows: +C = 'N': Do not overlap; +C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, +C C1 and C, and D1 and D, i.e. the same name is +C effectively used for each pair (for all pairs) +C in the routine call. In this case, setting +C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD +C will give maximum efficiency. +C +C Input/Output Parameters +C +C N1 (input) INTEGER +C The number of state variables in the first system, i.e. +C the order of the matrix A1, the number of rows of B1 and +C the number of columns of C1. N1 >= 0. +C +C M (input) INTEGER +C The number of input variables of the two systems, i.e. the +C number of columns of matrices B1, D1, B2 and D2. M >= 0. +C +C P (input) INTEGER +C The number of output variables of the two systems, i.e. +C the number of rows of matrices C1, D1, C2 and D2. P >= 0. +C +C N2 (input) INTEGER +C The number of state variables in the second system, i.e. +C the order of the matrix A2, the number of rows of B2 and +C the number of columns of C2. N2 >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The coefficient multiplying G2. +C +C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) +C The leading N1-by-N1 part of this array must contain the +C state transition matrix A1 for the first system. +C +C LDA1 INTEGER +C The leading dimension of array A1. LDA1 >= MAX(1,N1). +C +C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M) +C The leading N1-by-M part of this array must contain the +C input/state matrix B1 for the first system. +C +C LDB1 INTEGER +C The leading dimension of array B1. LDB1 >= MAX(1,N1). +C +C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) +C The leading P-by-N1 part of this array must contain the +C state/output matrix C1 for the first system. +C +C LDC1 INTEGER +C The leading dimension of array C1. +C LDC1 >= MAX(1,P) if N1 > 0. +C LDC1 >= 1 if N1 = 0. +C +C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M) +C The leading P-by-M part of this array must contain the +C input/output matrix D1 for the first system. +C +C LDD1 INTEGER +C The leading dimension of array D1. LDD1 >= MAX(1,P). +C +C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) +C The leading N2-by-N2 part of this array must contain the +C state transition matrix A2 for the second system. +C +C LDA2 INTEGER +C The leading dimension of array A2. LDA2 >= MAX(1,N2). +C +C B2 (input) DOUBLE PRECISION array, dimension (LDB2,M) +C The leading N2-by-M part of this array must contain the +C input/state matrix B2 for the second system. +C +C LDB2 INTEGER +C The leading dimension of array B2. LDB2 >= MAX(1,N2). +C +C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) +C The leading P-by-N2 part of this array must contain the +C state/output matrix C2 for the second system. +C +C LDC2 INTEGER +C The leading dimension of array C2. +C LDC2 >= MAX(1,P) if N2 > 0. +C LDC2 >= 1 if N2 = 0. +C +C D2 (input) DOUBLE PRECISION array, dimension (LDD2,M) +C The leading P-by-M part of this array must contain the +C input/output matrix D2 for the second system. +C +C LDD2 INTEGER +C The leading dimension of array D2. LDD2 >= MAX(1,P). +C +C N (output) INTEGER +C The number of state variables (N1 + N2) in the resulting +C system, i.e. the order of the matrix A, the number of rows +C of B and the number of columns of C. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) +C The leading N-by-N part of this array contains the state +C transition matrix A for the resulting system. +C The array A can overlap A1 if OVER = 'O'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N1+N2). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array contains the +C input/state matrix B for the resulting system. +C The array B can overlap B1 if OVER = 'O'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N1+N2). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) +C The leading P-by-N part of this array contains the +C state/output matrix C for the resulting system. +C The array C can overlap C1 if OVER = 'O'. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,P) if N1+N2 > 0. +C LDC >= 1 if N1+N2 = 0. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array contains the +C input/output matrix D for the resulting system. +C The array D can overlap D1 if OVER = 'O'. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrices of the resulting systems are determined as: +C +C ( A1 0 ) ( B1 ) +C A = ( ) , B = ( ) , +C ( 0 A2 ) ( B2 ) +C +C C = ( C1 alpha*C2 ) , D = D1 + alpha*D2 . +C +C REFERENCES +C +C None +C +C NUMERICAL ASPECTS +C +C None +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Research Establishment, +C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, +C Belgium, Nov. 1996. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 2003, +C Feb. 2004. +C +C KEYWORDS +C +C Multivariable system, state-space model, state-space +C representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO=0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER OVER + INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, + $ LDC1, LDC2, LDD, LDD1, LDD2, M, N, N1, N2, P + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), + $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), + $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*) +C .. Local Scalars .. + LOGICAL LOVER + INTEGER I, J, N1P1 +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DLACPY, DLASCL, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + LOVER = LSAME( OVER, 'O' ) + N = N1 + N2 + INFO = 0 +C +C Test the input scalar arguments. +C + IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN + INFO = -1 + ELSE IF( N1.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( N2.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN + INFO = -8 + ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN + INFO = -10 + ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P ) ) .OR. + $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN + INFO = -12 + ELSE IF( LDD1.LT.MAX( 1, P ) ) THEN + INFO = -14 + ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN + INFO = -16 + ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN + INFO = -18 + ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P ) ) .OR. + $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN + INFO = -20 + ELSE IF( LDD2.LT.MAX( 1, P ) ) THEN + INFO = -22 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -25 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -27 + ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P ) ) .OR. + $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN + INFO = -29 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -31 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB05PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, MIN( M, P ) ).EQ.0 ) + $ RETURN +C + N1P1 = N1 + 1 +C +C ( A1 0 ) +C Construct A = ( ) . +C ( 0 A2 ) +C + IF ( LOVER .AND. LDA1.LE.LDA ) THEN + IF ( LDA1.LT.LDA ) THEN +C + DO 20 J = N1, 1, -1 + DO 10 I = N1, 1, -1 + A(I,J) = A1(I,J) + 10 CONTINUE + 20 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) + END IF +C + IF ( N2.GT.0 ) THEN + CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(1,N1P1), LDA ) + CALL DLASET( 'F', N2, N1, ZERO, ZERO, A(N1P1,1), LDA ) + CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1P1,N1P1), LDA ) + END IF +C +C ( B1 ) +C Construct B = ( ) . +C ( B2 ) +C + IF ( LOVER .AND. LDB1.LE.LDB ) THEN + IF ( LDB1.LT.LDB ) THEN +C + DO 40 J = M, 1, -1 + DO 30 I = N1, 1, -1 + B(I,J) = B1(I,J) + 30 CONTINUE + 40 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, M, B1, LDB1, B, LDB ) + END IF +C + IF ( N2.GT.0 ) + $ CALL DLACPY( 'F', N2, M, B2, LDB2, B(N1P1,1), LDB ) +C +C Construct C = ( C1 alpha*C2 ) . +C + IF ( LOVER .AND. LDC1.LE.LDC ) THEN + IF ( LDC1.LT.LDC ) THEN +C + DO 60 J = N1, 1, -1 + DO 50 I = P, 1, -1 + C(I,J) = C1(I,J) + 50 CONTINUE + 60 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', P, N1, C1, LDC1, C, LDC ) + END IF +C + IF ( N2.GT.0 ) THEN + CALL DLACPY( 'F', P, N2, C2, LDC2, C(1,N1P1), LDC ) + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( 'G', 0, 0, ONE, ALPHA, P, N2, C(1,N1P1), LDC, + $ INFO ) + END IF +C +C Construct D = D1 + alpha*D2 . +C + IF ( LOVER .AND. LDD1.LE.LDD ) THEN + IF ( LDD1.LT.LDD ) THEN +C + DO 80 J = M, 1, -1 + DO 70 I = P, 1, -1 + D(I,J) = D1(I,J) + 70 CONTINUE + 80 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', P, M, D1, LDD1, D, LDD ) + END IF +C + DO 90 J = 1, M + CALL DAXPY( P, ALPHA, D2(1,J), 1, D(1,J), 1 ) + 90 CONTINUE +C + RETURN +C *** Last line of AB05PD *** + END diff --git a/mex/sources/libslicot/AB05QD.f b/mex/sources/libslicot/AB05QD.f new file mode 100644 index 000000000..c9f54bcaa --- /dev/null +++ b/mex/sources/libslicot/AB05QD.f @@ -0,0 +1,419 @@ + SUBROUTINE AB05QD( OVER, N1, M1, P1, N2, M2, P2, A1, LDA1, B1, + $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, + $ C2, LDC2, D2, LDD2, N, M, P, A, LDA, B, LDB, + $ C, LDC, D, LDD, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To append two systems G1 and G2 in state-space form together. +C If G1 = (A1,B1,C1,D1) and G2 = (A2,B2,C2,D2) are the state-space +C models of the given two systems having the transfer-function +C matrices G1 and G2, respectively, this subroutine constructs the +C state-space model G = (A,B,C,D) which corresponds to the +C transfer-function matrix +C +C ( G1 0 ) +C G = ( ) +C ( 0 G2 ) +C +C ARGUMENTS +C +C Mode Parameters +C +C OVER CHARACTER*1 +C Indicates whether the user wishes to overlap pairs of +C arrays, as follows: +C = 'N': Do not overlap; +C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, +C C1 and C, and D1 and D, i.e. the same name is +C effectively used for each pair (for all pairs) +C in the routine call. In this case, setting +C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD +C will give maximum efficiency. +C +C Input/Output Parameters +C +C N1 (input) INTEGER +C The number of state variables in the first system, i.e. +C the order of the matrix A1, the number of rows of B1 and +C the number of columns of C1. N1 >= 0. +C +C M1 (input) INTEGER +C The number of input variables in the first system, i.e. +C the number of columns of matrices B1 and D1. M1 >= 0. +C +C P1 (input) INTEGER +C The number of output variables in the first system, i.e. +C the number of rows of matrices C1 and D1. P1 >= 0. +C +C N2 (input) INTEGER +C The number of state variables in the second system, i.e. +C the order of the matrix A2, the number of rows of B2 and +C the number of columns of C2. N2 >= 0. +C +C M2 (input) INTEGER +C The number of input variables in the second system, i.e. +C the number of columns of matrices B2 and D2. M2 >= 0. +C +C P2 (input) INTEGER +C The number of output variables in the second system, i.e. +C the number of rows of matrices C2 and D2. P2 >= 0. +C +C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) +C The leading N1-by-N1 part of this array must contain the +C state transition matrix A1 for the first system. +C +C LDA1 INTEGER +C The leading dimension of array A1. LDA1 >= MAX(1,N1). +C +C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) +C The leading N1-by-M1 part of this array must contain the +C input/state matrix B1 for the first system. +C +C LDB1 INTEGER +C The leading dimension of array B1. LDB1 >= MAX(1,N1). +C +C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) +C The leading P1-by-N1 part of this array must contain the +C state/output matrix C1 for the first system. +C +C LDC1 INTEGER +C The leading dimension of array C1. +C LDC1 >= MAX(1,P1) if N1 > 0. +C LDC1 >= 1 if N1 = 0. +C +C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) +C The leading P1-by-M1 part of this array must contain the +C input/output matrix D1 for the first system. +C +C LDD1 INTEGER +C The leading dimension of array D1. LDD1 >= MAX(1,P1). +C +C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) +C The leading N2-by-N2 part of this array must contain the +C state transition matrix A2 for the second system. +C +C LDA2 INTEGER +C The leading dimension of array A2. LDA2 >= MAX(1,N2). +C +C B2 (input) DOUBLE PRECISION array, dimension (LDB2,M2) +C The leading N2-by-M2 part of this array must contain the +C input/state matrix B2 for the second system. +C +C LDB2 INTEGER +C The leading dimension of array B2. LDB2 >= MAX(1,N2). +C +C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) +C The leading P2-by-N2 part of this array must contain the +C state/output matrix C2 for the second system. +C +C LDC2 INTEGER +C The leading dimension of array C2. +C LDC2 >= MAX(1,P2) if N2 > 0. +C LDC2 >= 1 if N2 = 0. +C +C D2 (input) DOUBLE PRECISION array, dimension (LDD2,M2) +C The leading P2-by-M2 part of this array must contain the +C input/output matrix D2 for the second system. +C +C LDD2 INTEGER +C The leading dimension of array D2. LDD2 >= MAX(1,P2). +C +C N (output) INTEGER +C The number of state variables (N1 + N2) in the resulting +C system, i.e. the order of the matrix A, the number of rows +C of B and the number of columns of C. +C +C M (output) INTEGER +C The number of input variables (M1 + M2) in the resulting +C system, i.e. the number of columns of B and D. +C +C P (output) INTEGER +C The number of output variables (P1 + P2) of the resulting +C system, i.e. the number of rows of C and D. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) +C The leading N-by-N part of this array contains the state +C transition matrix A for the resulting system. +C The array A can overlap A1 if OVER = 'O'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N1+N2). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M1+M2) +C The leading N-by-M part of this array contains the +C input/state matrix B for the resulting system. +C The array B can overlap B1 if OVER = 'O'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N1+N2). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) +C The leading P-by-N part of this array contains the +C state/output matrix C for the resulting system. +C The array C can overlap C1 if OVER = 'O'. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,P1+P2) if N1+N2 > 0. +C LDC >= 1 if N1+N2 = 0. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M1+M2) +C The leading P-by-M part of this array contains the +C input/output matrix D for the resulting system. +C The array D can overlap D1 if OVER = 'O'. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P1+P2). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrices of the resulting systems are determined as: +C +C ( A1 0 ) ( B1 0 ) +C A = ( ) , B = ( ) , +C ( 0 A2 ) ( 0 B2 ) +C +C ( C1 0 ) ( D1 0 ) +C C = ( ) , D = ( ) . +C ( 0 C2 ) ( 0 D2 ) +C +C REFERENCES +C +C None +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Research Establishment, +C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, +C Belgium, Nov. 1996. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. +C +C KEYWORDS +C +C Multivariable system, state-space model, state-space +C representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO=0.0D0 ) +C .. Scalar Arguments .. + CHARACTER OVER + INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, + $ LDC1, LDC2, LDD, LDD1, LDD2, M, M1, M2, N, N1, + $ N2, P, P1, P2 +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), + $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), + $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*) +C .. Local Scalars .. + LOGICAL LOVER + INTEGER I, J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + LOVER = LSAME( OVER, 'O' ) + N = N1 + N2 + M = M1 + M2 + P = P1 + P2 + INFO = 0 +C +C Test the input scalar arguments. +C + IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN + INFO = -1 + ELSE IF( N1.LT.0 ) THEN + INFO = -2 + ELSE IF( M1.LT.0 ) THEN + INFO = -3 + ELSE IF( P1.LT.0 ) THEN + INFO = -4 + ELSE IF( N2.LT.0 ) THEN + INFO = -5 + ELSE IF( M2.LT.0 ) THEN + INFO = -6 + ELSE IF( P2.LT.0 ) THEN + INFO = -7 + ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN + INFO = -9 + ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN + INFO = -11 + ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. + $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN + INFO = -13 + ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN + INFO = -15 + ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN + INFO = -17 + ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN + INFO = -19 + ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P2 ) ) .OR. + $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN + INFO = -21 + ELSE IF( LDD2.LT.MAX( 1, P2 ) ) THEN + INFO = -23 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -28 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -30 + ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P ) ) .OR. + $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN + INFO = -32 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -34 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB05QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, MIN( M, P ) ).EQ.0 ) + $ RETURN +C ( A1 0 ) +C Construct A = ( ) . +C ( 0 A2 ) +C + IF ( LOVER .AND. LDA1.LE.LDA ) THEN + IF ( LDA1.LT.LDA ) THEN +C + DO 20 J = N1, 1, -1 + DO 10 I = N1, 1, -1 + A(I,J) = A1(I,J) + 10 CONTINUE + 20 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) + END IF +C + IF ( N2.GT.0 ) THEN + CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(1,N1+1), LDA ) + CALL DLASET( 'F', N2, N1, ZERO, ZERO, A(N1+1,1), LDA ) + CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1+1,N1+1), LDA ) + END IF +C +C ( B1 0 ) +C Construct B = ( ) . +C ( 0 B2 ) +C + IF ( LOVER .AND. LDB1.LE.LDB ) THEN + IF ( LDB1.LT.LDB ) THEN +C + DO 40 J = M1, 1, -1 + DO 30 I = N1, 1, -1 + B(I,J) = B1(I,J) + 30 CONTINUE + 40 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, M1, B1, LDB1, B, LDB ) + END IF +C + IF ( M2.GT.0 ) + $ CALL DLASET( 'F', N1, M2, ZERO, ZERO, B(1,M1+1), LDB ) + IF ( N2.GT.0 ) THEN + CALL DLASET( 'F', N2, M1, ZERO, ZERO, B(N1+1,1), LDB ) + IF ( M2.GT.0 ) + $ CALL DLACPY( 'F', N2, M2, B2, LDB2, B(N1+1,M1+1), LDB ) + END IF +C +C ( C1 0 ) +C Construct C = ( ) . +C ( 0 C2 ) +C + IF ( LOVER .AND. LDC1.LE.LDC ) THEN + IF ( LDC1.LT.LDC ) THEN +C + DO 60 J = N1, 1, -1 + DO 50 I = P1, 1, -1 + C(I,J) = C1(I,J) + 50 CONTINUE + 60 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', P1, N1, C1, LDC1, C, LDC ) + END IF +C + IF ( N2.GT.0 ) + $ CALL DLASET( 'F', P1, N2, ZERO, ZERO, C(1,N1+1), LDC ) + IF ( P2.GT.0 ) THEN + IF ( N1.GT.0 ) + $ CALL DLASET( 'F', P2, N1, ZERO, ZERO, C(P1+1,1), LDC ) + IF ( N2.GT.0 ) + $ CALL DLACPY( 'F', P2, N2, C2, LDC2, C(P1+1,N1+1), LDC ) + END IF +C +C ( D1 0 ) +C Construct D = ( ) . +C ( 0 D2 ) +C + IF ( LOVER .AND. LDD1.LE.LDD ) THEN + IF ( LDD1.LT.LDD ) THEN +C + DO 80 J = M1, 1, -1 + DO 70 I = P1, 1, -1 + D(I,J) = D1(I,J) + 70 CONTINUE + 80 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', P1, M1, D1, LDD1, D, LDD ) + END IF +C + IF ( M2.GT.0 ) + $ CALL DLASET( 'F', P1, M2, ZERO, ZERO, D(1,M1+1), LDD ) + IF ( P2.GT.0 ) THEN + CALL DLASET( 'F', P2, M1, ZERO, ZERO, D(P1+1,1), LDD ) + IF ( M2.GT.0 ) + $ CALL DLACPY( 'F', P2, M2, D2, LDD2, D(P1+1,M1+1), LDD ) + END IF +C + RETURN +C *** Last line of AB05QD *** + END diff --git a/mex/sources/libslicot/AB05RD.f b/mex/sources/libslicot/AB05RD.f new file mode 100644 index 000000000..4592f93d3 --- /dev/null +++ b/mex/sources/libslicot/AB05RD.f @@ -0,0 +1,393 @@ + SUBROUTINE AB05RD( FBTYPE, JOBD, N, M, P, MV, PZ, ALPHA, BETA, A, + $ LDA, B, LDB, C, LDC, D, LDD, F, LDF, K, LDK, + $ G, LDG, H, LDH, RCOND, BC, LDBC, CC, LDCC, + $ DC, LDDC, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct for a given state space system (A,B,C,D) the closed- +C loop system (Ac,Bc,Cc,Dc) corresponding to the mixed output and +C state feedback control law +C +C u = alpha*F*y + beta*K*x + G*v +C z = H*y. +C +C ARGUMENTS +C +C Mode Parameters +C +C FBTYPE CHARACTER*1 +C Specifies the type of the feedback law as follows: +C = 'I': Unitary output feedback (F = I); +C = 'O': General output feedback. +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears +C in the given state space model: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of state vector x, i.e. the order of the +C matrix A, the number of rows of B and the number of +C columns of C. N >= 0. +C +C M (input) INTEGER +C The dimension of input vector u, i.e. the number of +C columns of matrices B and D, and the number of rows of F. +C M >= 0. +C +C P (input) INTEGER +C The dimension of output vector y, i.e. the number of rows +C of matrices C and D, and the number of columns of F. +C P >= 0 and P = M if FBTYPE = 'I'. +C +C MV (input) INTEGER +C The dimension of the new input vector v, i.e. the number +C of columns of matrix G. MV >= 0. +C +C PZ (input) INTEGER. +C The dimension of the new output vector z, i.e. the number +C of rows of matrix H. PZ >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The coefficient alpha in the output feedback law. +C +C BETA (input) DOUBLE PRECISION. +C The coefficient beta in the state feedback law. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the system state transition matrix A. +C On exit, the leading N-by-N part of this array contains +C the state matrix Ac of the closed-loop system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the system input matrix B. +C On exit, the leading N-by-M part of this array contains +C the intermediary input matrix B1 (see METHOD). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the system output matrix C. +C On exit, the leading P-by-N part of this array contains +C the intermediary output matrix C1+BETA*D1*K (see METHOD). +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,P) if N > 0. +C LDC >= 1 if N = 0. +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, if JOBD = 'D', the leading P-by-M part of this +C array must contain the system direct input/output +C transmission matrix D. +C On exit, the leading P-by-M part of this array contains +C the intermediary direct input/output transmission matrix +C D1 (see METHOD). +C The array D is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P) if JOBD = 'D'. +C LDD >= 1 if JOBD = 'Z'. +C +C F (input) DOUBLE PRECISION array, dimension (LDF,P) +C If FBTYPE = 'O', the leading M-by-P part of this array +C must contain the output feedback matrix F. +C If FBTYPE = 'I', then the feedback matrix is assumed to be +C an M x M order identity matrix. +C The array F is not referenced if FBTYPE = 'I' or +C ALPHA = 0. +C +C LDF INTEGER +C The leading dimension of array F. +C LDF >= MAX(1,M) if FBTYPE = 'O' and ALPHA <> 0. +C LDF >= 1 if FBTYPE = 'I' or ALPHA = 0. +C +C K (input) DOUBLE PRECISION array, dimension (LDK,N) +C The leading M-by-N part of this array must contain the +C state feedback matrix K. +C The array K is not referenced if BETA = 0. +C +C LDK INTEGER +C The leading dimension of the array K. +C LDK >= MAX(1,M) if BETA <> 0. +C LDK >= 1 if BETA = 0. +C +C G (input) DOUBLE PRECISION array, dimension (LDG,MV) +C The leading M-by-MV part of this array must contain the +C system input scaling matrix G. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= MAX(1,M). +C +C H (input) DOUBLE PRECISION array, dimension (LDH,P) +C The leading PZ-by-P part of this array must contain the +C system output scaling matrix H. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= MAX(1,PZ). +C +C RCOND (output) DOUBLE PRECISION +C The reciprocal condition number of the matrix +C I - alpha*D*F. +C +C BC (output) DOUBLE PRECISION array, dimension (LDBC,MV) +C The leading N-by-MV part of this array contains the input +C matrix Bc of the closed-loop system. +C +C LDBC INTEGER +C The leading dimension of array BC. LDBC >= MAX(1,N). +C +C CC (output) DOUBLE PRECISION array, dimension (LDCC,N) +C The leading PZ-by-N part of this array contains the +C system output matrix Cc of the closed-loop system. +C +C LDCC INTEGER +C The leading dimension of array CC. +C LDCC >= MAX(1,PZ) if N > 0. +C LDCC >= 1 if N = 0. +C +C DC (output) DOUBLE PRECISION array, dimension (LDDC,MV) +C If JOBD = 'D', the leading PZ-by-MV part of this array +C contains the direct input/output transmission matrix Dc +C of the closed-loop system. +C The array DC is not referenced if JOBD = 'Z'. +C +C LDDC INTEGER +C The leading dimension of array DC. +C LDDC >= MAX(1,PZ) if JOBD = 'D'. +C LDDC >= 1 if JOBD = 'Z'. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK >= MAX(1,2*P) if JOBD = 'D'. +C LIWORK >= 1 if JOBD = 'Z'. +C IWORK is not referenced if JOBD = 'Z'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= wspace, where +C wspace = MAX( 1, M, P*MV, P*P + 4*P ) if JOBD = 'D', +C wspace = MAX( 1, M ) if JOBD = 'Z'. +C For best performance, LDWORK >= MAX( wspace, N*M, N*P ). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix I - alpha*D*F is numerically singular. +C +C METHOD +C +C The matrices of the closed-loop system have the expressions: +C +C Ac = A1 + beta*B1*K, Bc = B1*G, +C Cc = H*(C1 + beta*D1*K), Dc = H*D1*G, +C +C where +C +C A1 = A + alpha*B*F*E*C, B1 = B + alpha*B*F*E*D, +C C1 = E*C, D1 = E*D, +C +C with E = (I - alpha*D*F)**-1. +C +C NUMERICAL ASPECTS +C +C The accuracy of computations basically depends on the conditioning +C of the matrix I - alpha*D*F. If RCOND is very small, it is likely +C that the computed results are inaccurate. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Research Establishment, +C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, +C Belgium, Nov. 1996. +C +C REVISIONS +C +C January 14, 1997, February 18, 1998. +C V. Sima, Research Institute for Informatics, Bucharest, July 2003, +C Jan. 2005. +C +C KEYWORDS +C +C Multivariable system, state-space model, state-space +C representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER FBTYPE, JOBD + INTEGER INFO, LDA, LDB, LDBC, LDC, LDCC, LDD, LDDC, + $ LDF, LDG, LDH, LDK, LDWORK, M, MV, N, P, PZ + DOUBLE PRECISION ALPHA, BETA, RCOND +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), BC(LDBC,*), C(LDC,*), + $ CC(LDCC,*), D(LDD,*), DC(LDDC,*), DWORK(*), + $ F(LDF,*), G(LDG,*), H(LDH,*), K(LDK,*) +C .. Local Scalars .. + LOGICAL LJOBD, OUTPF, UNITF + INTEGER LDWP +C .. External functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External subroutines .. + EXTERNAL AB05SD, DGEMM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Check the input scalar arguments. +C + UNITF = LSAME( FBTYPE, 'I' ) + OUTPF = LSAME( FBTYPE, 'O' ) + LJOBD = LSAME( JOBD, 'D' ) +C + INFO = 0 +C + IF( .NOT.UNITF .AND. .NOT.OUTPF ) THEN + INFO = -1 + ELSE IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 .OR. UNITF.AND.P.NE.M ) THEN + INFO = -5 + ELSE IF( MV.LT.0 ) THEN + INFO = -6 + ELSE IF( PZ.LT.0 ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P ) ) .OR. + $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN + INFO = -15 + ELSE IF( ( LJOBD .AND. LDD.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN + INFO = -17 + ELSE IF( ( OUTPF .AND. ALPHA.NE.ZERO .AND. LDF.LT.MAX( 1, M ) ) + $ .OR. ( ( UNITF .OR. ALPHA.EQ.ZERO ) .AND. LDF.LT.1 ) ) THEN + INFO = -19 + ELSE IF( ( BETA.NE.ZERO .AND. LDK.LT.MAX( 1, M ) ) .OR. + $ ( BETA.EQ.ZERO .AND. LDK.LT.1 ) ) THEN + INFO = -21 + ELSE IF( LDG.LT.MAX( 1, M ) ) THEN + INFO = -23 + ELSE IF( LDH.LT.MAX( 1, PZ ) ) THEN + INFO = -25 + ELSE IF( LDBC.LT.MAX( 1, N ) ) THEN + INFO = -28 + ELSE IF( ( N.GT.0 .AND. LDCC.LT.MAX( 1, PZ ) ) .OR. + $ ( N.EQ.0 .AND. LDCC.LT.1 ) ) THEN + INFO = -30 + ELSE IF( ( ( LJOBD .AND. LDDC.LT.MAX( 1, PZ ) ) .OR. + $ ( .NOT.LJOBD .AND. LDDC.LT.1 ) ) ) THEN + INFO = -32 + ELSE IF( ( LJOBD .AND. LDWORK.LT.MAX( 1, M, P*MV, P*P + 4*P ) ) + $ .OR. ( .NOT.LJOBD .AND. LDWORK.LT.MAX( 1, M ) ) ) THEN + INFO = -35 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB05RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, MIN( M, P ), MIN( MV, PZ ) ).EQ.0 ) THEN + RCOND = ONE + RETURN + END IF +C +C Apply the partial output feedback u = alpha*F*y + v1 +C + CALL AB05SD( FBTYPE, JOBD, N, M, P, ALPHA, A, LDA, B, LDB, C, + $ LDC, D, LDD, F, LDF, RCOND, IWORK, DWORK, LDWORK, + $ INFO ) + IF ( INFO.NE.0 ) RETURN +C +C Apply the partial state feedback v1 = beta*K*x + v2. +C +C Compute Ac = A1 + beta*B1*K and C1 <- C1 + beta*D1*K. +C + IF( BETA.NE.ZERO .AND. N.GT.0 ) THEN + CALL DGEMM( 'N', 'N', N, N, M, BETA, B, LDB, K, LDK, ONE, A, + $ LDA ) + IF( LJOBD ) + $ CALL DGEMM( 'N', 'N', P, N, M, BETA, D, LDD, K, LDK, ONE, + $ C, LDC ) + END IF +C +C Apply the input and output conversions v2 = G*v, z = H*y. +C +C Compute Bc = B1*G. +C + CALL DGEMM( 'N', 'N', N, MV, M, ONE, B, LDB, G, LDG, ZERO, BC, + $ LDBC ) +C +C Compute Cc = H*C1. +C + IF( N.GT.0 ) + $ CALL DGEMM( 'N', 'N', PZ, N, P, ONE, H, LDH, C, LDC, ZERO, CC, + $ LDCC ) +C +C Compute Dc = H*D1*G. +C + IF( LJOBD ) THEN + LDWP = MAX( 1, P ) + CALL DGEMM( 'N', 'N', P, MV, M, ONE, D, LDD, G, LDG, ZERO, + $ DWORK, LDWP ) + CALL DGEMM( 'N', 'N', PZ, MV, P, ONE, H, LDH, DWORK, LDWP, + $ ZERO, DC, LDDC ) + END IF +C + RETURN +C *** Last line of AB05RD *** + END diff --git a/mex/sources/libslicot/AB05SD.f b/mex/sources/libslicot/AB05SD.f new file mode 100644 index 000000000..7cc57b5c7 --- /dev/null +++ b/mex/sources/libslicot/AB05SD.f @@ -0,0 +1,371 @@ + SUBROUTINE AB05SD( FBTYPE, JOBD, N, M, P, ALPHA, A, LDA, B, LDB, + $ C, LDC, D, LDD, F, LDF, RCOND, IWORK, DWORK, + $ LDWORK, INFO) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct for a given state space system (A,B,C,D) the closed- +C loop system (Ac,Bc,Cc,Dc) corresponding to the output feedback +C control law +C +C u = alpha*F*y + v. +C +C ARGUMENTS +C +C Mode Parameters +C +C FBTYPE CHARACTER*1 +C Specifies the type of the feedback law as follows: +C = 'I': Unitary output feedback (F = I); +C = 'O': General output feedback. +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears in +C the given state space model: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of state variables, i.e. the order of the +C matrix A, the number of rows of B and the number of +C columns of C. N >= 0. +C +C M (input) INTEGER +C The number of input variables, i.e. the number of columns +C of matrices B and D, and the number of rows of F. M >= 0. +C +C P (input) INTEGER +C The number of output variables, i.e. the number of rows of +C matrices C and D, and the number of columns of F. P >= 0 +C and P = M if FBTYPE = 'I'. +C +C ALPHA (input) DOUBLE PRECISION +C The coefficient alpha in the output feedback law. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the system state transition matrix A. +C On exit, the leading N-by-N part of this array contains +C the state matrix Ac of the closed-loop system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the system input matrix B. +C On exit, the leading N-by-M part of this array contains +C the input matrix Bc of the closed-loop system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the system output matrix C. +C On exit, the leading P-by-N part of this array contains +C the output matrix Cc of the closed-loop system. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,P) if N > 0. +C LDC >= 1 if N = 0. +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the system direct input/output transmission +C matrix D. +C On exit, if JOBD = 'D', the leading P-by-M part of this +C array contains the direct input/output transmission +C matrix Dc of the closed-loop system. +C The array D is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P) if JOBD = 'D'. +C LDD >= 1 if JOBD = 'Z'. +C +C F (input) DOUBLE PRECISION array, dimension (LDF,P) +C If FBTYPE = 'O', the leading M-by-P part of this array +C must contain the output feedback matrix F. +C If FBTYPE = 'I', then the feedback matrix is assumed to be +C an M x M order identity matrix. +C The array F is not referenced if FBTYPE = 'I' or +C ALPHA = 0. +C +C LDF INTEGER +C The leading dimension of array F. +C LDF >= MAX(1,M) if FBTYPE = 'O' and ALPHA <> 0. +C LDF >= 1 if FBTYPE = 'I' or ALPHA = 0. +C +C RCOND (output) DOUBLE PRECISION +C The reciprocal condition number of the matrix +C I - alpha*D*F. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK >= MAX(1,2*P) if JOBD = 'D'. +C LIWORK >= 1 if JOBD = 'Z'. +C IWORK is not referenced if JOBD = 'Z'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= wspace, where +C wspace = MAX( 1, M, P*P + 4*P ) if JOBD = 'D', +C wspace = MAX( 1, M ) if JOBD = 'Z'. +C For best performance, LDWORK >= MAX( wspace, N*M, N*P ). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix I - alpha*D*F is numerically singular. +C +C METHOD +C +C The matrices of the closed-loop system have the expressions: +C +C Ac = A + alpha*B*F*E*C, Bc = B + alpha*B*F*E*D, +C Cc = E*C, Dc = E*D, +C +C where E = (I - alpha*D*F)**-1. +C +C NUMERICAL ASPECTS +C +C The accuracy of computations basically depends on the conditioning +C of the matrix I - alpha*D*F. If RCOND is very small, it is likely +C that the computed results are inaccurate. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Research Establishment, +C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, +C Belgium, Nov. 1996. +C +C REVISIONS +C +C January 14, 1997. +C V. Sima, Research Institute for Informatics, Bucharest, July 2003. +C +C KEYWORDS +C +C Multivariable system, state-space model, state-space +C representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER FBTYPE, JOBD + INTEGER INFO, LDA, LDB, LDC, LDD, LDF, LDWORK, M, N, P + DOUBLE PRECISION ALPHA, RCOND +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), F(LDF,*) +C .. Local Scalars .. + LOGICAL LJOBD, OUTPF, UNITF + INTEGER I, IW, LDWN, LDWP + DOUBLE PRECISION ENORM +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1) +C .. External functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External subroutines .. + EXTERNAL DAXPY, DCOPY, DGECON, DGEMM, DGEMV, DGETRF, + $ DGETRS, DLACPY, DLASCL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Check the input scalar arguments. +C + UNITF = LSAME( FBTYPE, 'I' ) + OUTPF = LSAME( FBTYPE, 'O' ) + LJOBD = LSAME( JOBD, 'D' ) + LDWN = MAX( 1, N ) + LDWP = MAX( 1, P ) +C + INFO = 0 +C + IF( .NOT.UNITF .AND. .NOT.OUTPF ) THEN + INFO = -1 + ELSE IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 .OR. UNITF.AND.P.NE.M ) THEN + INFO = -5 + ELSE IF( LDA.LT.LDWN ) THEN + INFO = -7 + ELSE IF( LDB.LT.LDWN ) THEN + INFO = -9 + ELSE IF( ( N.GT.0 .AND. LDC.LT.LDWP ) .OR. + $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN + INFO = -11 + ELSE IF( ( LJOBD .AND. LDD.LT.LDWP ) .OR. + $ ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN + INFO = -13 + ELSE IF( ( OUTPF .AND. ALPHA.NE.ZERO .AND. LDF.LT.MAX( 1, M ) ) + $ .OR. ( ( UNITF .OR. ALPHA.EQ.ZERO ) .AND. LDF.LT.1 ) ) THEN + INFO = -16 + ELSE IF( ( LJOBD .AND. LDWORK.LT.MAX( 1, M, P*P + 4*P ) ) .OR. + $ ( .NOT.LJOBD .AND. LDWORK.LT.MAX( 1, M ) ) ) THEN + INFO = -20 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB05SD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + RCOND = ONE + IF ( MAX( N, MIN( M, P ) ).EQ.0 .OR. ALPHA.EQ.ZERO ) + $ RETURN +C + IF (LJOBD) THEN + IW = P*P + 1 +C +C Compute I - alpha*D*F. +C + IF( UNITF) THEN + CALL DLACPY( 'F', P, P, D, LDD, DWORK, LDWP ) + IF ( ALPHA.NE.-ONE ) + $ CALL DLASCL( 'G', 0, 0, ONE, -ALPHA, P, P, DWORK, LDWP, + $ INFO ) + ELSE + CALL DGEMM( 'N', 'N', P, P, M, -ALPHA, D, LDD, F, LDF, ZERO, + $ DWORK, LDWP ) + END IF +C + DUMMY(1) = ONE + CALL DAXPY( P, ONE, DUMMY, 0, DWORK, P+1 ) +C +C Compute Cc = E*C, Dc = E*D, where E = (I - alpha*D*F)**-1. +C + ENORM = DLANGE( '1', P, P, DWORK, LDWP, DWORK(IW) ) + CALL DGETRF( P, P, DWORK, LDWP, IWORK, INFO ) + IF( INFO.GT.0 ) THEN +C +C Error return. +C + RCOND = ZERO + INFO = 1 + RETURN + END IF + CALL DGECON( '1', P, DWORK, LDWP, ENORM, RCOND, DWORK(IW), + $ IWORK(P+1), INFO ) + IF( RCOND.LE.DLAMCH('E') ) THEN +C +C Error return. +C + INFO = 1 + RETURN + END IF +C + IF( N.GT.0 ) + $ CALL DGETRS( 'N', P, N, DWORK, LDWP, IWORK, C, LDC, INFO ) + CALL DGETRS( 'N', P, M, DWORK, LDWP, IWORK, D, LDD, INFO ) + END IF +C + IF ( N.EQ.0 ) + $ RETURN +C +C Compute Ac = A + alpha*B*F*Cc and Bc = B + alpha*B*F*Dc. +C + IF( UNITF ) THEN + CALL DGEMM( 'N', 'N', N, N, M, ALPHA, B, LDB, C, LDC, ONE, A, + $ LDA ) + IF( LJOBD ) THEN +C + IF( LDWORK.LT.N*M ) THEN +C +C Not enough working space for using DGEMM. +C + DO 10 I = 1, N + CALL DCOPY( P, B(I,1), LDB, DWORK, 1 ) + CALL DGEMV( 'T', P, P, ALPHA, D, LDD, DWORK, 1, ONE, + $ B(I,1), LDB ) + 10 CONTINUE +C + ELSE + CALL DLACPY( 'F', N, M, B, LDB, DWORK, LDWN ) + CALL DGEMM( 'N', 'N', N, P, M, ALPHA, DWORK, LDWN, D, + $ LDD, ONE, B, LDB ) + END IF + END IF + ELSE +C + IF( LDWORK.LT.N*P ) THEN +C +C Not enough working space for using DGEMM. +C + DO 20 I = 1, N + CALL DGEMV( 'N', M, P, ALPHA, F, LDF, C(1,I), 1, ZERO, + $ DWORK, 1 ) + CALL DGEMV( 'N', N, M, ONE, B, LDB, DWORK, 1, ONE, + $ A(1,I), 1 ) + 20 CONTINUE +C + IF( LJOBD ) THEN +C + DO 30 I = 1, N + CALL DGEMV( 'T', M, P, ALPHA, F, LDF, B(I,1), LDB, + $ ZERO, DWORK, 1 ) + CALL DGEMV( 'T', P, M, ONE, D, LDD, DWORK, 1, ONE, + $ B(I,1), LDB ) + 30 CONTINUE +C + END IF + ELSE +C + CALL DGEMM( 'N', 'N', N, P, M, ALPHA, B, LDB, F, LDF, + $ ZERO, DWORK, LDWN ) + CALL DGEMM( 'N', 'N', N, N, P, ONE, DWORK, LDWN, C, LDC, + $ ONE, A, LDA ) + IF( LJOBD ) + $ CALL DGEMM( 'N', 'N', N, M, P, ONE, DWORK, LDWN, D, LDD, + $ ONE, B, LDB ) + END IF + END IF +C + RETURN +C *** Last line of AB05SD *** + END diff --git a/mex/sources/libslicot/AB07MD.f b/mex/sources/libslicot/AB07MD.f new file mode 100644 index 000000000..da49e2df7 --- /dev/null +++ b/mex/sources/libslicot/AB07MD.f @@ -0,0 +1,224 @@ + SUBROUTINE AB07MD( JOBD, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find the dual of a given state-space representation. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears in +C the given state space model: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading N-by-N part of this array contains +C the dual state dynamics matrix A'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,MAX(M,P)) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, the leading N-by-P part of this array contains +C the dual input/state matrix C'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, the leading M-by-N part of this array contains +C the dual state/output matrix B'. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,M,P) if N > 0. +C LDC >= 1 if N = 0. +C +C D (input/output) DOUBLE PRECISION array, dimension +C (LDD,MAX(M,P)) +C On entry, if JOBD = 'D', the leading P-by-M part of this +C array must contain the original direct transmission +C matrix D. +C On exit, if JOBD = 'D', the leading M-by-P part of this +C array contains the dual direct transmission matrix D'. +C The array D is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,M,P) if JOBD = 'D'. +C LDD >= 1 if JOBD = 'Z'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C If the given state-space representation is the M-input/P-output +C (A,B,C,D), its dual is simply the P-input/M-output (A',C',B',D'). +C +C REFERENCES +C +C None +C +C NUMERICAL ASPECTS +C +C None +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine AB07AD by T.W.C.Williams, Kingston +C Polytechnic, United Kingdom, March 1982. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. +C +C KEYWORDS +C +C Dual system, state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER JOBD + INTEGER INFO, LDA, LDB, LDC, LDD, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*) +C .. Local Scalars .. + LOGICAL LJOBD + INTEGER J, MINMP, MPLIM +C .. External functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External subroutines .. + EXTERNAL DCOPY, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LJOBD = LSAME( JOBD, 'D' ) + MPLIM = MAX( M, P ) + MINMP = MIN( M, P ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, MPLIM ) ) .OR. + $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN + INFO = -10 + ELSE IF( ( LJOBD .AND. LDD.LT.MAX( 1, MPLIM ) ) .OR. + $ ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB07MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, MINMP ).EQ.0 ) + $ RETURN +C + IF ( N.GT.0 ) THEN +C +C Transpose A, if non-scalar. +C + DO 10 J = 1, N - 1 + CALL DSWAP( N-J, A(J+1,J), 1, A(J,J+1), LDA ) + 10 CONTINUE +C +C Replace B by C' and C by B'. +C + DO 20 J = 1, MPLIM + IF ( J.LE.MINMP ) THEN + CALL DSWAP( N, B(1,J), 1, C(J,1), LDC ) + ELSE IF ( J.GT.P ) THEN + CALL DCOPY( N, B(1,J), 1, C(J,1), LDC ) + ELSE + CALL DCOPY( N, C(J,1), LDC, B(1,J), 1 ) + END IF + 20 CONTINUE +C + END IF +C + IF ( LJOBD .AND. MINMP.GT.0 ) THEN +C +C Transpose D, if non-scalar. +C + DO 30 J = 1, MPLIM + IF ( J.LT.MINMP ) THEN + CALL DSWAP( MINMP-J, D(J+1,J), 1, D(J,J+1), LDD ) + ELSE IF ( J.GT.P ) THEN + CALL DCOPY( P, D(1,J), 1, D(J,1), LDD ) + ELSE IF ( J.GT.M ) THEN + CALL DCOPY( M, D(J,1), LDD, D(1,J), 1 ) + END IF + 30 CONTINUE +C + END IF +C + RETURN +C *** Last line of AB07MD *** + END diff --git a/mex/sources/libslicot/AB07ND.f b/mex/sources/libslicot/AB07ND.f new file mode 100644 index 000000000..86b26d27a --- /dev/null +++ b/mex/sources/libslicot/AB07ND.f @@ -0,0 +1,303 @@ + SUBROUTINE AB07ND( N, M, A, LDA, B, LDB, C, LDC, D, LDD, RCOND, + $ IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the inverse (Ai,Bi,Ci,Di) of a given system (A,B,C,D). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs and outputs. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state matrix A of the original system. +C On exit, the leading N-by-N part of this array contains +C the state matrix Ai of the inverse system. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B of the original system. +C On exit, the leading N-by-M part of this array contains +C the input matrix Bi of the inverse system. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the output matrix C of the original system. +C On exit, the leading M-by-N part of this array contains +C the output matrix Ci of the inverse system. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,M). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading M-by-M part of this array must +C contain the feedthrough matrix D of the original system. +C On exit, the leading M-by-M part of this array contains +C the feedthrough matrix Di of the inverse system. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= MAX(1,M). +C +C RCOND (output) DOUBLE PRECISION +C The estimated reciprocal condition number of the +C feedthrough matrix D of the original system. +C +C Workspace +C +C IWORK INTEGER array, dimension (2*M) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or M+1, DWORK(1) returns the optimal +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,4*M). +C For good performance, LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = i: the matrix D is exactly singular; the (i,i) diagonal +C element is zero, i <= M; RCOND was set to zero; +C = M+1: the matrix D is numerically singular, i.e., RCOND +C is less than the relative machine precision, EPS +C (see LAPACK Library routine DLAMCH). The +C calculations have been completed, but the results +C could be very inaccurate. +C +C METHOD +C +C The matrices of the inverse system are computed with the formulas: +C -1 -1 -1 -1 +C Ai = A - B*D *C, Bi = -B*D , Ci = D *C, Di = D . +C +C NUMERICAL ASPECTS +C +C The accuracy depends mainly on the condition number of the matrix +C D to be inverted. The estimated reciprocal condition number is +C returned in RCOND. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2000. +C D. Sima, University of Bucharest, April 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C Based on the routine SYSINV, A. Varga, 1992. +C +C REVISIONS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. +C +C KEYWORDS +C +C Inverse system, state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION RCOND + INTEGER INFO, LDA, LDB, LDC, LDD, LDWORK, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*) + INTEGER IWORK(*) +C .. Local Scalars .. + DOUBLE PRECISION DNORM + INTEGER BL, CHUNK, I, IERR, J, MAXWRK + LOGICAL BLAS3, BLOCK +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE + INTEGER ILAENV + EXTERNAL DLAMCH, DLANGE, ILAENV +C .. External Subroutines .. + EXTERNAL DCOPY, DGECON, DGEMM, DGEMV, DGETRF, DGETRI, + $ DLACPY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDD.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDWORK.LT.MAX( 1, 4*M ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB07ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( M.EQ.0 ) THEN + RCOND = ONE + DWORK(1) = ONE + RETURN + END IF +C +C Factorize D. +C + CALL DGETRF( M, M, D, LDD, IWORK, INFO ) + IF ( INFO.NE.0 ) THEN + RCOND = ZERO + RETURN + END IF +C +C Compute the reciprocal condition number of the matrix D. +C Workspace: need 4*M. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + DNORM = DLANGE( '1-norm', M, M, D, LDD, DWORK ) + CALL DGECON( '1-norm', M, D, LDD, DNORM, RCOND, DWORK, IWORK(M+1), + $ IERR ) + IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) + $ INFO = M + 1 +C -1 +C Compute Di = D . +C Workspace: need M; +C prefer M*NB. +C + MAXWRK = MAX( 4*M, M*ILAENV( 1, 'DGETRI', ' ', M, -1, -1, -1 ) ) + CALL DGETRI( M, D, LDD, IWORK, DWORK, LDWORK, IERR ) + IF ( N.GT.0 ) THEN + CHUNK = LDWORK / M + BLAS3 = CHUNK.GE.N .AND. M.GT.1 + BLOCK = MIN( CHUNK, M ).GT.1 +C -1 +C Compute Bi = -B*D . +C + IF ( BLAS3 ) THEN +C +C Enough workspace for a fast BLAS 3 algorithm. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, M, -ONE, + $ DWORK, N, D, LDD, ZERO, B, LDB ) +C + ELSE IF( BLOCK ) THEN +C +C Use as many rows of B as possible. +C + DO 10 I = 1, N, CHUNK + BL = MIN( N-I+1, CHUNK ) + CALL DLACPY( 'Full', BL, M, B(I,1), LDB, DWORK, BL ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, M, M, -ONE, + $ DWORK, BL, D, LDD, ZERO, B(I,1), LDB ) + 10 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. +C + DO 20 I = 1, N + CALL DCOPY( M, B(I,1), LDB, DWORK, 1 ) + CALL DGEMV( 'Transpose', M, M, -ONE, D, LDD, DWORK, 1, + $ ZERO, B(I,1), LDB ) + 20 CONTINUE +C + END IF +C +C Compute Ai = A + Bi*C. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B, LDB, + $ C, LDC, ONE, A, LDA ) +C -1 +C Compute C <-- D *C. +C + IF ( BLAS3 ) THEN +C +C Enough workspace for a fast BLAS 3 algorithm. +C + CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, ONE, + $ D, LDD, DWORK, M, ZERO, C, LDC ) +C + ELSE IF( BLOCK ) THEN +C +C Use as many columns of C as possible. +C + DO 30 J = 1, N, CHUNK + BL = MIN( N-J+1, CHUNK ) + CALL DLACPY( 'Full', M, BL, C(1,J), LDC, DWORK, M ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, BL, M, ONE, + $ D, LDD, DWORK, M, ZERO, C(1,J), LDC ) + 30 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. +C + DO 40 J = 1, N + CALL DCOPY( M, C(1,J), 1, DWORK, 1 ) + CALL DGEMV( 'NoTranspose', M, M, ONE, D, LDD, DWORK, 1, + $ ZERO, C(1,J), 1 ) + 40 CONTINUE +C + END IF + END IF +C +C Return optimal workspace in DWORK(1). +C + DWORK(1) = DBLE( MAX( MAXWRK, N*M ) ) + RETURN +C +C *** Last line of AB07ND *** + END diff --git a/mex/sources/libslicot/AB08MD.f b/mex/sources/libslicot/AB08MD.f new file mode 100644 index 000000000..bd801a617 --- /dev/null +++ b/mex/sources/libslicot/AB08MD.f @@ -0,0 +1,299 @@ + SUBROUTINE AB08MD( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ RANK, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the normal rank of the transfer-function matrix of a +C state-space model (A,B,C,D). +C +C ARGUMENTS +C +C Mode Parameters +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to balance the compound +C matrix (see METHOD) as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of state variables, i.e., the order of the +C matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state dynamics matrix A of the system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B of the system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C of the system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct transmission matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C RANK (output) INTEGER +C The normal rank of the transfer-function matrix. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS +C then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (2*N+MAX(M,P)+1) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= (N+P)*(N+M) + +C MAX( MIN(P,M) + MAX(3*M-1,N), 1, +C MIN(P,N) + MAX(3*P-1,N+P,N+M) ) +C For optimum performance LDWORK should be larger. +C +C If LDWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C DWORK array, returns this value as the first entry of +C the DWORK array, and no error message related to LDWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine reduces the (N+P)-by-(M+N) compound matrix (B A) +C (D C) +C +C to one with the same invariant zeros and with D of full row rank. +C The normal rank of the transfer-function matrix is the rank of D. +C +C REFERENCES +C +C [1] Svaricek, F. +C Computation of the Structural Invariants of Linear +C Multivariable Systems with an Extended Version of +C the Program ZEROS. +C System & Control Letters, 6, pp. 261-266, 1985. +C +C [2] Emami-Naeini, A. and Van Dooren, P. +C Computation of Zeros of Linear Multivariable Systems. +C Automatica, 18, pp. 415-430, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable (see [2] and [1]). +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001, +C Dec. 2003, Jan. 2009, Mar. 2009, Apr. 2009. +C +C KEYWORDS +C +C Multivariable system, orthogonal transformation, +C structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL + INTEGER INFO, LDA, LDB, LDC, LDD, LDWORK, M, N, P, RANK + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) +C .. Local Scalars .. + LOGICAL LEQUIL, LQUERY + INTEGER I, KW, MU, NB, NINFZ, NKROL, NM, NP, NU, RO, + $ SIGMA, WRKOPT + DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL AB08NX, DLACPY, TB01ID, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + NP = N + P + NM = N + M + INFO = 0 + LEQUIL = LSAME( EQUIL, 'S' ) + LQUERY = ( LDWORK.EQ.-1 ) + WRKOPT = NP*NM +C +C Test the input scalar arguments. +C + IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE + KW = WRKOPT + MAX( MIN( P, M ) + MAX( 3*M-1, N ), 1, + $ MIN( P, N ) + MAX( 3*P-1, NP, NM ) ) + IF( LQUERY ) THEN + SVLMAX = ZERO + NINFZ = 0 + CALL AB08NX( N, M, P, P, 0, SVLMAX, DWORK, MAX( 1, NP ), + $ NINFZ, IWORK, IWORK, MU, NU, NKROL, TOL, IWORK, + $ DWORK, -1, INFO ) + WRKOPT = MAX( KW, WRKOPT + INT( DWORK(1) ) ) + ELSE IF( LDWORK.LT.KW ) THEN + INFO = -17 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB08MD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( M, P ).EQ.0 ) THEN + RANK = 0 + DWORK(1) = ONE + RETURN + END IF +C + DO 10 I = 1, 2*N+1 + IWORK(I) = 0 + 10 CONTINUE +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C +C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). +C ( D C ) +C Workspace: need (N+P)*(N+M). +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, NP ) + CALL DLACPY( 'Full', P, M, D, LDD, DWORK(N+1), NP ) + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(NP*M+1), NP ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(NP*M+N+1), NP ) +C +C If required, balance the compound matrix (default MAXRED). +C Workspace: need N. +C + KW = WRKOPT + 1 + IF ( LEQUIL ) THEN + MAXRED = ZERO + CALL TB01ID( 'A', N, M, P, MAXRED, DWORK(NP*M+1), NP, DWORK, + $ NP, DWORK(NP*M+N+1), NP, DWORK(KW), INFO ) + WRKOPT = WRKOPT + N + END IF +C +C If required, set tolerance. +C + THRESH = SQRT( DBLE( NP*NM ) )*DLAMCH( 'Precision' ) + TOLER = TOL + IF ( TOLER.LT.THRESH ) TOLER = THRESH + SVLMAX = DLANGE( 'Frobenius', NP, NM, DWORK, NP, DWORK(KW) ) +C +C Reduce this system to one with the same invariant zeros and with +C D full row rank MU (the normal rank of the original system). +C Real workspace: need (N+P)*(N+M) + +C MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M) ); +C prefer larger. +C Integer workspace: 2*N+MAX(M,P)+1. +C + RO = P + SIGMA = 0 + NINFZ = 0 + CALL AB08NX( N, M, P, RO, SIGMA, SVLMAX, DWORK, NP, NINFZ, IWORK, + $ IWORK(N+1), MU, NU, NKROL, TOLER, IWORK(2*N+2), + $ DWORK(KW), LDWORK-KW+1, INFO ) + RANK = MU +C + DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + RETURN +C *** Last line of AB08MD *** + END diff --git a/mex/sources/libslicot/AB08MZ.f b/mex/sources/libslicot/AB08MZ.f new file mode 100644 index 000000000..89d8005e7 --- /dev/null +++ b/mex/sources/libslicot/AB08MZ.f @@ -0,0 +1,303 @@ + SUBROUTINE AB08MZ( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ RANK, TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the normal rank of the transfer-function matrix of a +C state-space model (A,B,C,D). +C +C ARGUMENTS +C +C Mode Parameters +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to balance the compound +C matrix (see METHOD) as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of state variables, i.e., the order of the +C matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input) COMPLEX*16 array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state dynamics matrix A of the system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) COMPLEX*16 array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B of the system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) COMPLEX*16 array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C of the system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) COMPLEX*16 array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct transmission matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C RANK (output) INTEGER +C The normal rank of the transfer-function matrix. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS +C then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (2*N+MAX(M,P)+1) +C +C DWORK DOUBLE PRECISION array, dimension (2*MAX(M,P)) +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C On exit, if INFO = 0, ZWORK(1) returns the optimal value +C of LZWORK. +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK >= (N+P)*(N+M) + MAX(MIN(P,M) + MAX(3*M-1,N), 1, +C MIN(P,N) + MAX(3*P-1,N+P,N+M)) +C For optimum performance LZWORK should be larger. +C +C If LZWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C ZWORK array, returns this value as the first entry of +C the ZWORK array, and no error message related to LZWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine reduces the (N+P)-by-(M+N) compound matrix (B A) +C (D C) +C +C to one with the same invariant zeros and with D of full row rank. +C The normal rank of the transfer-function matrix is the rank of D. +C +C REFERENCES +C +C [1] Svaricek, F. +C Computation of the Structural Invariants of Linear +C Multivariable Systems with an Extended Version of +C the Program ZEROS. +C System & Control Letters, 6, pp. 261-266, 1985. +C +C [2] Emami-Naeini, A. and Van Dooren, P. +C Computation of Zeros of Linear Multivariable Systems. +C Automatica, 18, pp. 415-430, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable (see [2] and [1]). +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Dec. 2008. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2009, +C Apr. 2009. +C +C KEYWORDS +C +C Multivariable system, unitary transformation, +C structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL + INTEGER INFO, LDA, LDB, LDC, LDD, LZWORK, M, N, P, RANK + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + COMPLEX*16 A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), ZWORK(*) + DOUBLE PRECISION DWORK(*) +C .. Local Scalars .. + LOGICAL LEQUIL, LQUERY + INTEGER I, KW, MU, NB, NINFZ, NKROL, NM, NP, NU, RO, + $ SIGMA, WRKOPT + DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL DLAMCH, LSAME, ZLANGE +C .. External Subroutines .. + EXTERNAL AB8NXZ, TB01IZ, XERBLA, ZLACPY +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + NP = N + P + NM = N + M + INFO = 0 + LEQUIL = LSAME( EQUIL, 'S' ) + LQUERY = ( LZWORK.EQ.-1 ) + WRKOPT = NP*NM +C +C Test the input scalar arguments. +C + IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE + KW = WRKOPT + MAX( MIN( P, M ) + MAX( 3*M-1, N ), 1, + $ MIN( P, N ) + MAX( 3*P-1, NP, NM ) ) + IF( LQUERY ) THEN + SVLMAX = ZERO + NINFZ = 0 + CALL AB8NXZ( N, M, P, P, 0, SVLMAX, ZWORK, MAX( 1, NP ), + $ NINFZ, IWORK, IWORK, MU, NU, NKROL, TOL, IWORK, + $ DWORK, ZWORK, -1, INFO ) + WRKOPT = MAX( KW, WRKOPT + INT( ZWORK(1) ) ) + ELSE IF( LZWORK.LT.KW ) THEN + INFO = -17 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB08MZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + ZWORK(1) = WRKOPT + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( M, P ).EQ.0 ) THEN + RANK = 0 + ZWORK(1) = ONE + RETURN + END IF +C + DO 10 I = 1, 2*N+1 + IWORK(I) = 0 + 10 CONTINUE +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance.) +C +C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). +C ( D C ) +C Complex workspace: need (N+P)*(N+M). +C + CALL ZLACPY( 'Full', N, M, B, LDB, ZWORK, NP ) + CALL ZLACPY( 'Full', P, M, D, LDD, ZWORK(N+1), NP ) + CALL ZLACPY( 'Full', N, N, A, LDA, ZWORK(NP*M+1), NP ) + CALL ZLACPY( 'Full', P, N, C, LDC, ZWORK(NP*M+N+1), NP ) +C +C If required, balance the compound matrix (default MAXRED). +C Real Workspace: need N. +C + KW = WRKOPT + 1 + IF ( LEQUIL ) THEN + MAXRED = ZERO + CALL TB01IZ( 'A', N, M, P, MAXRED, ZWORK(NP*M+1), NP, ZWORK, + $ NP, ZWORK(NP*M+N+1), NP, DWORK, INFO ) + END IF +C +C If required, set tolerance. +C + THRESH = SQRT( DBLE( NP*NM ) )*DLAMCH( 'Precision' ) + TOLER = TOL + IF ( TOLER.LT.THRESH ) TOLER = THRESH + SVLMAX = ZLANGE( 'Frobenius', NP, NM, ZWORK, NP, DWORK ) +C +C Reduce this system to one with the same invariant zeros and with +C D full row rank MU (the normal rank of the original system). +C Real workspace: need 2*MAX(M,P); +C Complex workspace: need (N+P)*(N+M) + +C MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M) ); +C prefer larger. +C Integer workspace: 2*N+MAX(M,P)+1. +C + RO = P + SIGMA = 0 + NINFZ = 0 + CALL AB8NXZ( N, M, P, RO, SIGMA, SVLMAX, ZWORK, NP, NINFZ, IWORK, + $ IWORK(N+1), MU, NU, NKROL, TOLER, IWORK(2*N+2), + $ DWORK, ZWORK(KW), LZWORK-KW+1, INFO ) + RANK = MU +C + ZWORK(1) = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) + RETURN +C *** Last line of AB08MZ *** + END diff --git a/mex/sources/libslicot/AB08ND.f b/mex/sources/libslicot/AB08ND.f new file mode 100644 index 000000000..8fdb139d2 --- /dev/null +++ b/mex/sources/libslicot/AB08ND.f @@ -0,0 +1,568 @@ + SUBROUTINE AB08ND( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ NU, RANK, DINFZ, NKROR, NKROL, INFZ, KRONR, + $ KRONL, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct for a linear multivariable system described by a +C state-space model (A,B,C,D) a regular pencil (A - lambda*B ) which +C f f +C has the invariant zeros of the system as generalized eigenvalues. +C The routine also computes the orders of the infinite zeros and the +C right and left Kronecker indices of the system (A,B,C,D). +C +C ARGUMENTS +C +C Mode Parameters +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to balance the compound +C matrix (see METHOD) as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of state variables, i.e., the order of the +C matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state dynamics matrix A of the system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B of the system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C of the system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct transmission matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NU (output) INTEGER +C The number of (finite) invariant zeros. +C +C RANK (output) INTEGER +C The normal rank of the transfer function matrix. +C +C DINFZ (output) INTEGER +C The maximum degree of infinite elementary divisors. +C +C NKROR (output) INTEGER +C The number of right Kronecker indices. +C +C NKROL (output) INTEGER +C The number of left Kronecker indices. +C +C INFZ (output) INTEGER array, dimension (N) +C The leading DINFZ elements of INFZ contain information +C on the infinite elementary divisors as follows: +C the system has INFZ(i) infinite elementary divisors +C of degree i, where i = 1,2,...,DINFZ. +C +C KRONR (output) INTEGER array, dimension (MAX(N,M)+1) +C The leading NKROR elements of this array contain the +C right Kronecker (column) indices. +C +C KRONL (output) INTEGER array, dimension (MAX(N,P)+1) +C The leading NKROL elements of this array contain the +C left Kronecker (row) indices. +C +C AF (output) DOUBLE PRECISION array, dimension +C (LDAF,N+MIN(P,M)) +C The leading NU-by-NU part of this array contains the +C coefficient matrix A of the reduced pencil. The remainder +C f +C of the leading (N+M)-by-(N+MIN(P,M)) part is used as +C internal workspace. +C +C LDAF INTEGER +C The leading dimension of array AF. LDAF >= MAX(1,N+M). +C +C BF (output) DOUBLE PRECISION array, dimension (LDBF,N+M) +C The leading NU-by-NU part of this array contains the +C coefficient matrix B of the reduced pencil. The +C f +C remainder of the leading (N+P)-by-(N+M) part is used as +C internal workspace. +C +C LDBF INTEGER +C The leading dimension of array BF. LDBF >= MAX(1,N+P). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS +C then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (MAX(M,P)) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M), +C MIN(M,N) + MAX(3*M-1,N+M) ). +C An upper bound is MAX(s,N) + MAX(3*s-1,N+s), with +C s = MAX(M,P). +C For optimum performance LDWORK should be larger. +C +C If LDWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C DWORK array, returns this value as the first entry of +C the DWORK array, and no error message related to LDWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine extracts from the system matrix of a state-space +C system (A,B,C,D) a regular pencil A - lambda*B which has the +C f f +C invariant zeros of the system as generalized eigenvalues as +C follows: +C +C (a) construct the (N+P)-by-(N+M) compound matrix (B A); +C (D C) +C +C (b) reduce the above system to one with the same invariant +C zeros and with D of full row rank; +C +C (c) pertranspose the system; +C +C (d) reduce the system to one with the same invariant zeros and +C with D square invertible; +C +C (e) perform a unitary transformation on the columns of +C (A - lambda*I B) in order to reduce it to +C ( C D) +C +C (A - lambda*B X) +C ( f f ), with Y and B square invertible; +C ( 0 Y) f +C +C (f) compute the right and left Kronecker indices of the system +C (A,B,C,D), which together with the orders of the infinite +C zeros (determined by steps (a) - (e)) constitute the +C complete set of structural invariants under strict +C equivalence transformations of a linear system. +C +C REFERENCES +C +C [1] Svaricek, F. +C Computation of the Structural Invariants of Linear +C Multivariable Systems with an Extended Version of +C the Program ZEROS. +C System & Control Letters, 6, pp. 261-266, 1985. +C +C [2] Emami-Naeini, A. and Van Dooren, P. +C Computation of Zeros of Linear Multivariable Systems. +C Automatica, 18, pp. 415-430, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable (see [2] and [1]). +C +C FURTHER COMMENTS +C +C In order to compute the invariant zeros of the system explicitly, +C a call to this routine may be followed by a call to the LAPACK +C Library routine DGGEV with A = A , B = B and N = NU. +C f f +C If RANK = 0, the routine DGEEV can be used (since B = I). +C f +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C Supersedes Release 2.0 routine AB08BD by F. Svaricek. +C +C REVISIONS +C +C Oct. 1997, Feb. 1998, Dec. 2003, March 2004, Jan. 2009, Mar. 2009, +C Apr. 2009. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, orthogonal transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL + INTEGER DINFZ, INFO, LDA, LDAF, LDB, LDBF, LDC, LDD, + $ LDWORK, M, N, NKROL, NKROR, NU, P, RANK + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER INFZ(*), IWORK(*), KRONL(*), KRONR(*) + DOUBLE PRECISION A(LDA,*), AF(LDAF,*), B(LDB,*), BF(LDBF,*), + $ C(LDC,*), D(LDD,*), DWORK(*) +C .. Local Scalars .. + LOGICAL LEQUIL, LQUERY + INTEGER I, I1, II, J, MM, MNU, MU, NB, NINFZ, NN, NU1, + $ NUMU, NUMU1, PP, RO, SIGMA, WRKOPT + DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL AB08NX, DCOPY, DLACPY, DLASET, DORMRZ, DTZRZF, + $ TB01ID, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + LEQUIL = LSAME( EQUIL, 'S' ) + LQUERY = ( LDWORK.EQ.-1 ) +C +C Test the input scalar arguments. +C + IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDAF.LT.MAX( 1, N + M ) ) THEN + INFO = -22 + ELSE IF( LDBF.LT.MAX( 1, N + P ) ) THEN + INFO = -24 + ELSE + II = MIN( P, M ) + I = MAX( II + MAX( 3*M - 1, N ), + $ MIN( P, N ) + MAX( 3*P - 1, N+P, N+M ), + $ MIN( M, N ) + MAX( 3*M - 1, N+M ), 1 ) + IF( LQUERY ) THEN + SVLMAX = ZERO + NINFZ = 0 + CALL AB08NX( N, M, P, P, 0, SVLMAX, BF, LDBF, NINFZ, INFZ, + $ KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, -1, + $ INFO ) + WRKOPT = MAX( I, INT( DWORK(1) ) ) + CALL AB08NX( N, II, M, M-II, II, SVLMAX, AF, LDAF, NINFZ, + $ INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, + $ -1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + NB = ILAENV( 1, 'DGERQF', ' ', II, N+II, -1, -1 ) + WRKOPT = MAX( WRKOPT, II + II*NB ) + NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RT', N, N+II, II, -1 ) ) + WRKOPT = MAX( WRKOPT, II + N*NB ) + ELSE IF( LDWORK.LT.I ) THEN + INFO = -28 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB08ND', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C + DINFZ = 0 + NKROL = 0 + NKROR = 0 +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + IF ( MIN( M, P ).EQ.0 ) THEN + NU = 0 + RANK = 0 + DWORK(1) = ONE + RETURN + END IF + END IF +C + MM = M + NN = N + PP = P +C + DO 20 I = 1, N + INFZ(I) = 0 + 20 CONTINUE +C + IF ( M.GT.0 ) THEN + DO 40 I = 1, N + 1 + KRONR(I) = 0 + 40 CONTINUE + END IF +C + IF ( P.GT.0 ) THEN + DO 60 I = 1, N + 1 + KRONL(I) = 0 + 60 CONTINUE + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + WRKOPT = 1 +C +C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). +C ( D C ) +C + CALL DLACPY( 'Full', NN, MM, B, LDB, BF, LDBF ) + IF ( PP.GT.0 ) + $ CALL DLACPY( 'Full', PP, MM, D, LDD, BF(1+NN,1), LDBF ) + IF ( NN.GT.0 ) THEN + CALL DLACPY( 'Full', NN, NN, A, LDA, BF(1,1+MM), LDBF ) + IF ( PP.GT.0 ) + $ CALL DLACPY( 'Full', PP, NN, C, LDC, BF(1+NN,1+MM), LDBF ) + END IF +C +C If required, balance the compound matrix (default MAXRED). +C Workspace: need N. +C + IF ( LEQUIL .AND. NN.GT.0 .AND. PP.GT.0 ) THEN + MAXRED = ZERO + CALL TB01ID( 'A', NN, MM, PP, MAXRED, BF(1,1+MM), LDBF, BF, + $ LDBF, BF(1+NN,1+MM), LDBF, DWORK, INFO ) + WRKOPT = N + END IF +C +C If required, set tolerance. +C + THRESH = SQRT( DBLE( (N + P)*(N + M) ) )*DLAMCH( 'Precision' ) + TOLER = TOL + IF ( TOLER.LT.THRESH ) TOLER = THRESH + SVLMAX = DLANGE( 'Frobenius', NN+PP, NN+MM, BF, LDBF, DWORK ) +C +C Reduce this system to one with the same invariant zeros and with +C D upper triangular of full row rank MU (the normal rank of the +C original system). +C Workspace: need MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M) ); +C prefer larger. +C + RO = PP + SIGMA = 0 + NINFZ = 0 + CALL AB08NX( NN, MM, PP, RO, SIGMA, SVLMAX, BF, LDBF, NINFZ, INFZ, + $ KRONL, MU, NU, NKROL, TOLER, IWORK, DWORK, LDWORK, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + RANK = MU +C +C Pertranspose the system. +C + NUMU = NU + MU + IF ( NUMU.NE.0 ) THEN + MNU = MM + NU + NUMU1 = NUMU + 1 +C + DO 80 I = 1, NUMU + CALL DCOPY( MNU, BF(I,1), LDBF, AF(1,NUMU1-I), -1 ) + 80 CONTINUE +C + IF ( MU.NE.MM ) THEN +C +C Here MU < MM and MM > 0 (since MM = 0 implies MU = 0 = MM). +C + PP = MM + NN = NU + MM = MU +C +C Reduce the system to one with the same invariant zeros and +C with D square invertible. +C Workspace: need MAX( 1, MU + MAX(3*MU-1,N), +C MIN(M,N) + MAX(3*M-1,N+M) ); +C prefer larger. Note that MU <= MIN(P,M). +C + RO = PP - MM + SIGMA = MM + CALL AB08NX( NN, MM, PP, RO, SIGMA, SVLMAX, AF, LDAF, NINFZ, + $ INFZ, KRONR, MU, NU, NKROR, TOLER, IWORK, + $ DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + END IF +C + IF ( NU.NE.0 ) THEN +C +C Perform a unitary transformation on the columns of +C ( B A-lambda*I ) +C ( D C ) +C in order to reduce it to +C ( X AF-lambda*BF ) +C ( Y 0 ) +C with Y and BF square invertible. +C + CALL DLASET( 'Full', NU, MU, ZERO, ZERO, BF, LDBF ) + CALL DLASET( 'Full', NU, NU, ZERO, ONE, BF(1,MU+1), LDBF ) +C + IF ( RANK.NE.0 ) THEN + NU1 = NU + 1 + I1 = NU + MU +C +C Workspace: need 2*MIN(M,P); +C prefer MIN(M,P) + MIN(M,P)*NB. +C + CALL DTZRZF( MU, I1, AF(NU1,1), LDAF, DWORK, DWORK(MU+1), + $ LDWORK-MU, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(MU+1) ) + MU ) +C +C Workspace: need MIN(M,P) + N; +C prefer MIN(M,P) + N*NB. +C + CALL DORMRZ( 'Right', 'Transpose', NU, I1, MU, NU, + $ AF(NU1,1), LDAF, DWORK, AF, LDAF, + $ DWORK(MU+1), LDWORK-MU, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(MU+1) ) + MU ) +C + CALL DORMRZ( 'Right', 'Transpose', NU, I1, MU, NU, + $ AF(NU1,1), LDAF, DWORK, BF, LDBF, + $ DWORK(MU+1), LDWORK-MU, INFO ) +C + END IF +C +C Move AF and BF in the first columns. This assumes that +C DLACPY moves column by column. +C + CALL DLACPY( 'Full', NU, NU, AF(1,MU+1), LDAF, AF, LDAF ) + IF ( RANK.NE.0 ) + $ CALL DLACPY( 'Full', NU, NU, BF(1,MU+1), LDBF, BF, LDBF ) +C + END IF + END IF +C +C Set right Kronecker indices (column indices). +C + IF ( NKROR.GT.0 ) THEN + J = 1 +C + DO 120 I = 1, N + 1 +C + DO 100 II = J, J + KRONR(I) - 1 + IWORK(II) = I - 1 + 100 CONTINUE +C + J = J + KRONR(I) + KRONR(I) = 0 + 120 CONTINUE +C + NKROR = J - 1 +C + DO 140 I = 1, NKROR + KRONR(I) = IWORK(I) + 140 CONTINUE +C + END IF +C +C Set left Kronecker indices (row indices). +C + IF ( NKROL.GT.0 ) THEN + J = 1 +C + DO 180 I = 1, N + 1 +C + DO 160 II = J, J + KRONL(I) - 1 + IWORK(II) = I - 1 + 160 CONTINUE +C + J = J + KRONL(I) + KRONL(I) = 0 + 180 CONTINUE +C + NKROL = J - 1 +C + DO 200 I = 1, NKROL + KRONL(I) = IWORK(I) + 200 CONTINUE +C + END IF +C + IF ( N.GT.0 ) THEN + DINFZ = N +C + 220 CONTINUE + IF ( INFZ(DINFZ).EQ.0 ) THEN + DINFZ = DINFZ - 1 + IF ( DINFZ.GT.0 ) + $ GO TO 220 + END IF + END IF +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of AB08ND *** + END diff --git a/mex/sources/libslicot/AB08NX.f b/mex/sources/libslicot/AB08NX.f new file mode 100644 index 000000000..d67f6a193 --- /dev/null +++ b/mex/sources/libslicot/AB08NX.f @@ -0,0 +1,446 @@ + SUBROUTINE AB08NX( N, M, P, RO, SIGMA, SVLMAX, ABCD, LDABCD, + $ NINFZ, INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To extract from the (N+P)-by-(M+N) system +C ( B A ) +C ( D C ) +C an (NU+MU)-by-(M+NU) "reduced" system +C ( B' A') +C ( D' C') +C having the same transmission zeros but with D' of full row rank. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of state variables. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C RO (input/output) INTEGER +C On entry, +C = P for the original system; +C = MAX(P-M, 0) for the pertransposed system. +C On exit, RO contains the last computed rank. +C +C SIGMA (input/output) INTEGER +C On entry, +C = 0 for the original system; +C = M for the pertransposed system. +C On exit, SIGMA contains the last computed value sigma in +C the algorithm. +C +C SVLMAX (input) DOUBLE PRECISION +C During each reduction step, the rank-revealing QR +C factorization of a matrix stops when the estimated minimum +C singular value is smaller than TOL * MAX(SVLMAX,EMSV), +C where EMSV is the estimated maximum singular value. +C SVLMAX >= 0. +C +C ABCD (input/output) DOUBLE PRECISION array, dimension +C (LDABCD,M+N) +C On entry, the leading (N+P)-by-(M+N) part of this array +C must contain the compound input matrix of the system. +C On exit, the leading (NU+MU)-by-(M+NU) part of this array +C contains the reduced compound input matrix of the system. +C +C LDABCD INTEGER +C The leading dimension of array ABCD. +C LDABCD >= MAX(1,N+P). +C +C NINFZ (input/output) INTEGER +C On entry, the currently computed number of infinite zeros. +C It should be initialized to zero on the first call. +C NINFZ >= 0. +C On exit, the number of infinite zeros. +C +C INFZ (input/output) INTEGER array, dimension (N) +C On entry, INFZ(i) must contain the current number of +C infinite zeros of degree i, where i = 1,2,...,N, found in +C the previous call(s) of the routine. It should be +C initialized to zero on the first call. +C On exit, INFZ(i) contains the number of infinite zeros of +C degree i, where i = 1,2,...,N. +C +C KRONL (input/output) INTEGER array, dimension (N+1) +C On entry, this array must contain the currently computed +C left Kronecker (row) indices found in the previous call(s) +C of the routine. It should be initialized to zero on the +C first call. +C On exit, the leading NKROL elements of this array contain +C the left Kronecker (row) indices. +C +C MU (output) INTEGER +C The normal rank of the transfer function matrix of the +C original system. +C +C NU (output) INTEGER +C The dimension of the reduced system matrix and the number +C of (finite) invariant zeros if D' is invertible. +C +C NKROL (output) INTEGER +C The number of left Kronecker indices. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C NOTE that when SVLMAX > 0, the estimated ranks could be +C less than those defined above (see SVLMAX). +C +C Workspace +C +C IWORK INTEGER array, dimension (MAX(M,P)) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M) ). +C For optimum performance LDWORK should be larger. +C +C If LDWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C DWORK array, returns this value as the first entry of +C the DWORK array, and no error message related to LDWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Svaricek, F. +C Computation of the Structural Invariants of Linear +C Multivariable Systems with an Extended Version of +C the Program ZEROS. +C System & Control Letters, 6, pp. 261-266, 1985. +C +C [2] Emami-Naeini, A. and Van Dooren, P. +C Computation of Zeros of Linear Multivariable Systems. +C Automatica, 18, pp. 415-430, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C Supersedes Release 2.0 routine AB08BZ by F. Svaricek. +C +C REVISIONS +C +C V. Sima, Oct. 1997; Feb. 1998, Jan. 2009, Apr. 2009. +C A. Varga, May 1999; May 2001. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, orthogonal transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDABCD, LDWORK, M, MU, N, NINFZ, NKROL, + $ NU, P, RO, SIGMA + DOUBLE PRECISION SVLMAX, TOL +C .. Array Arguments .. + INTEGER INFZ(*), IWORK(*), KRONL(*) + DOUBLE PRECISION ABCD(LDABCD,*), DWORK(*) +C .. Local Scalars .. + LOGICAL LQUERY + INTEGER I1, IK, IROW, ITAU, IZ, JWORK, MM1, MNTAU, MNU, + $ MPM, NB, NP, RANK, RO1, TAU, WRKOPT + DOUBLE PRECISION T +C .. Local Arrays .. + DOUBLE PRECISION SVAL(3) +C .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +C .. External Subroutines .. + EXTERNAL DLAPMT, DLARFG, DLASET, DLATZM, DORMQR, DORMRQ, + $ MB03OY, MB03PY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + NP = N + P + MPM = MIN( P, M ) + INFO = 0 + LQUERY = ( LDWORK.EQ.-1 ) +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( RO.NE.P .AND. RO.NE.MAX( P-M, 0 ) ) THEN + INFO = -4 + ELSE IF( SIGMA.NE.0 .AND. SIGMA.NE.M ) THEN + INFO = -5 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDABCD.LT.MAX( 1, NP ) ) THEN + INFO = -8 + ELSE IF( NINFZ.LT.0 ) THEN + INFO = -9 + ELSE + JWORK = MAX( 1, MPM + MAX( 3*M - 1, N ), + $ MIN( P, N ) + MAX( 3*P - 1, NP, N+M ) ) + IF( LQUERY ) THEN + IF( M.GT.0 ) THEN + NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LT', P, N, MPM, + $ -1 ) ) + WRKOPT = MAX( JWORK, MPM + MAX( 1, N )*NB ) + ELSE + WRKOPT = JWORK + END IF + NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RT', NP, N, MIN( P, N ), + $ -1 ) ) + WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, NP )*NB ) + NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'LN', N, M+N, + $ MIN( P, N ), -1 ) ) + WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, M+N )*NB ) + ELSE IF( LDWORK.LT.JWORK ) THEN + INFO = -18 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB08NX', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C + MU = P + NU = N +C + IZ = 0 + IK = 1 + MM1 = M + 1 + ITAU = 1 + NKROL = 0 + WRKOPT = 1 +C +C Main reduction loop: +C +C M NU M NU +C NU [ B A ] NU [ B A ] +C MU [ D C ] --> SIGMA [ RD C1 ] (SIGMA = rank(D) = +C TAU [ 0 C2 ] row size of RD) +C +C M NU-RO RO +C NU-RO [ B1 A11 A12 ] +C --> RO [ B2 A21 A22 ] (RO = rank(C2) = +C SIGMA [ RD C11 C12 ] col size of LC) +C TAU [ 0 0 LC ] +C +C M NU-RO +C NU-RO [ B1 A11 ] NU := NU - RO +C [----------] MU := RO + SIGMA +C --> RO [ B2 A21 ] D := [B2;RD] +C SIGMA [ RD C11 ] C := [A21;C11] +C + 20 IF ( MU.EQ.0 ) + $ GO TO 80 +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + RO1 = RO + MNU = M + NU + IF ( M.GT.0 ) THEN + IF ( SIGMA.NE.0 ) THEN + IROW = NU + 1 +C +C Compress rows of D. First exploit triangular shape. +C Workspace: need M+N-1. +C + DO 40 I1 = 1, SIGMA + CALL DLARFG( RO+1, ABCD(IROW,I1), ABCD(IROW+1,I1), 1, T ) + CALL DLATZM( 'L', RO+1, MNU-I1, ABCD(IROW+1,I1), 1, T, + $ ABCD(IROW,I1+1), ABCD(IROW+1,I1+1), LDABCD, + $ DWORK ) + IROW = IROW + 1 + 40 CONTINUE + CALL DLASET( 'Lower', RO+SIGMA-1, SIGMA, ZERO, ZERO, + $ ABCD(NU+2,1), LDABCD ) + END IF +C +C Continue with Householder with column pivoting. +C +C The rank of D is the number of (estimated) singular values +C that are greater than TOL * MAX(SVLMAX,EMSV). This number +C includes the singular values of the first SIGMA columns. +C Integer workspace: need M; +C Workspace: need min(RO1,M) + 3*M - 1. RO1 <= P. +C + IF ( SIGMA.LT.M ) THEN + JWORK = ITAU + MIN( RO1, M ) + I1 = SIGMA + 1 + IROW = NU + I1 + CALL MB03OY( RO1, M-SIGMA, ABCD(IROW,I1), LDABCD, TOL, + $ SVLMAX, RANK, SVAL, IWORK, DWORK(ITAU), + $ DWORK(JWORK), INFO ) + WRKOPT = MAX( WRKOPT, JWORK + 3*M - 2 ) +C +C Apply the column permutations to matrices B and part of D. +C + CALL DLAPMT( .TRUE., NU+SIGMA, M-SIGMA, ABCD(1,I1), LDABCD, + $ IWORK ) +C + IF ( RANK.GT.0 ) THEN +C +C Apply the Householder transformations to the submatrix C. +C Workspace: need min(RO1,M) + NU; +C prefer min(RO1,M) + NU*NB. +C + CALL DORMQR( 'Left', 'Transpose', RO1, NU, RANK, + $ ABCD(IROW,I1), LDABCD, DWORK(ITAU), + $ ABCD(IROW,MM1), LDABCD, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF ( RO1.GT.1 ) + $ CALL DLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO, + $ ZERO, ABCD(IROW+1,I1), LDABCD ) + RO1 = RO1 - RANK + END IF + END IF + END IF +C + TAU = RO1 + SIGMA = MU - TAU +C +C Determination of the orders of the infinite zeros. +C + IF ( IZ.GT.0 ) THEN + INFZ(IZ) = INFZ(IZ) + RO - TAU + NINFZ = NINFZ + IZ*( RO - TAU ) + END IF + IF ( RO1.EQ.0 ) + $ GO TO 80 + IZ = IZ + 1 +C + IF ( NU.LE.0 ) THEN + MU = SIGMA + NU = 0 + RO = 0 + ELSE +C +C Compress the columns of C2 using RQ factorization with row +C pivoting, P * C2 = R * Q. +C + I1 = NU + SIGMA + 1 + MNTAU = MIN( TAU, NU ) + JWORK = ITAU + MNTAU +C +C The rank of C2 is the number of (estimated) singular values +C greater than TOL * MAX(SVLMAX,EMSV). +C Integer Workspace: need TAU; +C Workspace: need min(TAU,NU) + 3*TAU - 1. +C + CALL MB03PY( TAU, NU, ABCD(I1,MM1), LDABCD, TOL, SVLMAX, RANK, + $ SVAL, IWORK, DWORK(ITAU), DWORK(JWORK), INFO ) + WRKOPT = MAX( WRKOPT, JWORK + 3*TAU - 1 ) + IF ( RANK.GT.0 ) THEN + IROW = I1 + TAU - RANK +C +C Apply Q' to the first NU columns of [A; C1] from the right. +C Workspace: need min(TAU,NU) + NU + SIGMA; SIGMA <= P; +C prefer min(TAU,NU) + (NU + SIGMA)*NB. +C + CALL DORMRQ( 'Right', 'Transpose', I1-1, NU, RANK, + $ ABCD(IROW,MM1), LDABCD, DWORK(MNTAU-RANK+1), + $ ABCD(1,MM1), LDABCD, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Apply Q to the first NU rows and M + NU columns of [ B A ] +C from the left. +C Workspace: need min(TAU,NU) + M + NU; +C prefer min(TAU,NU) + (M + NU)*NB. +C + CALL DORMRQ( 'Left', 'NoTranspose', NU, MNU, RANK, + $ ABCD(IROW,MM1), LDABCD, DWORK(MNTAU-RANK+1), + $ ABCD, LDABCD, DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + CALL DLASET( 'Full', RANK, NU-RANK, ZERO, ZERO, + $ ABCD(IROW,MM1), LDABCD ) + IF ( RANK.GT.1 ) + $ CALL DLASET( 'Lower', RANK-1, RANK-1, ZERO, ZERO, + $ ABCD(IROW+1,MM1+NU-RANK), LDABCD ) + END IF +C + RO = RANK + END IF +C +C Determine the left Kronecker indices (row indices). +C + KRONL(IK) = KRONL(IK) + TAU - RO + NKROL = NKROL + KRONL(IK) + IK = IK + 1 +C +C C and D are updated to [A21 ; C11] and [B2 ; RD]. +C + NU = NU - RO + MU = SIGMA + RO + IF ( RO.NE.0 ) + $ GO TO 20 +C + 80 CONTINUE + DWORK(1) = WRKOPT + RETURN +C *** Last line of AB08NX *** + END diff --git a/mex/sources/libslicot/AB08NZ.f b/mex/sources/libslicot/AB08NZ.f new file mode 100644 index 000000000..9638b4bbb --- /dev/null +++ b/mex/sources/libslicot/AB08NZ.f @@ -0,0 +1,576 @@ + SUBROUTINE AB08NZ( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ NU, RANK, DINFZ, NKROR, NKROL, INFZ, KRONR, + $ KRONL, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK, + $ ZWORK, LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct for a linear multivariable system described by a +C state-space model (A,B,C,D) a regular pencil (A - lambda*B ) which +C f f +C has the invariant zeros of the system as generalized eigenvalues. +C The routine also computes the orders of the infinite zeros and the +C right and left Kronecker indices of the system (A,B,C,D). +C +C ARGUMENTS +C +C Mode Parameters +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to balance the compound +C matrix (see METHOD) as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of state variables, i.e., the order of the +C matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input) COMPLEX*16 array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state dynamics matrix A of the system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) COMPLEX*16 array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B of the system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) COMPLEX*16 array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C of the system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) COMPLEX*16 array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct transmission matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NU (output) INTEGER +C The number of (finite) invariant zeros. +C +C RANK (output) INTEGER +C The normal rank of the transfer function matrix. +C +C DINFZ (output) INTEGER +C The maximum degree of infinite elementary divisors. +C +C NKROR (output) INTEGER +C The number of right Kronecker indices. +C +C NKROL (output) INTEGER +C The number of left Kronecker indices. +C +C INFZ (output) INTEGER array, dimension (N) +C The leading DINFZ elements of INFZ contain information +C on the infinite elementary divisors as follows: +C the system has INFZ(i) infinite elementary divisors +C of degree i, where i = 1,2,...,DINFZ. +C +C KRONR (output) INTEGER array, dimension (MAX(N,M)+1) +C The leading NKROR elements of this array contain the +C right Kronecker (column) indices. +C +C KRONL (output) INTEGER array, dimension (MAX(N,P)+1) +C The leading NKROL elements of this array contain the +C left Kronecker (row) indices. +C +C AF (output) COMPLEX*16 array, dimension (LDAF,N+MIN(P,M)) +C The leading NU-by-NU part of this array contains the +C coefficient matrix A of the reduced pencil. The remainder +C f +C of the leading (N+M)-by-(N+MIN(P,M)) part is used as +C internal workspace. +C +C LDAF INTEGER +C The leading dimension of array AF. LDAF >= MAX(1,N+M). +C +C BF (output) COMPLEX*16 array, dimension (LDBF,N+M) +C The leading NU-by-NU part of this array contains the +C coefficient matrix B of the reduced pencil. The +C f +C remainder of the leading (N+P)-by-(N+M) part is used as +C internal workspace. +C +C LDBF INTEGER +C The leading dimension of array BF. LDBF >= MAX(1,N+P). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS +C then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (MAX(M,P)) +C +C DWORK DOUBLE PRECISION array, dimension (MAX(N,2*MAX(P,M))) +C +C ZWORK DOUBLE PRECISION array, dimension (LZWORK) +C On exit, if INFO = 0, ZWORK(1) returns the optimal value +C of LZWORK. +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M), +C MIN(M,N) + MAX(3*M-1,N+M) ). +C An upper bound is MAX(s,N) + MAX(3*s-1,N+s), with +C s = MAX(M,P). +C For optimum performance LZWORK should be larger. +C +C If LZWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C ZWORK array, returns this value as the first entry of +C the ZWORK array, and no error message related to LZWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine extracts from the system matrix of a state-space +C system (A,B,C,D) a regular pencil A - lambda*B which has the +C f f +C invariant zeros of the system as generalized eigenvalues as +C follows: +C +C (a) construct the (N+P)-by-(N+M) compound matrix (B A); +C (D C) +C +C (b) reduce the above system to one with the same invariant +C zeros and with D of full row rank; +C +C (c) pertranspose the system; +C +C (d) reduce the system to one with the same invariant zeros and +C with D square invertible; +C +C (e) perform a unitary transformation on the columns of +C (A - lambda*I B) in order to reduce it to +C ( C D) +C +C (A - lambda*B X) +C ( f f ), with Y and B square invertible; +C ( 0 Y) f +C +C (f) compute the right and left Kronecker indices of the system +C (A,B,C,D), which together with the orders of the infinite +C zeros (determined by steps (a) - (e)) constitute the +C complete set of structural invariants under strict +C equivalence transformations of a linear system. +C +C REFERENCES +C +C [1] Svaricek, F. +C Computation of the Structural Invariants of Linear +C Multivariable Systems with an Extended Version of +C the Program ZEROS. +C System & Control Letters, 6, pp. 261-266, 1985. +C +C [2] Emami-Naeini, A. and Van Dooren, P. +C Computation of Zeros of Linear Multivariable Systems. +C Automatica, 18, pp. 415-430, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable (see [2] and [1]). +C +C FURTHER COMMENTS +C +C In order to compute the invariant zeros of the system explicitly, +C a call to this routine may be followed by a call to the LAPACK +C Library routine ZGGEV with A = A , B = B and N = NU. +C f f +C If RANK = 0, the routine ZGEEV can be used (since B = I). +C f +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2009, +C Apr. 2009. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, unitary transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION DZERO + PARAMETER ( DZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL + INTEGER DINFZ, INFO, LDA, LDAF, LDB, LDBF, LDC, LDD, + $ LZWORK, M, N, NKROL, NKROR, NU, P, RANK + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER INFZ(*), IWORK(*), KRONL(*), KRONR(*) + COMPLEX*16 A(LDA,*), AF(LDAF,*), B(LDB,*), BF(LDBF,*), + $ C(LDC,*), D(LDD,*), ZWORK(*) + DOUBLE PRECISION DWORK(*) +C .. Local Scalars .. + LOGICAL LEQUIL, LQUERY + INTEGER I, I1, II, J, MM, MNU, MU, NB, NINFZ, NN, NU1, + $ NUMU, NUMU1, PP, RO, SIGMA, WRKOPT + DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL DLAMCH, ILAENV, LSAME, ZLANGE +C .. External Subroutines .. + EXTERNAL AB8NXZ, TB01IZ, XERBLA, ZCOPY, ZLACPY, ZLASET, + $ ZTZRZF, ZUNMRZ +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + LEQUIL = LSAME( EQUIL, 'S' ) + LQUERY = ( LZWORK.EQ.-1 ) +C +C Test the input scalar arguments. +C + IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDAF.LT.MAX( 1, N + M ) ) THEN + INFO = -22 + ELSE IF( LDBF.LT.MAX( 1, N + P ) ) THEN + INFO = -24 + ELSE + II = MIN( P, M ) + I = MAX( II + MAX( 3*M - 1, N ), + $ MIN( P, N ) + MAX( 3*P - 1, N+P, N+M ), + $ MIN( M, N ) + MAX( 3*M - 1, N+M ), 1 ) + IF( LQUERY ) THEN + SVLMAX = DZERO + NINFZ = 0 + CALL AB8NXZ( N, M, P, P, 0, SVLMAX, BF, LDBF, NINFZ, INFZ, + $ KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, + $ ZWORK, -1, INFO ) + WRKOPT = MAX( I, INT( ZWORK(1) ) ) + CALL AB8NXZ( N, II, M, M-II, II, SVLMAX, AF, LDAF, NINFZ, + $ INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, + $ ZWORK, -1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) + NB = ILAENV( 1, 'ZGERQF', ' ', II, N+II, -1, -1 ) + WRKOPT = MAX( WRKOPT, II + II*NB ) + NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', N, N+II, II, -1 ) ) + WRKOPT = MAX( WRKOPT, II + N*NB ) + ELSE IF( LZWORK.LT.I ) THEN + INFO = -29 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB08NZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + ZWORK(1) = WRKOPT + RETURN + END IF +C + DINFZ = 0 + NKROL = 0 + NKROR = 0 +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + IF ( MIN( M, P ).EQ.0 ) THEN + NU = 0 + RANK = 0 + ZWORK(1) = ONE + RETURN + END IF + END IF +C + MM = M + NN = N + PP = P +C + DO 20 I = 1, N + INFZ(I) = 0 + 20 CONTINUE +C + IF ( M.GT.0 ) THEN + DO 40 I = 1, N + 1 + KRONR(I) = 0 + 40 CONTINUE + END IF +C + IF ( P.GT.0 ) THEN + DO 60 I = 1, N + 1 + KRONL(I) = 0 + 60 CONTINUE + END IF +C +C (Note: Comments in the code beginning "CWorkspace:" and +C "RWorkspace:" describe the minimal amount of complex and real +C workspace, respectively, needed at that point in the code, as +C well as the preferred amount for good performance.) +C + WRKOPT = 1 +C +C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). +C ( D C ) +C + CALL ZLACPY( 'Full', NN, MM, B, LDB, BF, LDBF ) + IF ( PP.GT.0 ) + $ CALL ZLACPY( 'Full', PP, MM, D, LDD, BF(1+NN,1), LDBF ) + IF ( NN.GT.0 ) THEN + CALL ZLACPY( 'Full', NN, NN, A, LDA, BF(1,1+MM), LDBF ) + IF ( PP.GT.0 ) + $ CALL ZLACPY( 'Full', PP, NN, C, LDC, BF(1+NN,1+MM), LDBF ) + END IF +C +C If required, balance the compound matrix (default MAXRED). +C RWorkspace: need N. +C + IF ( LEQUIL .AND. NN.GT.0 .AND. PP.GT.0 ) THEN + MAXRED = DZERO + CALL TB01IZ( 'A', NN, MM, PP, MAXRED, BF(1,1+MM), LDBF, BF, + $ LDBF, BF(1+NN,1+MM), LDBF, DWORK, INFO ) + END IF +C +C If required, set tolerance. +C + THRESH = SQRT( DBLE( (N + P)*(N + M) ) )*DLAMCH( 'Precision' ) + TOLER = TOL + IF ( TOLER.LT.THRESH ) TOLER = THRESH + SVLMAX = ZLANGE( 'Frobenius', NN+PP, NN+MM, BF, LDBF, DWORK ) +C +C Reduce this system to one with the same invariant zeros and with +C D upper triangular of full row rank MU (the normal rank of the +C original system). +C RWorkspace: need 2*MAX(M,P); +C CWorkspace: need MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M) ); +C prefer larger. +C + RO = PP + SIGMA = 0 + NINFZ = 0 + CALL AB8NXZ( NN, MM, PP, RO, SIGMA, SVLMAX, BF, LDBF, NINFZ, INFZ, + $ KRONL, MU, NU, NKROL, TOLER, IWORK, DWORK, ZWORK, + $ LZWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) + RANK = MU +C +C Pertranspose the system. +C + NUMU = NU + MU + IF ( NUMU.NE.0 ) THEN + MNU = MM + NU + NUMU1 = NUMU + 1 +C + DO 80 I = 1, NUMU + CALL ZCOPY( MNU, BF(I,1), LDBF, AF(1,NUMU1-I), -1 ) + 80 CONTINUE +C + IF ( MU.NE.MM ) THEN +C +C Here MU < MM and MM > 0 (since MM = 0 implies MU = 0 = MM). +C + PP = MM + NN = NU + MM = MU +C +C Reduce the system to one with the same invariant zeros and +C with D square invertible. +C RWorkspace: need 2*M. +C CWorkspace: need MAX( 1, MU + MAX(3*MU-1,N), +C MIN(M,N) + MAX(3*M-1,N+M) ); +C prefer larger. Note that MU <= MIN(M,P). +C + RO = PP - MM + SIGMA = MM + CALL AB8NXZ( NN, MM, PP, RO, SIGMA, SVLMAX, AF, LDAF, NINFZ, + $ INFZ, KRONR, MU, NU, NKROR, TOLER, IWORK, + $ DWORK, ZWORK, LZWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) + END IF +C + IF ( NU.NE.0 ) THEN +C +C Perform a unitary transformation on the columns of +C ( B A-lambda*I ) +C ( D C ) +C in order to reduce it to +C ( X AF-lambda*BF ) +C ( Y 0 ) +C with Y and BF square invertible. +C + CALL ZLASET( 'Full', NU, MU, ZERO, ZERO, BF, LDBF ) + CALL ZLASET( 'Full', NU, NU, ZERO, ONE, BF(1,MU+1), LDBF ) +C + IF ( RANK.NE.0 ) THEN + NU1 = NU + 1 + I1 = NU + MU +C +C CWorkspace: need 2*MIN(M,P); +C prefer MIN(M,P) + MIN(M,P)*NB. +C + CALL ZTZRZF( MU, I1, AF(NU1,1), LDAF, ZWORK, ZWORK(MU+1), + $ LZWORK-MU, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(MU+1) ) + MU ) +C +C CWorkspace: need MIN(M,P) + N; +C prefer MIN(M,P) + N*NB. +C + CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, I1, MU, + $ NU, AF(NU1,1), LDAF, ZWORK, AF, LDAF, + $ ZWORK(MU+1), LZWORK-MU, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(MU+1) ) + MU ) +C + CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, I1, MU, + $ NU, AF(NU1,1), LDAF, ZWORK, BF, LDBF, + $ ZWORK(MU+1), LZWORK-MU, INFO ) +C + END IF +C +C Move AF and BF in the first columns. This assumes that +C ZLACPY moves column by column. +C + CALL ZLACPY( 'Full', NU, NU, AF(1,MU+1), LDAF, AF, LDAF ) + IF ( RANK.NE.0 ) + $ CALL ZLACPY( 'Full', NU, NU, BF(1,MU+1), LDBF, BF, LDBF ) +C + END IF + END IF +C +C Set right Kronecker indices (column indices). +C + IF ( NKROR.GT.0 ) THEN + J = 1 +C + DO 120 I = 1, N + 1 +C + DO 100 II = J, J + KRONR(I) - 1 + IWORK(II) = I - 1 + 100 CONTINUE +C + J = J + KRONR(I) + KRONR(I) = 0 + 120 CONTINUE +C + NKROR = J - 1 +C + DO 140 I = 1, NKROR + KRONR(I) = IWORK(I) + 140 CONTINUE +C + END IF +C +C Set left Kronecker indices (row indices). +C + IF ( NKROL.GT.0 ) THEN + J = 1 +C + DO 180 I = 1, N + 1 +C + DO 160 II = J, J + KRONL(I) - 1 + IWORK(II) = I - 1 + 160 CONTINUE +C + J = J + KRONL(I) + KRONL(I) = 0 + 180 CONTINUE +C + NKROL = J - 1 +C + DO 200 I = 1, NKROL + KRONL(I) = IWORK(I) + 200 CONTINUE +C + END IF +C + IF ( N.GT.0 ) THEN + DINFZ = N +C + 220 CONTINUE + IF ( INFZ(DINFZ).EQ.0 ) THEN + DINFZ = DINFZ - 1 + IF ( DINFZ.GT.0 ) + $ GO TO 220 + END IF + END IF +C + ZWORK(1) = WRKOPT + RETURN +C *** Last line of AB08NZ *** + END diff --git a/mex/sources/libslicot/AB09AD.f b/mex/sources/libslicot/AB09AD.f new file mode 100644 index 000000000..8d04fa633 --- /dev/null +++ b/mex/sources/libslicot/AB09AD.f @@ -0,0 +1,363 @@ + SUBROUTINE AB09AD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, A, LDA, + $ B, LDB, C, LDC, HSV, TOL, IWORK, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr) for a stable original +C state-space representation (A,B,C) by using either the square-root +C or the balancing-free square-root Balance & Truncate (B & T) +C model reduction method. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root Balance & Truncate method; +C = 'N': use the balancing-free square-root +C Balance & Truncate method. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of the +C resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR +C is the desired order on entry and NMIN is the order of a +C minimal realization of the given system; NMIN is +C determined as the number of Hankel singular values greater +C than N*EPS*HNORM(A,B,C), where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH) and +C HNORM(A,B,C) is the Hankel norm of the system (computed +C in HSV(1)); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL,N*EPS*HNORM(A,B,C)). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the reduced +C order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the Hankel singular values of +C the original system ordered decreasingly. HSV(1) is the +C Hankel norm of the system. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If ORDSEL = 'A', TOL contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL = c*HNORM(A,B,C), where c is a constant in the +C interval [0.00001,0.001], and HNORM(A,B,C) is the +C Hankel-norm of the given system (computed in HSV(1)). +C For computing a minimal realization, the recommended +C value is TOL = N*EPS*HNORM(A,B,C), where EPS is the +C machine precision (see LAPACK Library Routine DLAMCH). +C This value is used by default if TOL <= 0 on entry. +C If ORDSEL = 'F', the value of TOL is ignored. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = 0, if JOB = 'B'; +C LIWORK = N, if JOB = 'N'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5)+N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than the order of a minimal realization of the +C given system. In this case, the resulting NR is +C set automatically to a value corresponding to the +C order of a minimal realization of the system. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to the real Schur form failed; +C = 2: the state matrix A is not stable (if DICO = 'C') +C or not convergent (if DICO = 'D'); +C = 3: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09AD determines for +C the given system (1), the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) (2) +C +C such that +C +C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C If JOB = 'B', the square-root Balance & Truncate method of [1] +C is used and, for DICO = 'C', the resulting model is balanced. +C By setting TOL <= 0, the routine can be used to compute balanced +C minimal state-space realizations of stable systems. +C +C If JOB = 'N', the balancing-free square-root version of the +C Balance & Truncate method [2] is used. +C By setting TOL <= 0, the routine can be used to compute minimal +C state-space realizations of stable systems. +C +C REFERENCES +C +C [1] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [2] Varga A. +C Efficient minimal realization procedure based on balancing. +C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, +C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), +C Vol. 2, pp. 42-46. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routines SRBT and SRBFT. +C +C REVISIONS +C +C May 2, 1998. +C November 11, 1998, V. Sima, Research Institute for Informatics, +C Bucharest. +C +C KEYWORDS +C +C Balancing, minimal state-space representation, model reduction, +C multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, C100 + PARAMETER ( ONE = 1.0D0, C100 = 100.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDWORK, M, N, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL FIXORD + INTEGER IERR, KI, KR, KT, KTI, KW, NN + DOUBLE PRECISION MAXRED, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB09AX, TB01ID, TB01WD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. LSAME( DICO, 'D' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -14 + ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2 ) ) THEN + INFO = -19 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 .OR. ( FIXORD .AND. NR.EQ.0 ) ) THEN + NR = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Allocate working storage. +C + NN = N*N + KT = 1 + KR = KT + NN + KI = KR + N + KW = KI + N +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C + MAXRED = C100 + CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Reduce A to the real Schur form using an orthogonal similarity +C transformation A <- T'*A*T and apply the transformation to +C B and C: B <- T'*B and C <- C*T. +C + CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, DWORK(KT), N, + $ DWORK(KR), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) + KTI = KT + NN + KW = KTI + NN +C + CALL AB09AX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, C, + $ LDC, HSV, DWORK(KT), N, DWORK(KTI), N, TOL, IWORK, + $ DWORK(KW), LDWORK-KW+1, IWARN, IERR ) +C + IF( IERR.NE.0 ) THEN + INFO = IERR + 1 + RETURN + END IF +C + DWORK(1) = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) +C + RETURN +C *** Last line of AB09AD *** + END diff --git a/mex/sources/libslicot/AB09AX.f b/mex/sources/libslicot/AB09AX.f new file mode 100644 index 000000000..6d333337a --- /dev/null +++ b/mex/sources/libslicot/AB09AX.f @@ -0,0 +1,564 @@ + SUBROUTINE AB09AX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, + $ C, LDC, HSV, T, LDT, TI, LDTI, TOL, IWORK, + $ DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr) for a stable original +C state-space representation (A,B,C) by using either the square-root +C or the balancing-free square-root Balance & Truncate model +C reduction method. The state dynamics matrix A of the original +C system is an upper quasi-triangular matrix in real Schur canonical +C form. The matrices of the reduced order system are computed using +C the truncation formulas: +C +C Ar = TI * A * T , Br = TI * B , Cr = C * T . +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root Balance & Truncate method; +C = 'N': use the balancing-free square-root +C Balance & Truncate method. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of the +C resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR +C is the desired order on entry and NMIN is the order of a +C minimal realization of the given system; NMIN is +C determined as the number of Hankel singular values greater +C than N*EPS*HNORM(A,B,C), where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH) and +C HNORM(A,B,C) is the Hankel norm of the system (computed +C in HSV(1)); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL,N*EPS*HNORM(A,B,C)). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A in a real Schur +C canonical form. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the Hankel singular values of +C the original system ordered decreasingly. HSV(1) is the +C Hankel norm of the system. +C +C T (output) DOUBLE PRECISION array, dimension (LDT,N) +C If INFO = 0 and NR > 0, the leading N-by-NR part of this +C array contains the right truncation matrix T. +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,N). +C +C TI (output) DOUBLE PRECISION array, dimension (LDTI,N) +C If INFO = 0 and NR > 0, the leading NR-by-N part of this +C array contains the left truncation matrix TI. +C +C LDTI INTEGER +C The leading dimension of array TI. LDTI >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If ORDSEL = 'A', TOL contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL = c*HNORM(A,B,C), where c is a constant in the +C interval [0.00001,0.001], and HNORM(A,B,C) is the +C Hankel-norm of the given system (computed in HSV(1)). +C For computing a minimal realization, the recommended +C value is TOL = N*EPS*HNORM(A,B,C), where EPS is the +C machine precision (see LAPACK Library Routine DLAMCH). +C This value is used by default if TOL <= 0 on entry. +C If ORDSEL = 'F', the value of TOL is ignored. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = 0, if JOB = 'B', or +C LIWORK = N, if JOB = 'N'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*(MAX(N,M,P)+5) + N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than the order of a minimal realization of the +C given system. In this case, the resulting NR is +C set automatically to a value corresponding to the +C order of a minimal realization of the system. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the state matrix A is not stable (if DICO = 'C') +C or not convergent (if DICO = 'D'); +C = 2: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09AX determines for +C the given system (1), the matrices of a reduced NR order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) (2) +C +C such that +C +C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C If JOB = 'B', the square-root Balance & Truncate method of [1] +C is used and, for DICO = 'C', the resulting model is balanced. +C By setting TOL <= 0, the routine can be used to compute balanced +C minimal state-space realizations of stable systems. +C +C If JOB = 'N', the balancing-free square-root version of the +C Balance & Truncate method [2] is used. +C By setting TOL <= 0, the routine can be used to compute minimal +C state-space realizations of stable systems. +C +C REFERENCES +C +C [1] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [2] Varga A. +C Efficient minimal realization procedure based on balancing. +C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, +C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), +C Vol. 2, pp. 42-46. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routines SRBT1 and SRBFT1. +C +C REVISIONS +C +C May 2, 1998. +C November 11, 1998, V. Sima, Research Institute for Informatics, +C Bucharest. +C December 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C February 14, 1999, A. Varga, German Aerospace Center. +C February 22, 1999, V. Sima, Research Institute for Informatics. +C February 27, 2000, V. Sima, Research Institute for Informatics. +C +C KEYWORDS +C +C Balancing, minimal state-space representation, model reduction, +C multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDT, LDTI, LDWORK, + $ M, N, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*), + $ T(LDT,*), TI(LDTI,*) +C .. Local Scalars .. + LOGICAL BAL, DISCR, FIXORD, PACKED + INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, WRKOPT + DOUBLE PRECISION ATOL, RTOL, SCALEC, SCALEO, TEMP +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DGEMV, DGEQRF, DGETRF, DGETRS, DLACPY, + $ DORGQR, DSCAL, DTPMV, DTRMM, DTRMV, MA02AD, + $ MA02DD, MB03UD, SB03OU, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + BAL = LSAME( JOB, 'B' ) + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( BAL .OR. LSAME( JOB, 'N') ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2 ) ) THEN + INFO = -22 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09AX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 .OR. ( FIXORD .AND. NR.EQ.0 ) ) THEN + NR = 0 + DWORK(1) = ONE + RETURN + END IF +C + RTOL = DBLE( N )*DLAMCH( 'Epsilon' ) +C +C Allocate N*MAX(N,M,P) and N working storage for the matrices U +C and TAU, respectively. +C + KU = 1 + KTAU = KU + N*MAX( N, M, P ) + KW = KTAU + N + LDW = LDWORK - KW + 1 +C +C Copy B in U. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) +C +C If DISCR = .FALSE., solve for Su the Lyapunov equation +C 2 +C A*(Su*Su') + (Su*Su')*A' + scalec *B*B' = 0 . +C +C If DISCR = .TRUE., solve for Su the Lyapunov equation +C 2 +C A*(Su*Su')*A' + scalec *B*B' = Su*Su' . +C +C Workspace: need N*(MAX(N,M,P) + 5); +C prefer larger. +C + CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KU), N, + $ DWORK(KTAU), TI, LDTI, SCALEC, DWORK(KW), LDW, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + ENDIF + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Copy C in U. +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) +C +C If DISCR = .FALSE., solve for Ru the Lyapunov equation +C 2 +C A'*(Ru'*Ru) + (Ru'*Ru)*A + scaleo * C'*C = 0 . +C +C If DISCR = .TRUE., solve for Ru the Lyapunov equation +C 2 +C A'*(Ru'*Ru)*A + scaleo * C'*C = Ru'*Ru . +C +C Workspace: need N*(MAX(N,M,P) + 5); +C prefer larger. +C + CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), P, + $ DWORK(KTAU), T, LDT, SCALEO, DWORK(KW), LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Allocate N*(N+1)/2 (or, if possible, N*N) working storage for the +C matrix V, a packed (or unpacked) copy of Su, and save Su in V. +C (The locations for TAU are reused here.) +C + KV = KTAU + IF ( LDWORK-KV+1.LT.N*( N + 5 ) ) THEN + PACKED = .TRUE. + CALL MA02DD( 'Pack', 'Upper', N, TI, LDTI, DWORK(KV) ) + KW = KV + ( N*( N + 1 ) )/2 + ELSE + PACKED = .FALSE. + CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) + KW = KV + N*N + END IF +C | x x | +C Compute Ru*Su in the form | 0 x | in TI. +C + DO 10 J = 1, N + CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, + $ TI(1,J), 1 ) + 10 CONTINUE +C +C Compute the singular value decomposition Ru*Su = V*S*UT +C of the upper triangular matrix Ru*Su, with UT in TI and V in U. +C +C Workspace: need N*MAX(N,M,P) + N*(N+1)/2 + 5*N; +C prefer larger. +C + CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + ENDIF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Scale singular values. +C + CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) +C +C Partition S, U and V conformally as: +C +C S = diag(S1,S2), U = [U1,U2] (U' in TI) and V = [V1,V2] (in U). +C +C Compute the order of reduced system, as the order of S1. +C + ATOL = RTOL*HSV(1) + IF( FIXORD ) THEN + IF( NR.GT.0 ) THEN + IF( HSV(NR).LE.ATOL ) THEN + NR = 0 + IWARN = 1 + FIXORD = .FALSE. + ENDIF + ENDIF + ELSE + ATOL = MAX( TOL, ATOL ) + NR = 0 + ENDIF + IF( .NOT.FIXORD ) THEN + DO 20 J = 1, N + IF( HSV(J).LE.ATOL ) GO TO 30 + NR = NR + 1 + 20 CONTINUE + 30 CONTINUE + ENDIF +C + IF( NR.EQ.0 ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C +C Compute the truncation matrices. +C +C Compute TI' = Ru'*V1 in U. +C + CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NR, ONE, + $ T, LDT, DWORK(KU), N ) +C +C Compute T = Su*U1 (with Su packed, if not enough workspace). +C + CALL MA02AD( 'Full', NR, N, TI, LDTI, T, LDT ) + IF ( PACKED ) THEN + DO 40 J = 1, NR + CALL DTPMV( 'Upper', 'NoTranspose', 'NonUnit', N, DWORK(KV), + $ T(1,J), 1 ) + 40 CONTINUE + ELSE + CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, NR, + $ ONE, DWORK(KV), N, T, LDT ) + END IF +C + IF( BAL ) THEN + IJ = KU +C +C Square-Root B & T method. +C +C Compute the truncation matrices for balancing +C -1/2 -1/2 +C T*S1 and TI'*S1 +C + DO 50 J = 1, NR + TEMP = ONE/SQRT( HSV(J) ) + CALL DSCAL( N, TEMP, T(1,J), 1 ) + CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) + IJ = IJ + N + 50 CONTINUE + ELSE +C +C Balancing-Free B & T method. +C +C Compute orthogonal bases for the images of matrices T and TI'. +C +C Workspace: need N*MAX(N,M,P) + 2*NR; +C prefer N*MAX(N,M,P) + NR*(NB+1) +C (NB determined by ILAENV for DGEQRF). +C + KW = KTAU + NR + LDW = LDWORK - KW + 1 + CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) + CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF +C +C Transpose TI' to obtain TI. +C + CALL MA02AD( 'Full', N, NR, DWORK(KU), N, TI, LDTI ) +C + IF( .NOT.BAL ) THEN +C -1 +C Compute (TI*T) *TI in TI. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, + $ LDTI, T, LDT, ZERO, DWORK(KU), N ) + CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) + CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, + $ LDTI, IERR ) + END IF +C +C Compute TI*A*T (A is in RSF). +C + IJ = KU + DO 60 J = 1, N + K = MIN( J+1, N ) + CALL DGEMV( 'NoTranspose', NR, K, ONE, TI, LDTI, A(1,J), 1, + $ ZERO, DWORK(IJ), 1 ) + IJ = IJ + N + 60 CONTINUE + CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, + $ DWORK(KU), N, T, LDT, ZERO, A, LDA ) +C +C Compute TI*B and C*T. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, M, N, ONE, TI, LDTI, + $ DWORK(KU), N, ZERO, B, LDB ) +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NR, N, ONE, + $ DWORK(KU), P, T, LDT, ZERO, C, LDC ) +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB09AX *** + END diff --git a/mex/sources/libslicot/AB09BD.f b/mex/sources/libslicot/AB09BD.f new file mode 100644 index 000000000..0aa01b394 --- /dev/null +++ b/mex/sources/libslicot/AB09BD.f @@ -0,0 +1,385 @@ + SUBROUTINE AB09BD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, A, LDA, + $ B, LDB, C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK, + $ DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable +C original state-space representation (A,B,C,D) by using either the +C square-root or the balancing-free square-root Singular +C Perturbation Approximation (SPA) model reduction method. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root SPA method; +C = 'N': use the balancing-free square-root SPA method. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR +C is the desired order on entry and NMIN is the order of a +C minimal realization of the given system; NMIN is +C determined as the number of Hankel singular values greater +C than N*EPS*HNORM(A,B,C), where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH) and +C HNORM(A,B,C) is the Hankel norm of the system (computed +C in HSV(1)); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the Hankel singular values of +C the original system ordered decreasingly. HSV(1) is the +C Hankel norm of the system. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(A,B,C), where c is a constant in the +C interval [0.00001,0.001], and HNORM(A,B,C) is the +C Hankel-norm of the given system (computed in HSV(1)). +C For computing a minimal realization, the recommended +C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the +C machine precision (see LAPACK Library Routine DLAMCH). +C This value is used by default if TOL1 <= 0 on entry. +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the given system. The recommended value is +C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default +C if TOL2 <= 0 on entry. +C If TOL2 > 0, then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension MAX(1,2*N) +C On exit with INFO = 0, IWORK(1) contains the order of the +C minimal realization of the system. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5)+N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than the order of a minimal realization of the +C given system. In this case, the resulting NR is +C set automatically to a value corresponding to the +C order of a minimal realization of the system. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to the real Schur form failed; +C = 2: the state matrix A is not stable (if DICO = 'C') +C or not convergent (if DICO = 'D'); +C = 3: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09BD determines for +C the given system (1), the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t) (2) +C +C such that +C +C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C If JOB = 'B', the balancing-based square-root SPA method of [1] +C is used and the resulting model is balanced. +C +C If JOB = 'N', the balancing-free square-root SPA method of [2] +C is used. +C By setting TOL1 = TOL2, the routine can be used to compute +C Balance & Truncate approximations. +C +C REFERENCES +C +C [1] Liu Y. and Anderson B.D.O. +C Singular Perturbation Approximation of Balanced Systems, +C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. +C +C [2] Varga A. +C Balancing-free square-root algorithm for computing singular +C perturbation approximations. +C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, +C Vol. 2, pp. 1062-1065. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine SRBFSP. +C +C REVISIONS +C +C May 2, 1998. +C November 11, 1998, V. Sima, Research Institute for Informatics, +C Bucharest. +C +C KEYWORDS +C +C Balancing, minimal state-space representation, model reduction, +C multivariable system, singular perturbation approximation, +C state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, C100 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, + $ M, N, NR, P + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL FIXORD + INTEGER IERR, KI, KR, KT, KTI, KW, NN + DOUBLE PRECISION MAXRED, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB09BX, TB01ID, TB01WD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. LSAME( DICO, 'D' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -14 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN + INFO = -19 + ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2 ) ) THEN + INFO = -22 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09BD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Allocate working storage. +C + NN = N*N + KT = 1 + KR = KT + NN + KI = KR + N + KW = KI + N +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Reduce A to the real Schur form using an orthogonal similarity +C transformation A <- T'*A*T and apply the transformation to +C B and C: B <- T'*B and C <- C*T. +C + CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, DWORK(KT), N, + $ DWORK(KR), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C + KTI = KT + NN + KW = KTI + NN + CALL AB09BX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, + $ C, LDC, D, LDD, HSV, DWORK(KT), N, DWORK(KTI), N, + $ TOL1, TOL2, IWORK, DWORK(KW), LDWORK-KW+1, IWARN, + $ IERR ) +C + IF( IERR.NE.0 ) THEN + INFO = IERR + 1 + RETURN + END IF +C + DWORK(1) = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) +C + RETURN +C *** Last line of AB09BD *** + END diff --git a/mex/sources/libslicot/AB09BX.f b/mex/sources/libslicot/AB09BX.f new file mode 100644 index 000000000..438babc5d --- /dev/null +++ b/mex/sources/libslicot/AB09BX.f @@ -0,0 +1,662 @@ + SUBROUTINE AB09BX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, + $ C, LDC, D, LDD, HSV, T, LDT, TI, LDTI, TOL1, + $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable +C original state-space representation (A,B,C,D) by using either the +C square-root or the balancing-free square-root +C Singular Perturbation Approximation (SPA) model reduction method. +C The state dynamics matrix A of the original system is an upper +C quasi-triangular matrix in real Schur canonical form. The matrices +C of a minimal realization are computed using the truncation +C formulas: +C +C Am = TI * A * T , Bm = TI * B , Cm = C * T . (1) +C +C Am, Bm, Cm and D serve further for computing the SPA of the given +C system. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root SPA method; +C = 'N': use the balancing-free square-root SPA method. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR +C is the desired order on entry and NMIN is the order of a +C minimal realization of the given system; NMIN is +C determined as the number of Hankel singular values greater +C than N*EPS*HNORM(A,B,C), where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH) and +C HNORM(A,B,C) is the Hankel norm of the system (computed +C in HSV(1)); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A in a real Schur +C canonical form. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the Hankel singular values of +C the original system ordered decreasingly. HSV(1) is the +C Hankel norm of the system. +C +C T (output) DOUBLE PRECISION array, dimension (LDT,N) +C If INFO = 0 and NR > 0, the leading N-by-NR part of this +C array contains the right truncation matrix T in (1). +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,N). +C +C TI (output) DOUBLE PRECISION array, dimension (LDTI,N) +C If INFO = 0 and NR > 0, the leading NR-by-N part of this +C array contains the left truncation matrix TI in (1). +C +C LDTI INTEGER +C The leading dimension of array TI. LDTI >= MAX(1,N). +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(A,B,C), where c is a constant in the +C interval [0.00001,0.001], and HNORM(A,B,C) is the +C Hankel-norm of the given system (computed in HSV(1)). +C For computing a minimal realization, the recommended +C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the +C machine precision (see LAPACK Library Routine DLAMCH). +C This value is used by default if TOL1 <= 0 on entry. +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the given system. The recommended value is +C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default +C if TOL2 <= 0 on entry. +C If TOL2 > 0, then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension MAX(1,2*N) +C On exit with INFO = 0, IWORK(1) contains the order of the +C minimal realization of the system. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*(MAX(N,M,P)+5) + N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than the order of a minimal realization of the +C given system. In this case, the resulting NR is +C set automatically to a value corresponding to the +C order of a minimal realization of the system. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the state matrix A is not stable (if DICO = 'C') +C or not convergent (if DICO = 'D'); +C = 2: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t) (2) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09BX determines for +C the given system (1), the matrices of a reduced NR order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t) (3) +C +C such that +C +C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C If JOB = 'B', the balancing-based square-root SPA method of [1] +C is used and the resulting model is balanced. +C +C If JOB = 'N', the balancing-free square-root SPA method of [2] +C is used. +C By setting TOL1 = TOL2, the routine can be also used to compute +C Balance & Truncate approximations. +C +C REFERENCES +C +C [1] Liu Y. and Anderson B.D.O. +C Singular Perturbation Approximation of Balanced Systems, +C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. +C +C [2] Varga A. +C Balancing-free square-root algorithm for computing singular +C perturbation approximations. +C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, +C Vol. 2, pp. 1062-1065. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine SRBFP1. +C +C REVISIONS +C +C May 2, 1998. +C November 11, 1998, V. Sima, Research Institute for Informatics, +C Bucharest. +C December 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C February 14, 1999, A. Varga, German Aerospace Center. +C February 22, 1999, V. Sima, Research Institute for Informatics. +C February 27, 2000, V. Sima, Research Institute for Informatics. +C May 26, 2000, A. Varga, German Aerospace Center. +C +C KEYWORDS +C +C Balancing, minimal state-space representation, model reduction, +C multivariable system, singular perturbation approximation, +C state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDT, LDTI, + $ LDWORK, M, N, NR, P + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*), T(LDT,*), TI(LDTI,*) +C .. Local Scalars .. + LOGICAL BAL, DISCR, FIXORD, PACKED + INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, NMINR, + $ NR1, NS, WRKOPT + DOUBLE PRECISION ATOL, RCOND, RTOL, SCALEC, SCALEO, TEMP +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB09DD, DGEMM, DGEMV, DGEQRF, DGETRF, DGETRS, + $ DLACPY, DORGQR, DSCAL, DTPMV, DTRMM, DTRMV, + $ MA02AD, MA02DD, MB03UD, SB03OU, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + BAL = LSAME( JOB, 'B' ) + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( BAL .OR. LSAME( JOB, 'N') ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN + INFO = -20 + ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN + INFO = -22 + ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2 ) ) THEN + INFO = -25 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09BX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C + RTOL = DBLE( N )*DLAMCH( 'Epsilon' ) +C +C Allocate N*MAX(N,M,P) and N working storage for the matrices U +C and TAU, respectively. +C + KU = 1 + KTAU = KU + N*MAX( N, M, P ) + KW = KTAU + N + LDW = LDWORK - KW + 1 +C +C Copy B in U. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) +C +C If DISCR = .FALSE., solve for Su the Lyapunov equation +C 2 +C A*(Su*Su') + (Su*Su')*A' + scalec *B*B' = 0 . +C +C If DISCR = .TRUE., solve for Su the Lyapunov equation +C 2 +C A*(Su*Su')*A' + scalec *B*B' = Su*Su' . +C +C Workspace: need N*(MAX(N,M,P) + 5); +C prefer larger. +C + CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KU), N, + $ DWORK(KTAU), TI, LDTI, SCALEC, DWORK(KW), LDW, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + ENDIF + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Copy C in U. +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) +C +C If DISCR = .FALSE., solve for Ru the Lyapunov equation +C 2 +C A'*(Ru'*Ru) + (Ru'*Ru)*A + scaleo * C'*C = 0 . +C +C If DISCR = .TRUE., solve for Ru the Lyapunov equation +C 2 +C A'*(Ru'*Ru)*A + scaleo * C'*C = Ru'*Ru . +C +C Workspace: need N*(MAX(N,M,P) + 5); +C prefer larger. +C + CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), P, + $ DWORK(KTAU), T, LDT, SCALEO, DWORK(KW), LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Allocate N*(N+1)/2 (or, if possible, N*N) working storage for the +C matrix V, a packed (or unpacked) copy of Su, and save Su in V. +C (The locations for TAU are reused here.) +C + KV = KTAU + IF ( LDWORK-KV+1.LT.N*( N + 5 ) ) THEN + PACKED = .TRUE. + CALL MA02DD( 'Pack', 'Upper', N, TI, LDTI, DWORK(KV) ) + KW = KV + ( N*( N + 1 ) )/2 + ELSE + PACKED = .FALSE. + CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) + KW = KV + N*N + END IF +C | x x | +C Compute Ru*Su in the form | 0 x | in TI. +C + DO 10 J = 1, N + CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, + $ TI(1,J), 1 ) + 10 CONTINUE +C +C Compute the singular value decomposition Ru*Su = V*S*UT +C of the upper triangular matrix Ru*Su, with UT in TI and V in U. +C +C Workspace: need N*MAX(N,M,P) + N*(N+1)/2 + 5*N; +C prefer larger. +C + CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + ENDIF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Scale singular values. +C + CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) +C +C Partition S, U and V conformally as: +C +C S = diag(S1,S2,S3), U = [U1,U2,U3] (U' in TI) and V = [V1,V2,V3] +C (in U). +C +C Compute the order NR of reduced system, as the order of S1. +C + ATOL = RTOL*HSV(1) + IF( FIXORD ) THEN + IF( NR.GT.0 ) THEN + IF( HSV(NR).LE.ATOL ) THEN + NR = 0 + IWARN = 1 + FIXORD = .FALSE. + ENDIF + ENDIF + ELSE + ATOL = MAX( TOL1, ATOL ) + NR = 0 + ENDIF + IF( .NOT.FIXORD ) THEN + DO 20 J = 1, N + IF( HSV(J).LE.ATOL ) GO TO 30 + NR = NR + 1 + 20 CONTINUE + 30 CONTINUE + ENDIF +C +C Finish if the order of the reduced model is zero. +C + IF( NR.EQ.0 ) THEN +C +C Compute only Dr using singular perturbation formulas. +C Workspace: need real 4*N; +C need integer 2*N. +C + CALL AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC, D, + $ LDD, RCOND, IWORK, DWORK, IERR ) + IWORK(1) = 0 + DWORK(1) = WRKOPT + RETURN + END IF +C +C Compute the order of minimal realization as the order of [S1 S2]. +C + NR1 = NR + 1 + NMINR = NR + IF( NR.LT.N ) THEN + ATOL = MAX( TOL2, RTOL*HSV(1) ) + DO 40 J = NR1, N + IF( HSV(J).LE.ATOL ) GO TO 50 + NMINR = NMINR + 1 + 40 CONTINUE + 50 CONTINUE + END IF +C +C Compute the order of S2. +C + NS = NMINR - NR +C +C Compute the truncation matrices. +C +C Compute TI' = | TI1' TI2' | = Ru'*| V1 V2 | in U. +C + CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NMINR, + $ ONE, T, LDT, DWORK(KU), N ) +C +C Compute T = | T1 T2 | = Su*| U1 U2 | +C (with Su packed, if not enough workspace). +C + CALL MA02AD( 'Full', NMINR, N, TI, LDTI, T, LDT ) + IF ( PACKED ) THEN + DO 60 J = 1, NMINR + CALL DTPMV( 'Upper', 'NoTranspose', 'NonUnit', N, DWORK(KV), + $ T(1,J), 1 ) + 60 CONTINUE + ELSE + CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, + $ NMINR, ONE, DWORK(KV), N, T, LDT ) + END IF +C + IF( BAL ) THEN + IJ = KU +C +C Square-Root SPA method. +C +C Compute the truncation matrices for balancing +C -1/2 -1/2 +C T1*S1 and TI1'*S1 +C + DO 70 J = 1, NR + TEMP = ONE/SQRT( HSV(J) ) + CALL DSCAL( N, TEMP, T(1,J), 1 ) + CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) + IJ = IJ + N + 70 CONTINUE + ELSE +C +C Balancing-Free SPA method. +C +C Compute orthogonal bases for the images of matrices T1 and +C TI1'. +C +C Workspace: need N*MAX(N,M,P) + 2*NR; +C prefer N*MAX(N,M,P) + NR*(NB+1) +C (NB determined by ILAENV for DGEQRF). +C + KW = KTAU + NR + LDW = LDWORK - KW + 1 + CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) + CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + ENDIF + IF( NS.GT.0 ) THEN +C +C Compute orthogonal bases for the images of matrices T2 and +C TI2'. +C +C Workspace: need N*MAX(N,M,P) + 2*NS; +C prefer N*MAX(N,M,P) + NS*(NB+1) +C (NB determined by ILAENV for DGEQRF). + KW = KTAU + NS + LDW = LDWORK - KW + 1 + CALL DGEQRF( N, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + CALL DORGQR( N, NS, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + CALL DGEQRF( N, NS, DWORK(KU+N*NR), N, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL DORGQR( N, NS, NS, DWORK(KU+N*NR), N, DWORK(KTAU), + $ DWORK(KW), LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + ENDIF +C +C Transpose TI' in TI. +C + CALL MA02AD( 'Full', N, NMINR, DWORK(KU), N, TI, LDTI ) +C + IF( .NOT.BAL ) THEN +C -1 +C Compute (TI1*T1) *TI1 in TI. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, + $ LDTI, T, LDT, ZERO, DWORK(KU), N ) + CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) + CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, + $ LDTI, IERR ) +C + IF( NS.GT.0 ) THEN +C -1 +C Compute (TI2*T2) *TI2 in TI2. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NS, NS, N, ONE, + $ TI(NR1,1), LDTI, T(1,NR1), LDT, ZERO, DWORK(KU), + $ N ) + CALL DGETRF( NS, NS, DWORK(KU), N, IWORK, IERR ) + CALL DGETRS( 'NoTranspose', NS, N, DWORK(KU), N, IWORK, + $ TI(NR1,1), LDTI, IERR ) + END IF + END IF +C +C Compute TI*A*T (A is in RSF). +C + IJ = KU + DO 80 J = 1, N + K = MIN( J+1, N ) + CALL DGEMV( 'NoTranspose', NMINR, K, ONE, TI, LDTI, A(1,J), 1, + $ ZERO, DWORK(IJ), 1 ) + IJ = IJ + N + 80 CONTINUE + CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, NMINR, N, ONE, + $ DWORK(KU), N, T, LDT, ZERO, A, LDA ) +C +C Compute TI*B and C*T. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, M, N, ONE, TI, + $ LDTI, DWORK(KU), N, ZERO, B, LDB ) +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NMINR, N, ONE, + $ DWORK(KU), P, T, LDT, ZERO, C, LDC ) +C +C Compute the singular perturbation approximation if possible. +C Note that IERR = 1 on exit from AB09DD cannot appear here. +C +C Workspace: need real 4*(NMINR-NR); +C need integer 2*(NMINR-NR). +C + CALL AB09DD( DICO, NMINR, M, P, NR, A, LDA, B, LDB, C, LDC, D, + $ LDD, RCOND, IWORK, DWORK, IERR ) +C + IWORK(1) = NMINR + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB09BX *** + END diff --git a/mex/sources/libslicot/AB09CD.f b/mex/sources/libslicot/AB09CD.f new file mode 100644 index 000000000..01567db21 --- /dev/null +++ b/mex/sources/libslicot/AB09CD.f @@ -0,0 +1,375 @@ + SUBROUTINE AB09CD( DICO, EQUIL, ORDSEL, N, M, P, NR, A, LDA, B, + $ LDB, C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK, + $ DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable +C original state-space representation (A,B,C,D) by using the +C optimal Hankel-norm approximation method in conjunction with +C square-root balancing. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(MAX(0,NR-KR+1),NMIN), +C where KR is the multiplicity of the Hankel singular value +C HSV(NR+1), NR is the desired order on entry, and NMIN is +C the order of a minimal realization of the given system; +C NMIN is determined as the number of Hankel singular values +C greater than N*EPS*HNORM(A,B,C), where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH) and +C HNORM(A,B,C) is the Hankel norm of the system (computed +C in HSV(1)); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system in a real Schur form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the Hankel singular values of +C the original system ordered decreasingly. HSV(1) is the +C Hankel norm of the system. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(A,B,C), where c is a constant in the +C interval [0.00001,0.001], and HNORM(A,B,C) is the +C Hankel-norm of the given system (computed in HSV(1)). +C For computing a minimal realization, the recommended +C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the +C machine precision (see LAPACK Library Routine DLAMCH). +C This value is used by default if TOL1 <= 0 on entry. +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the given system. The recommended value is +C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default +C if TOL2 <= 0 on entry. +C If TOL2 > 0, then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = MAX(1,M), if DICO = 'C'; +C LIWORK = MAX(1,N,M), if DICO = 'D'. +C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of +C the computed minimal realization. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( LDW1, LDW2 ), where +C LDW1 = N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2, +C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + +C MAX( 3*M+1, MIN(N,M)+P ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than the order of a minimal realization of the +C given system. In this case, the resulting NR is set +C automatically to a value corresponding to the order +C of a minimal realization of the system. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to the real Schur form failed; +C = 2: the state matrix A is not stable (if DICO = 'C') +C or not convergent (if DICO = 'D'); +C = 3: the computation of Hankel singular values failed; +C = 4: the computation of stable projection failed; +C = 5: the order of computed stable projection differs +C from the order of Hankel-norm approximation. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09CD determines for +C the given system (1), the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t) (2) +C +C such that +C +C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C The optimal Hankel-norm approximation method of [1], based on the +C square-root balancing projection formulas of [2], is employed. +C +C REFERENCES +C +C [1] Glover, K. +C All optimal Hankel norm approximation of linear +C multivariable systems and their L-infinity error bounds. +C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. +C +C [2] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on an accuracy enhancing square-root +C technique. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, April 1998. +C Based on the RASP routine OHNAP. +C +C REVISIONS +C +C November 11, 1998, V. Sima, Research Institute for Informatics, +C Bucharest. +C March 26, 2005, V. Sima, Research Institute for Informatics. +C +C KEYWORDS +C +C Balancing, Hankel-norm approximation, model reduction, +C multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, C100 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, + $ M, N, NR, P + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL FIXORD + INTEGER IERR, KI, KL, KT, KW + DOUBLE PRECISION MAXRED, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB09CX, TB01ID, TB01WD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Check the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. LSAME( DICO, 'D' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN + INFO = -18 + ELSE IF( LDWORK.LT.MAX( N*( 2*N + MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2, + $ N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + + $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) ) THEN + INFO = -21 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09CD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Reduce A to the real Schur form using an orthogonal similarity +C transformation A <- T'*A*T and apply the transformation to B +C and C: B <- T'*B and C <- C*T. +C + KT = 1 + KL = KT + N*N + KI = KL + N + KW = KI + N + CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, DWORK(KT), N, + $ DWORK(KL), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C + CALL AB09CX( DICO, ORDSEL, N, M, P, NR, A, LDA, B, LDB, C, LDC, + $ D, LDD, HSV, TOL1, TOL2, IWORK, DWORK, LDWORK, + $ IWARN, IERR ) +C + IF( IERR.NE.0 ) THEN + INFO = IERR + 1 + RETURN + END IF +C + DWORK(1) = MAX( WRKOPT, DWORK(1) ) +C + RETURN +C *** Last line of AB09CD *** + END diff --git a/mex/sources/libslicot/AB09CX.f b/mex/sources/libslicot/AB09CX.f new file mode 100644 index 000000000..7644d7992 --- /dev/null +++ b/mex/sources/libslicot/AB09CX.f @@ -0,0 +1,558 @@ + SUBROUTINE AB09CX( DICO, ORDSEL, N, M, P, NR, A, LDA, B, LDB, + $ C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK, + $ DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable +C original state-space representation (A,B,C,D) by using the optimal +C Hankel-norm approximation method in conjunction with square-root +C balancing. The state dynamics matrix A of the original system is +C an upper quasi-triangular matrix in real Schur canonical form. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(MAX(0,NR-KR+1),NMIN), +C where KR is the multiplicity of the Hankel singular value +C HSV(NR+1), NR is the desired order on entry, and NMIN is +C the order of a minimal realization of the given system; +C NMIN is determined as the number of Hankel singular values +C greater than N*EPS*HNORM(A,B,C), where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH) and +C HNORM(A,B,C) is the Hankel norm of the system (computed +C in HSV(1)); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A in a real Schur +C canonical form. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system in a real Schur form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the Hankel singular values of +C the original system ordered decreasingly. HSV(1) is the +C Hankel norm of the system. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(A,B,C), where c is a constant in the +C interval [0.00001,0.001], and HNORM(A,B,C) is the +C Hankel-norm of the given system (computed in HSV(1)). +C For computing a minimal realization, the recommended +C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the +C machine precision (see LAPACK Library Routine DLAMCH). +C This value is used by default if TOL1 <= 0 on entry. +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the given system. The recommended value is +C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default +C if TOL2 <= 0 on entry. +C If TOL2 > 0, then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = MAX(1,M), if DICO = 'C'; +C LIWORK = MAX(1,N,M), if DICO = 'D'. +C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of +C the computed minimal realization. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( LDW1,LDW2 ), where +C LDW1 = N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2, +C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + +C MAX( 3*M+1, MIN(N,M)+P ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than the order of a minimal realization of the +C given system. In this case, the resulting NR is set +C automatically to a value corresponding to the order +C of a minimal realization of the system. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the state matrix A is not stable (if DICO = 'C') +C or not convergent (if DICO = 'D'); +C = 2: the computation of Hankel singular values failed; +C = 3: the computation of stable projection failed; +C = 4: the order of computed stable projection differs +C from the order of Hankel-norm approximation. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09CX determines for +C the given system (1), the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t) (2) +C +C such that +C +C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C The optimal Hankel-norm approximation method of [1], based on the +C square-root balancing projection formulas of [2], is employed. +C +C REFERENCES +C +C [1] Glover, K. +C All optimal Hankel norm approximation of linear +C multivariable systems and their L-infinity error bounds. +C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. +C +C [2] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on an accuracy enhancing square-root +C technique. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, April 1998. +C Based on the RASP routine OHNAP1. +C +C REVISIONS +C +C November 11, 1998, V. Sima, Research Institute for Informatics, +C Bucharest. +C April 24, 2000, A. Varga, DLR Oberpfaffenhofen. +C April 8, 2001, A. Varga, DLR Oberpfaffenhofen. +C March 26, 2005, V. Sima, Research Institute for Informatics. +C +C KEYWORDS +C +C Balancing, Hankel-norm approximation, model reduction, +C multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, + $ M, N, NR, P + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*) +C .. Local Scalars + LOGICAL DISCR, FIXORD + INTEGER I, I1, IERR, IRANK, J, KB1, KB2, KC1, KC2T, + $ KHSVP, KHSVP2, KR, KT, KTI, KU, KW, KW1, KW2, + $ LDB1, LDB2, LDC1, LDC2T, NA, NDIM, NKR1, NMINR, + $ NR1, NU, WRKOPT + DOUBLE PRECISION ATOL, RTOL, SKP, SKP2, SRRTOL +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB04MD, AB09AX, DAXPY, DCOPY, DGELSY, DGEMM, + $ DLACPY, DSWAP, MA02AD, MB01SD, TB01KD, TB01WD, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Check the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -14 + ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN + INFO = -17 + ELSE IF( LDWORK.LT.MAX( N*( 2*N + MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2, + $ N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + + $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) ) THEN + INFO = -20 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09CX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C + RTOL = DBLE( N )*DLAMCH( 'Epsilon' ) + SRRTOL = SQRT( RTOL ) +C +C Allocate working storage. +C + KT = 1 + KTI = KT + N*N + KW = KTI + N*N +C +C Compute a minimal order balanced realization of the given system. +C Workspace: need N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2; +C prefer larger. +C + CALL AB09AX( DICO, 'Balanced', 'Automatic', N, M, P, NMINR, A, + $ LDA, B, LDB, C, LDC, HSV, DWORK(KT), N, DWORK(KTI), + $ N, TOL2, IWORK, DWORK(KW), LDWORK-KW+1, IWARN, INFO ) +C + IF( INFO.NE.0 ) + $ RETURN + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Compute the order of reduced system. +C + ATOL = RTOL*HSV(1) + IF( FIXORD ) THEN + IF( NR.GT.0 ) THEN + IF( NR.GT.NMINR ) THEN + NR = NMINR + IWARN = 1 + ENDIF + ENDIF + ELSE + ATOL = MAX( TOL1, ATOL ) + NR = 0 + DO 10 I = 1, NMINR + IF( HSV(I).LE.ATOL ) GO TO 20 + NR = NR + 1 + 10 CONTINUE + 20 CONTINUE + ENDIF +C + IF( NR.EQ.NMINR ) THEN + IWORK(1) = NMINR + DWORK(1) = WRKOPT + KW = N*(N+2)+1 +C +C Reduce Ar to a real Schur form. +C + CALL TB01WD( NMINR, M, P, A, LDA, B, LDB, C, LDC, + $ DWORK(2*N+1), N, DWORK, DWORK(N+1), DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF + RETURN + END IF + SKP = HSV(NR+1) +C +C If necessary, reduce the order such that HSV(NR) > HSV(NR+1). +C + 30 IF( NR.GT.0 ) THEN + IF( ABS( HSV(NR)-SKP ).LE.SRRTOL*SKP ) THEN + NR = NR - 1 + GO TO 30 + END IF + END IF +C +C Determine KR, the multiplicity of HSV(NR+1). +C + KR = 1 + DO 40 I = NR+2, NMINR + IF( ABS( HSV(I)-SKP ).GT.SRRTOL*SKP ) GO TO 50 + KR = KR + 1 + 40 CONTINUE + 50 CONTINUE +C +C For discrete-time case, apply the discrete-to-continuous bilinear +C transformation. +C + IF( DISCR ) THEN +C +C Workspace: need N; +C prefer larger. +C + CALL AB04MD( 'Discrete', NMINR, M, P, ONE, ONE, A, LDA, B, LDB, + $ C, LDC, D, LDD, IWORK, DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + END IF +C +C Define leading dimensions and offsets for temporary data. +C + NU = NMINR - NR - KR + NA = NR + NU + LDB1 = NA + LDC1 = P + LDB2 = KR + LDC2T = MAX( KR, M ) + NR1 = NR + 1 + NKR1 = MIN( NMINR, NR1 + KR ) +C + KHSVP = 1 + KHSVP2 = KHSVP + NA + KU = KHSVP2 + NA + KB1 = KU + P*M + KB2 = KB1 + LDB1*M + KC1 = KB2 + LDB2*M + KC2T = KC1 + LDC1*NA + KW = KC2T + LDC2T*P +C +C Save B2 and C2'. +C + CALL DLACPY( 'Full', KR, M, B(NR1,1), LDB, DWORK(KB2), LDB2 ) + CALL MA02AD( 'Full', P, KR, C(1,NR1), LDC, DWORK(KC2T), LDC2T ) + IF( NR.GT.0 ) THEN +C +C Permute the elements of HSV and of matrices A, B, C. +C + CALL DCOPY( NR, HSV(1), 1, DWORK(KHSVP), 1 ) + CALL DCOPY( NU, HSV(NKR1), 1, DWORK(KHSVP+NR), 1 ) + CALL DLACPY( 'Full', NMINR, NU, A(1,NKR1), LDA, A(1,NR1), LDA ) + CALL DLACPY( 'Full', NU, NA, A(NKR1,1), LDA, A(NR1,1), LDA ) + CALL DLACPY( 'Full', NU, M, B(NKR1,1), LDB, B(NR1,1), LDB ) + CALL DLACPY( 'Full', P, NU, C(1,NKR1), LDC, C(1,NR1), LDC ) +C +C Save B1 and C1. +C + CALL DLACPY( 'Full', NA, M, B, LDB, DWORK(KB1), LDB1 ) + CALL DLACPY( 'Full', P, NA, C, LDC, DWORK(KC1), LDC1 ) + END IF +C +C Compute U = C2*pinv(B2'). +C Workspace: need N*(M+P+2) + 2*M*P + +C max(min(KR,M)+3*M+1,2*min(KR,M)+P); +C prefer N*(M+P+2) + 2*M*P + +C max(min(KR,M)+2*M+(M+1)*NB,2*min(KR,M)+P*NB), +C where NB is the maximum of the block sizes for +C DGEQP3, DTZRZF, DTZRQF, DORMQR, and DORMRZ. +C + DO 55 J = 1, M + IWORK(J) = 0 + 55 CONTINUE + CALL DGELSY( KR, M, P, DWORK(KB2), LDB2, DWORK(KC2T), LDC2T, + $ IWORK, RTOL, IRANK, DWORK(KW), LDWORK-KW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL MA02AD( 'Full', M, P, DWORK(KC2T), LDC2T, DWORK(KU), P ) +C +C Compute D <- D + HSV(NR+1)*U. +C + I = KU + DO 60 J = 1, M + CALL DAXPY( P, SKP, DWORK(I), 1, D(1,J), 1 ) + I = I + P + 60 CONTINUE +C + IF( NR.GT.0 ) THEN + SKP2 = SKP*SKP +C +C Compute G = inv(S1*S1-skp*skp*I), where S1 is the diagonal +C matrix of relevant singular values (of order NMINR - KR). +C + I1 = KHSVP2 + DO 70 I = KHSVP, KHSVP+NA-1 + DWORK(I1) = ONE / ( DWORK(I)*DWORK(I) - SKP2 ) + I1 = I1 + 1 + 70 CONTINUE +C +C Compute C <- C1*S1-skp*U*B1'. +C + CALL MB01SD( 'Column', P, NA, C, LDC, DWORK, DWORK(KHSVP) ) + CALL DGEMM( 'NoTranspose', 'Transpose', P, NA, M, -SKP, + $ DWORK(KU), P, DWORK(KB1), LDB1, ONE, C, LDC ) +C +C Compute B <- G*(S1*B1-skp*C1'*U). +C + CALL MB01SD( 'Row', NA, M, B, LDB, DWORK(KHSVP), DWORK ) + CALL DGEMM( 'Transpose', 'NoTranspose', NA, M, P, -SKP, + $ DWORK(KC1), LDC1, DWORK(KU), P, ONE, B, LDB ) + CALL MB01SD( 'Row', NA, M, B, LDB, DWORK(KHSVP2), DWORK ) +C +C Compute A <- -A1' - B*B1'. +C + DO 80 J = 2, NA + CALL DSWAP( J-1, A(1,J), 1, A(J,1), LDA ) + 80 CONTINUE + CALL DGEMM( 'NoTranspose', 'Transpose', NA, NA, M, -ONE, B, + $ LDB, DWORK(KB1), LDB1, -ONE, A, LDA ) +C +C Extract stable part. +C Workspace: need N*N+5*N; +C prefer larger. +C + KW1 = NA*NA + 1 + KW2 = KW1 + NA + KW = KW2 + NA + CALL TB01KD( 'Continuous', 'Stability', 'General', NA, M, P, + $ ZERO, A, LDA, B, LDB, C, LDC, NDIM, DWORK, NA, + $ DWORK(KW1), DWORK(KW2), DWORK(KW), LDWORK-KW+1, + $ IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C + IF( NDIM.NE.NR ) THEN + INFO = 4 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C For discrete-time case, apply the continuous-to-discrete +C bilinear transformation. +C + IF( DISCR ) + $ CALL AB04MD( 'Continuous', NR, M, P, ONE, ONE, A, LDA, B, + $ LDB, C, LDC, D, LDD, IWORK, DWORK, LDWORK, + $ INFO ) + END IF + IWORK(1) = NMINR + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB09CX *** + END diff --git a/mex/sources/libslicot/AB09DD.f b/mex/sources/libslicot/AB09DD.f new file mode 100644 index 000000000..0ba78924c --- /dev/null +++ b/mex/sources/libslicot/AB09DD.f @@ -0,0 +1,278 @@ + SUBROUTINE AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC, + $ D, LDD, RCOND, IWORK, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model by using singular perturbation +C approximation formulas. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the state vector, i.e. the order of the +C matrix A; also the number of rows of matrix B and the +C number of columns of the matrix C. N >= 0. +C +C M (input) INTEGER +C The dimension of input vector, i.e. the number of columns +C of matrices B and D. M >= 0. +C +C P (input) INTEGER +C The dimension of output vector, i.e. the number of rows of +C matrices C and D. P >= 0. +C +C NR (input) INTEGER +C The order of the reduced order system. N >= NR >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix of the original system. +C On exit, the leading NR-by-NR part of this array contains +C the state dynamics matrix Ar of the reduced order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix of the original system. +C On exit, the leading NR-by-M part of this array contains +C the input/state matrix Br of the reduced order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix of the original system. +C On exit, the leading P-by-NR part of this array contains +C the state/output matrix Cr of the reduced order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the input/output matrix of the original system. +C On exit, the leading P-by-M part of this array contains +C the input/output matrix Dr of the reduced order system. +C If NR = 0 and the given system is stable, then D contains +C the steady state gain of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C RCOND (output) DOUBLE PRECISION +C The reciprocal condition number of the matrix A22-g*I +C (see METHOD). +C +C Workspace +C +C IWORK INTEGER array, dimension 2*(N-NR) +C +C DWORK DOUBLE PRECISION array, dimension 4*(N-NR) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix A22-g*I (see METHOD) is numerically +C singular. +C +C METHOD +C +C Given the system (A,B,C,D), partition the system matrices as +C +C ( A11 A12 ) ( B1 ) +C A = ( ) , B = ( ) , C = ( C1 C2 ), +C ( A21 A22 ) ( B2 ) +C +C where A11 is NR-by-NR, B1 is NR-by-M, C1 is P-by-NR, and the other +C submatrices have appropriate dimensions. +C +C The matrices of the reduced order system (Ar,Br,Cr,Dr) are +C computed according to the following residualization formulas: +C -1 -1 +C Ar = A11 + A12*(g*I-A22) *A21 , Br = B1 + A12*(g*I-A22) *B2 +C -1 -1 +C Cr = C1 + C2*(g*I-A22) *A21 , Dr = D + C2*(g*I-A22) *B2 +C +C where g = 0 if DICO = 'C' and g = 1 if DICO = 'D'. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine SRESID. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Model reduction, multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO + INTEGER INFO, LDA, LDB, LDC, LDD, M, N, NR, P + DOUBLE PRECISION RCOND +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) + INTEGER IWORK(*) +C .. Local Scalars + LOGICAL DISCR + INTEGER I, J, K, NS + DOUBLE PRECISION A22NRM +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DGECON, DGEMM, DGETRF, DGETRS, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Check the input scalar arguments. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( NR.LT.0 .OR. NR.GT.N ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -13 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09DD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( NR.EQ.N ) THEN + RCOND = ONE + RETURN + END IF +C + K = NR + 1 + NS = N - NR +C +C Compute: T = -A22 if DICO = 'C' and +C T = -A22+I if DICO = 'D'. +C + DO 20 J = K, N + DO 10 I = K, N + A(I,J) = -A(I,J) + 10 CONTINUE + IF( DISCR ) A(J,J) = A(J,J) + ONE + 20 CONTINUE +C +C Compute the LU decomposition of T. +C + A22NRM = DLANGE( '1-norm', NS, NS, A(K,K), LDA, DWORK ) + CALL DGETRF( NS, NS, A(K,K), LDA, IWORK, INFO ) + IF( INFO.GT.0 ) THEN +C +C Error return. +C + RCOND = ZERO + INFO = 1 + RETURN + END IF + CALL DGECON( '1-norm', NS, A(K,K), LDA, A22NRM, RCOND, DWORK, + $ IWORK(NS+1), INFO ) + IF( RCOND.LE.DLAMCH('E') ) THEN +C +C Error return. +C + INFO = 1 + RETURN + END IF +C +C Compute A21 <- INV(T)*A21. +C + CALL DGETRS( 'NoTranspose', NS, NR, A(K,K), LDA, IWORK, A(K,1), + $ LDA, INFO ) +C +C Compute B2 <- INV(T)*B2. +C + CALL DGETRS( 'NoTranspose', NS, M, A(K,K), LDA, IWORK, B(K,1), + $ LDB, INFO ) +C +C Compute the residualized systems matrices. +C Ar = A11 + A12*INV(T)*A21. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, NS, ONE, A(1,K), + $ LDA, A(K,1), LDA, ONE, A, LDA ) +C +C Br = B1 + A12*INV(T)*B2. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, M, NS, ONE, A(1,K), + $ LDA, B(K,1), LDB, ONE, B, LDB ) +C +C Cr = C1 + C2*INV(T)*A21. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NR, NS, ONE, C(1,K), + $ LDC, A(K,1), LDA, ONE, C, LDC ) +C +C Dr = D + C2*INV(T)*B2. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, M, NS, ONE, C(1,K), + $ LDC, B(K,1), LDB, ONE, D, LDD ) +C + RETURN +C *** Last line of AB09DD *** + END diff --git a/mex/sources/libslicot/AB09ED.f b/mex/sources/libslicot/AB09ED.f new file mode 100644 index 000000000..7c3afb8e4 --- /dev/null +++ b/mex/sources/libslicot/AB09ED.f @@ -0,0 +1,493 @@ + SUBROUTINE AB09ED( DICO, EQUIL, ORDSEL, N, M, P, NR, ALPHA, + $ A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV, TOL1, + $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C state-space representation (A,B,C,D) by using the optimal +C Hankel-norm approximation method in conjunction with square-root +C balancing for the ALPHA-stable part of the system. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. For a system with NU ALPHA-unstable +C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), +C NR is set as follows: if ORDSEL = 'F', NR is equal to +C NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the +C multiplicity of the Hankel singular value HSV(NR-NU+1), +C NR is the desired order on entry, and NMIN is the order +C of a minimal realization of the ALPHA-stable part of the +C given system; NMIN is determined as the number of Hankel +C singular values greater than NS*EPS*HNORM(As,Bs,Cs), where +C EPS is the machine precision (see LAPACK Library Routine +C DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the +C ALPHA-stable part of the given system (computed in +C HSV(1)); +C if ORDSEL = 'A', NR is the sum of NU and the number of +C Hankel singular values greater than +C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix A. For a continuous-time +C system (DICO = 'C'), ALPHA <= 0 is the boundary value for +C the real parts of eigenvalues, while for a discrete-time +C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system in a real Schur form. +C The resulting A has a block-diagonal form with two blocks. +C For a system with NU ALPHA-unstable eigenvalues and +C NS ALPHA-stable eigenvalues (NU+NS = N), the leading +C NU-by-NU block contains the unreduced part of A +C corresponding to ALPHA-unstable eigenvalues. +C The trailing (NR+NS-N)-by-(NR+NS-N) block contains +C the reduced part of A corresponding to ALPHA-stable +C eigenvalues. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NS (output) INTEGER +C The dimension of the ALPHA-stable subsystem. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, the leading NS elements of HSV contain the +C Hankel singular values of the ALPHA-stable part of the +C original system ordered decreasingly. +C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the +C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the +C Hankel-norm of the ALPHA-stable part of the given system +C (computed in HSV(1)). +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of +C ALPHA-stable eigenvalues of A and EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C This value is appropriate to compute a minimal realization +C of the ALPHA-stable part. +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the ALPHA-stable part of the given system. +C The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs). +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0, then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = MAX(1,M), if DICO = 'C'; +C LIWORK = MAX(1,N,M), if DICO = 'D'. +C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of +C the computed minimal realization. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( LDW1, LDW2 ), where +C LDW1 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, +C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + +C MAX( 3*M+1, MIN(N,M)+P ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than NSMIN, the sum of the order of the +C ALPHA-unstable part and the order of a minimal +C realization of the ALPHA-stable part of the given +C system. In this case, the resulting NR is set equal +C to NSMIN. +C = 2: with ORDSEL = 'F', the selected order NR is less +C than the order of the ALPHA-unstable part of the +C given system. In this case NR is set equal to the +C order of the ALPHA-unstable part. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of the ordered real Schur form of A +C failed; +C = 2: the separation of the ALPHA-stable/unstable diagonal +C blocks failed because of very close eigenvalues; +C = 3: the computed ALPHA-stable part is just stable, +C having stable eigenvalues very near to the imaginary +C axis (if DICO = 'C') or to the unit circle +C (if DICO = 'D'); +C = 4: the computation of Hankel singular values failed; +C = 5: the computation of stable projection in the +C Hankel-norm approximation algorithm failed; +C = 6: the order of computed stable projection in the +C Hankel-norm approximation algorithm differs +C from the order of Hankel-norm approximation. +C +C METHOD +C +C Let be the following linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09ED determines for +C the given system (1), the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t) (2) +C +C such that +C +C HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C The following procedure is used to reduce a given G: +C +C 1) Decompose additively G as +C +C G = G1 + G2 +C +C such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and +C G2 = (Au,Bu,Cu,0) has only ALPHA-unstable poles. +C +C 2) Determine G1r, a reduced order approximation of the +C ALPHA-stable part G1. +C +C 3) Assemble the reduced model Gr as +C +C Gr = G1r + G2. +C +C To reduce the ALPHA-stable part G1, the optimal Hankel-norm +C approximation method of [1], based on the square-root +C balancing projection formulas of [2], is employed. +C +C REFERENCES +C +C [1] Glover, K. +C All optimal Hankel norm approximation of linear +C multivariable systems and their L-infinity error bounds. +C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. +C +C [2] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on an accuracy enhancing square-root +C technique. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routines SADSDC and OHNAP. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C Nov. 2000, A. Varga, DLR Oberpfaffenhofen. +C March 26, 2005, V. Sima, Research Institute for Informatics. +C +C KEYWORDS +C +C Balancing, Hankel-norm approximation, model reduction, +C multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION C100, ONE, ZERO + PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, + $ M, N, NR, NS, P + DOUBLE PRECISION ALPHA, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL DISCR, FIXORD + INTEGER IERR, IWARNL, KI, KL, KU, KW, NRA, NU, NU1 + DOUBLE PRECISION ALPWRK, MAXRED, WRKOPT +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB09CX, TB01ID, TB01KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Check the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -7 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -14 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN + INFO = -20 + ELSE IF( LDWORK.LT.MAX( N*( 2*N + MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2, + $ N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + + $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) ) THEN + INFO = -23 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09ED', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + NS = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C Workspace: N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Correct the value of ALPHA to ensure stability. +C + ALPWRK = ALPHA + IF( DISCR ) THEN + IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) + ELSE + IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) + END IF +C +C Allocate working storage. +C + KU = 1 + KL = KU + N*N + KI = KL + N + KW = KI + N +C +C Reduce A to a block-diagonal real Schur form, with the +C ALPHA-unstable part in the leading diagonal position, using a +C non-orthogonal similarity transformation A <- inv(T)*A*T and +C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, + $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), + $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 1 + ELSE + INFO = 2 + END IF + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C +C Determine a reduced order approximation of the ALPHA-stable part. +C +C Workspace: need MAX( LDW1, LDW2 ), +C LDW1 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, +C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + +C MAX( 3*M+1, MIN(N,M)+P ); +C prefer larger. +C + IWARNL = 0 + NS = N - NU + IF( FIXORD ) THEN + NRA = MAX( 0, NR-NU ) + IF( NR.LT.NU ) + $ IWARNL = 2 + ELSE + NRA = 0 + END IF +C +C Finish if only unstable part is present. +C + IF( NS.EQ.0 ) THEN + NR = NU + DWORK(1) = WRKOPT + RETURN + END IF +C + NU1 = NU + 1 + CALL AB09CX( DICO, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, + $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, TOL1, + $ TOL2, IWORK, DWORK, LDWORK, IWARN, IERR ) +C + IWARN = MAX( IWARN, IWARNL ) + IF( IERR.NE.0 ) THEN + INFO = IERR + 2 + RETURN + END IF +C + NR = NRA + NU +C + DWORK(1) = MAX( WRKOPT, DWORK(1) ) +C + RETURN +C *** Last line of AB09ED *** + END diff --git a/mex/sources/libslicot/AB09FD.f b/mex/sources/libslicot/AB09FD.f new file mode 100644 index 000000000..cb954ba15 --- /dev/null +++ b/mex/sources/libslicot/AB09FD.f @@ -0,0 +1,649 @@ + SUBROUTINE AB09FD( DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL, N, M, + $ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, NQ, HSV, + $ TOL1, TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr) for an original +C state-space representation (A,B,C) by using either the square-root +C or the balancing-free square-root Balance & Truncate (B & T) +C model reduction method in conjunction with stable coprime +C factorization techniques. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBCF CHARACTER*1 +C Specifies whether left or right coprime factorization is +C to be used as follows: +C = 'L': use left coprime factorization; +C = 'R': use right coprime factorization. +C +C FACT CHARACTER*1 +C Specifies the type of coprime factorization to be computed +C as follows: +C = 'S': compute a coprime factorization with prescribed +C stability degree ALPHA; +C = 'I': compute a coprime factorization with inner +C denominator. +C +C JOBMR CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root Balance & Truncate method; +C = 'N': use the balancing-free square-root +C Balance & Truncate method. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of the +C resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(NR,NQ,NMIN), where NR +C is the desired order on entry, NQ is the order of the +C computed coprime factorization of the given system, and +C NMIN is the order of a minimal realization of the extended +C system (see METHOD); NMIN is determined as the number of +C Hankel singular values greater than NQ*EPS*HNORM(Ge), +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the +C extended system (computed in HSV(1)); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL1,NQ*EPS*HNORM(Ge)). +C +C ALPHA (input) DOUBLE PRECISION +C If FACT = 'S', the desired stability degree for the +C factors of the coprime factorization (see SLICOT Library +C routines SB08ED/SB08FD). +C ALPHA < 0 for a continuous-time system (DICO = 'C'), and +C 0 <= ALPHA < 1 for a discrete-time system (DICO = 'D'). +C If FACT = 'I', ALPHA is not used. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the reduced +C order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C NQ (output) INTEGER +C The order of the computed extended system Ge (see METHOD). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the NQ Hankel singular values of +C the extended system Ge ordered decreasingly (see METHOD). +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced extended system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(Ge), where c is a constant in the +C interval [0.00001,0.001], and HNORM(Ge) is the +C Hankel-norm of the extended system (computed in HSV(1)). +C The value TOL1 = NQ*EPS*HNORM(Ge) is used by default if +C TOL1 <= 0 on entry, where EPS is the machine precision +C (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The absolute tolerance level below which the elements of +C B or C are considered zero (used for controllability or +C observability tests). +C If the user sets TOL2 <= 0, then an implicitly computed, +C default tolerance TOLDEF is used: +C TOLDEF = N*EPS*NORM(C'), if JOBCF = 'L', or +C TOLDEF = N*EPS*NORM(B), if JOBCF = 'R', +C where EPS is the machine precision, and NORM(.) denotes +C the 1-norm of a matrix. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = PM, if JOBMR = 'B', +C LIWORK = MAX(N,PM), if JOBMR = 'N', where +C PM = P, if JOBCF = 'L', +C PM = M, if JOBCF = 'R'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,LW1) if JOBCF = 'L' and FACT = 'S', +C LDWORK >= MAX(1,LW2) if JOBCF = 'L' and FACT = 'I', +C LDWORK >= MAX(1,LW3) if JOBCF = 'R' and FACT = 'S', +C LDWORK >= MAX(1,LW4) if JOBCF = 'R' and FACT = 'I', where +C LW1 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + +C MAX( N*P+MAX(N*(N+5), 5*P, 4*M), LWR ), +C LW2 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + +C MAX( N*P+MAX(N*(N+5), P*(P+2), 4*P, 4*M), LWR ), +C LW3 = (N+M)*(M+P) + MAX( 5*M, 4*P, LWR ), +C LW4 = (N+M)*(M+P) + MAX( M*(M+2), 4*M, 4*P, LWR ), and +C LWR = 2*N*N + N*(MAX(N,M+P)+5) + N*(N+1)/2. +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 10*K+I: +C I = 1: with ORDSEL = 'F', the selected order NR is +C greater than the order of the computed coprime +C factorization of the given system. In this case, +C the resulting NR is set automatically to a value +C corresponding to the order of a minimal +C realization of the system; +C K > 0: K violations of the numerical stability +C condition occured when computing the coprime +C factorization using pole assignment (see SLICOT +C Library routines SB08CD/SB08ED, SB08DD/SB08FD). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the ordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + H*C)*Z +C (or Z'*(A + B*F)*Z) along the diagonal; see SLICOT +C Library routines SB08CD/SB08ED (or SB08DD/SB08FD); +C = 3: the matrix A has an observable or controllable +C eigenvalue on the imaginary axis if DICO = 'C' or +C on the unit circle if DICO = 'D'; +C = 4: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system, and let G be the corresponding +C transfer-function matrix. The subroutine AB09FD determines +C the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) (2) +C +C with the transfer-function matrix Gr, by using the +C balanced-truncation model reduction method in conjunction with +C a left coprime factorization (LCF) or a right coprime +C factorization (RCF) technique: +C +C 1. Compute the appropriate stable coprime factorization of G: +C -1 -1 +C G = R *Q (LCF) or G = Q*R (RCF). +C +C 2. Perform the model reduction algorithm on the extended system +C ( Q ) +C Ge = ( Q R ) (LCF) or Ge = ( R ) (RCF) +C +C to obtain a reduced extended system with reduced factors +C ( Qr ) +C Ger = ( Qr Rr ) (LCF) or Ger = ( Rr ) (RCF). +C +C 3. Recover the reduced system from the reduced factors as +C -1 -1 +C Gr = Rr *Qr (LCF) or Gr = Qr*Rr (RCF). +C +C The approximation error for the extended system satisfies +C +C HSV(NR) <= INFNORM(Ge-Ger) <= 2*[HSV(NR+1) + ... + HSV(NQ)], +C +C where INFNORM(G) is the infinity-norm of G. +C +C If JOBMR = 'B', the square-root Balance & Truncate method of [1] +C is used for model reduction. +C If JOBMR = 'N', the balancing-free square-root version of the +C Balance & Truncate method [2] is used for model reduction. +C +C If FACT = 'S', the stable coprime factorization with prescribed +C stability degree ALPHA is computed by using the algorithm of [3]. +C If FACT = 'I', the stable coprime factorization with inner +C denominator is computed by using the algorithm of [4]. +C +C REFERENCES +C +C [1] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [2] Varga A. +C Efficient minimal realization procedure based on balancing. +C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, +C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2, +C pp. 42-46, 1991. +C +C [3] Varga A. +C Coprime factors model reduction method based on square-root +C balancing-free techniques. +C System Analysis, Modelling and Simulation, Vol. 11, +C pp. 303-311, 1993. +C +C [4] Varga A. +C A Schur method for computing coprime factorizations with +C inner denominators and applications in model reduction. +C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, August 1998. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C +C KEYWORDS +C +C Balancing, coprime factorization, minimal realization, +C model reduction, multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION C100, ONE, ZERO + PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, FACT, JOBCF, JOBMR, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDWORK, M, N, NQ, + $ NR, P + DOUBLE PRECISION ALPHA, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL DISCR, FIXORD, LEFT, STABD + INTEGER IERR, IWARNK, KB, KBR, KBT, KC, KCR, KD, KDR, + $ KDT, KT, KTI, KW, LW1, LW2, LW3, LW4, LWR, + $ MAXMP, MP, NDR, PM, WRKOPT + DOUBLE PRECISION MAXRED +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB09AX, DLACPY, DLASET, SB08CD, SB08DD, SB08ED, + $ SB08FD, SB08GD, SB08HD, TB01ID, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) + LEFT = LSAME( JOBCF, 'L' ) + STABD = LSAME( FACT, 'S' ) + MAXMP = MAX( M, P ) +C + LWR = 2*N*N + N*( MAX( N, M + P ) + 5 ) + ( N*( N + 1 ) )/2 + LW1 = N*( 2*MAXMP + P ) + MAXMP*( MAXMP + P ) + LW2 = LW1 + + $ MAX( N*P + MAX( N*( N + 5 ), P*( P+2 ), 4*P, 4*M ), LWR ) + LW1 = LW1 + MAX( N*P + MAX( N*( N + 5 ), 5*P, 4*M ), LWR ) + LW3 = ( N + M )*( M + P ) + MAX( 5*M, 4*P, LWR ) + LW4 = ( N + M )*( M + P ) + MAX( M*( M + 2 ), 4*M, 4*P, LWR ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( STABD .OR. LSAME( FACT, 'I' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( LSAME( JOBMR, 'B' ) .OR. + $ LSAME( JOBMR, 'N' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -5 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -6 + ELSE IF( STABD .AND. ( ( .NOT.DISCR .AND. ALPHA.GE.ZERO ) .OR. + $ ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GE.ONE ) ) ) ) + $ THEN + INFO = -7 + ELSE IF( N.LT.0 ) THEN + INFO = -8 + ELSE IF( M.LT.0 ) THEN + INFO = -9 + ELSE IF( P.LT.0 ) THEN + INFO = -10 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -11 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -17 + ELSE IF( ( LDWORK.LT.1 ) .OR. + $ ( STABD .AND. LEFT .AND. LDWORK.LT.LW1 ) .OR. + $ ( .NOT.STABD .AND. LEFT .AND. LDWORK.LT.LW2 ) .OR. + $ ( STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW3 ) .OR. + $ ( .NOT.STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW4 ) ) THEN + INFO = -24 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09FD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 .OR. ( FIXORD .AND. NR.EQ.0 ) ) THEN + NR = 0 + NQ = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C + MAXRED = C100 + CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Perform the coprime factor model reduction procedure. +C + KD = 1 + IF( LEFT ) THEN +C -1 +C Compute a LCF G = R *Q. +C + MP = M + P + KDR = KD + MAXMP*MAXMP + KC = KDR + MAXMP*P + KB = KC + MAXMP*N + KBR = KB + N*MAXMP + KW = KBR + N*P + LWR = LDWORK - KW + 1 + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KB), N ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), MAXMP ) + CALL DLASET( 'Full', P, M, ZERO, ZERO, DWORK(KD), MAXMP ) +C + IF( STABD ) THEN +C +C Compute a LCF with prescribed stability degree. +C +C Workspace needed: N*(2*MAX(M,P)+P) + +C MAX(M,P)*(MAX(M,P)+P); +C Additional workspace: need N*P+MAX(N*(N+5),5*P,4*M); +C prefer larger. +C + CALL SB08ED( DICO, N, M, P, ALPHA, A, LDA, DWORK(KB), N, + $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, + $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL2, + $ DWORK(KW), LWR, IWARN, INFO ) + ELSE +C +C Compute a LCF with inner denominator. +C +C Workspace needed: N*(2*MAX(M,P)+P) + +C MAX(M,P)*(MAX(M,P)+P); +C Additional workspace: need N*P + +C MAX(N*(N+5),P*(P+2),4*P,4*M). +C prefer larger; +C + CALL SB08CD( DICO, N, M, P, A, LDA, DWORK(KB), N, + $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, + $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL2, + $ DWORK(KW), LWR, IWARN, INFO ) + END IF +C + IWARN = 10*IWARN + IF( INFO.NE.0 ) + $ RETURN +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C + IF( NQ.EQ.0 ) THEN + NR = 0 + DWORK(1) = WRKOPT + RETURN + END IF +C + IF( MAXMP.GT.M ) THEN +C +C Form the matrices ( BQ, BR ) and ( DQ, DR ) in consecutive +C columns (see SLICOT Library routines SB08CD/SB08ED). +C + KBT = KBR + KBR = KB + N*M + KDT = KDR + KDR = KD + MAXMP*M + CALL DLACPY( 'Full', NQ, P, DWORK(KBT), N, DWORK(KBR), N ) + CALL DLACPY( 'Full', P, P, DWORK(KDT), MAXMP, DWORK(KDR), + $ MAXMP ) + END IF +C +C Perform model reduction on ( Q, R ) to determine ( Qr, Rr ). +C +C Workspace needed: N*(2*MAX(M,P)+P) + +C MAX(M,P)*(MAX(M,P)+P) + 2*N*N; +C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; +C prefer larger. +C + KT = KW + KTI = KT + NQ*NQ + KW = KTI + NQ*NQ + CALL AB09AX( DICO, JOBMR, ORDSEL, NQ, MP, P, NR, A, LDA, + $ DWORK(KB), N, DWORK(KC), MAXMP, HSV, DWORK(KT), + $ N, DWORK(KTI), N, TOL1, IWORK, DWORK(KW), + $ LDWORK-KW+1, IWARNK, IERR ) +C + IWARN = IWARN + IWARNK + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C -1 +C Compute the reduced order system Gr = Rr *Qr. +C +C Workspace needed: N*(2*MAX(M,P)+P) + +C MAX(M,P)*(MAX(M,P)+P); +C Additional workspace: need 4*P. +C + KW = KT + CALL SB08GD( NR, M, P, A, LDA, DWORK(KB), N, DWORK(KC), MAXMP, + $ DWORK(KD), MAXMP, DWORK(KBR), N, DWORK(KDR), + $ MAXMP, IWORK, DWORK(KW), INFO ) +C +C Copy the reduced system matrices Br and Cr to B and C. +C + CALL DLACPY( 'Full', NR, M, DWORK(KB), N, B, LDB ) + CALL DLACPY( 'Full', P, NR, DWORK(KC), MAXMP, C, LDC ) +C + ELSE +C -1 +C Compute a RCF G = Q*R . +C + PM = P + M + KDR = KD + P + KC = KD + PM*M + KCR = KC + P + KW = KC + PM*N + LWR = LDWORK - KW + 1 + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), PM ) + CALL DLASET( 'Full', P, M, ZERO, ZERO, DWORK(KD), PM ) +C + IF( STABD ) THEN +C +C Compute a RCF with prescribed stability degree. +C +C Workspace needed: (N+M)*(M+P); +C Additional workspace: need MAX( N*(N+5), 5*M, 4*P ); +C prefer larger. +C + CALL SB08FD( DICO, N, M, P, ALPHA, A, LDA, B, LDB, + $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, + $ DWORK(KCR), PM, DWORK(KDR), PM, TOL2, + $ DWORK(KW), LWR, IWARN, INFO ) + ELSE +C +C Compute a RCF with inner denominator. +C +C Workspace needed: (N+M)*(M+P); +C Additional workspace: need MAX(N*(N+5),M*(M+2),4*M,4*P); +C prefer larger. +C + CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, + $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, + $ DWORK(KCR), PM, DWORK(KDR), PM, TOL2, + $ DWORK(KW), LWR, IWARN, INFO ) + END IF +C + IWARN = 10*IWARN + IF( INFO.NE.0 ) + $ RETURN +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C + IF( NQ.EQ.0 ) THEN + NR = 0 + DWORK(1) = WRKOPT + RETURN + END IF +C ( Q ) ( Qr ) +C Perform model reduction on ( R ) to determine ( Rr ). +C +C Workspace needed: (N+M)*(M+P) + 2*N*N; +C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; +C prefer larger. +C + KT = KW + KTI = KT + NQ*NQ + KW = KTI + NQ*NQ + CALL AB09AX( DICO, JOBMR, ORDSEL, NQ, M, PM, NR, A, LDA, B, + $ LDB, DWORK(KC), PM, HSV, DWORK(KT), N, DWORK(KTI), + $ N, TOL1, IWORK, DWORK(KW), LDWORK-KW+1, IWARNK, + $ IERR ) +C + IWARN = IWARN + IWARNK + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C -1 +C Compute the reduced order system Gr = Qr*Rr . +C +C Workspace needed: (N+M)*(M+P); +C Additional workspace: need 4*M. +C + KW = KT + CALL SB08HD( NR, M, P, A, LDA, B, LDB, DWORK(KC), PM, + $ DWORK(KD), PM, DWORK(KCR), PM, DWORK(KDR), PM, + $ IWORK, DWORK(KW), INFO ) +C +C Copy the reduced system matrix Cr to C. +C + CALL DLACPY( 'Full', P, NR, DWORK(KC), PM, C, LDC ) + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB09FD *** + END diff --git a/mex/sources/libslicot/AB09GD.f b/mex/sources/libslicot/AB09GD.f new file mode 100644 index 000000000..c55160369 --- /dev/null +++ b/mex/sources/libslicot/AB09GD.f @@ -0,0 +1,681 @@ + SUBROUTINE AB09GD( DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL, N, M, + $ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD, + $ NQ, HSV, TOL1, TOL2, TOL3, IWORK, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C state-space representation (A,B,C,D) by using either the +C square-root or the balancing-free square-root Singular +C Perturbation Approximation (SPA) model reduction method in +C conjunction with stable coprime factorization techniques. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBCF CHARACTER*1 +C Specifies whether left or right coprime factorization is +C to be used as follows: +C = 'L': use left coprime factorization; +C = 'R': use right coprime factorization. +C +C FACT CHARACTER*1 +C Specifies the type of coprime factorization to be computed +C as follows: +C = 'S': compute a coprime factorization with prescribed +C stability degree ALPHA; +C = 'I': compute a coprime factorization with inner +C denominator. +C +C JOBMR CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root Balance & Truncate method; +C = 'N': use the balancing-free square-root +C Balance & Truncate method. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of the +C resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(NR,NQ,NMIN), where NR +C is the desired order on entry, NQ is the order of the +C computed coprime factorization of the given system, and +C NMIN is the order of a minimal realization of the extended +C system (see METHOD); NMIN is determined as the number of +C Hankel singular values greater than NQ*EPS*HNORM(Ge), +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the +C extended system (computed in HSV(1)); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL1,NQ*EPS*HNORM(Ge)). +C +C ALPHA (input) DOUBLE PRECISION +C If FACT = 'S', the desired stability degree for the +C factors of the coprime factorization (see SLICOT Library +C routines SB08ED/SB08FD). +C ALPHA < 0 for a continuous-time system (DICO = 'C'), and +C 0 <= ALPHA < 1 for a discrete-time system (DICO = 'D'). +C If FACT = 'I', ALPHA is not used. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the reduced +C order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NQ (output) INTEGER +C The order of the computed extended system Ge (see METHOD). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the NQ Hankel singular values of +C the extended system Ge ordered decreasingly (see METHOD). +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced extended system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(Ge), where c is a constant in the +C interval [0.00001,0.001], and HNORM(Ge) is the +C Hankel-norm of the extended system (computed in HSV(1)). +C The value TOL1 = NQ*EPS*HNORM(Ge) is used by default if +C TOL1 <= 0 on entry, where EPS is the machine precision +C (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the extended system Ge (see METHOD). +C The recommended value is TOL2 = NQ*EPS*HNORM(Ge). +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0, then TOL2 <= TOL1. +C +C TOL3 DOUBLE PRECISION +C The absolute tolerance level below which the elements of +C B or C are considered zero (used for controllability or +C observability tests by the coprime factorization method). +C If the user sets TOL3 <= 0, then an implicitly computed, +C default tolerance TOLDEF is used: +C TOLDEF = N*EPS*NORM(C'), if JOBCF = 'L', or +C TOLDEF = N*EPS*NORM(B), if JOBCF = 'R', +C where EPS is the machine precision, and NORM(.) denotes +C the 1-norm of a matrix. +C +C Workspace +C +C IWORK INTEGER array, dimension (MAX(1,2*N,PM)) +C where PM = P, if JOBCF = 'L', +C PM = M, if JOBCF = 'R'. +C On exit with INFO = 0, IWORK(1) contains the order of the +C minimal realization of the system. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,LW1) if JOBCF = 'L' and FACT = 'S', +C LDWORK >= MAX(1,LW2) if JOBCF = 'L' and FACT = 'I', +C LDWORK >= MAX(1,LW3) if JOBCF = 'R' and FACT = 'S', +C LDWORK >= MAX(1,LW4) if JOBCF = 'R' and FACT = 'I', where +C LW1 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + +C MAX( N*P+MAX(N*(N+5), 5*P, 4*M), LWR ), +C LW2 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + +C MAX( N*P+MAX(N*(N+5), P*(P+2), 4*P, 4*M), LWR ), +C LW3 = (N+M)*(M+P) + MAX( 5*M, 4*P, LWR ), +C LW4 = (N+M)*(M+P) + MAX( M*(M+2), 4*M, 4*P, LWR ), and +C LWR = 2*N*N + N*(MAX(N,M+P)+5) + N*(N+1)/2. +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 10*K+I: +C I = 1: with ORDSEL = 'F', the selected order NR is +C greater than the order of the computed coprime +C factorization of the given system. In this case, +C the resulting NR is set automatically to a value +C corresponding to the order of a minimal +C realization of the system; +C K > 0: K violations of the numerical stability +C condition occured when computing the coprime +C factorization using pole assignment (see SLICOT +C Library routines SB08CD/SB08ED, SB08DD/SB08FD). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the ordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + H*C)*Z +C (or Z'*(A + B*F)*Z) along the diagonal; see SLICOT +C Library routines SB08CD/SB08ED (or SB08DD/SB08FD); +C = 3: the matrix A has an observable or controllable +C eigenvalue on the imaginary axis if DICO = 'C' or +C on the unit circle if DICO = 'D'; +C = 4: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system, and let G be the corresponding +C transfer-function matrix. The subroutine AB09GD determines +C the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t) (2) +C +C with the transfer-function matrix Gr, by using the +C singular perturbation approximation (SPA) method in conjunction +C with a left coprime factorization (LCF) or a right coprime +C factorization (RCF) technique: +C +C 1. Compute the appropriate stable coprime factorization of G: +C -1 -1 +C G = R *Q (LCF) or G = Q*R (RCF). +C +C 2. Perform the model reduction algorithm on the extended system +C ( Q ) +C Ge = ( Q R ) (LCF) or Ge = ( R ) (RCF) +C +C to obtain a reduced extended system with reduced factors +C ( Qr ) +C Ger = ( Qr Rr ) (LCF) or Ger = ( Rr ) (RCF). +C +C 3. Recover the reduced system from the reduced factors as +C -1 -1 +C Gr = Rr *Qr (LCF) or Gr = Qr*Rr (RCF). +C +C The approximation error for the extended system satisfies +C +C HSV(NR) <= INFNORM(Ge-Ger) <= 2*[HSV(NR+1) + ... + HSV(NQ)], +C +C where INFNORM(G) is the infinity-norm of G. +C +C If JOBMR = 'B', the balancing-based square-root SPA method of [1] +C is used for model reduction. +C If JOBMR = 'N', the balancing-free square-root SPA method of [2] +C is used for model reduction. +C By setting TOL1 = TOL2, the routine can be used to compute +C Balance & Truncate approximations. +C +C If FACT = 'S', the stable coprime factorization with prescribed +C stability degree ALPHA is computed by using the algorithm of [3]. +C If FACT = 'I', the stable coprime factorization with inner +C denominator is computed by using the algorithm of [4]. +C +C REFERENCES +C +C [1] Liu Y. and Anderson B.D.O. +C Singular Perturbation Approximation of Balanced Systems. +C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. +C +C [2] Varga A. +C Balancing-free square-root algorithm for computing singular +C perturbation approximations. +C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, Vol. 2, +C pp. 1062-1065. +C +C [3] Varga A. +C Coprime factors model reduction method based on square-root +C balancing-free techniques. +C System Analysis, Modelling and Simulation, Vol. 11, +C pp. 303-311, 1993. +C +C [4] Varga A. +C A Schur method for computing coprime factorizations with +C inner denominators and applications in model reduction. +C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, August 1998. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C +C KEYWORDS +C +C Balancing, coprime factorization, minimal realization, +C model reduction, multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, C100, ZERO + PARAMETER ( ONE = 1.0D0, C100 = 100.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, FACT, JOBCF, JOBMR, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, M, N, + $ NQ, NR, P + DOUBLE PRECISION ALPHA, TOL1, TOL2, TOL3 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL DISCR, FIXORD, LEFT, STABD + INTEGER IERR, IWARNK, KB, KBR, KBT, KC, KCR, KD, KDR, + $ KDT, KT, KTI, KW, LW1, LW2, LW3, LW4, LWR, + $ MAXMP, MP, NDR, NMINR, PM, WRKOPT + DOUBLE PRECISION MAXRED +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB09BX, DLACPY, SB08CD, SB08DD, SB08ED, SB08FD, + $ SB08GD, SB08HD, TB01ID, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) + LEFT = LSAME( JOBCF, 'L' ) + STABD = LSAME( FACT, 'S' ) + MAXMP = MAX( M, P ) +C + LWR = 2*N*N + N*( MAX( N, M + P ) + 5 ) + ( N*( N + 1 ) )/2 + LW1 = N*( 2*MAXMP + P ) + MAXMP*( MAXMP + P ) + LW2 = LW1 + + $ MAX( N*P + MAX( N*( N + 5 ), P*( P+2 ), 4*P, 4*M ), LWR ) + LW1 = LW1 + MAX( N*P + MAX( N*( N + 5 ), 5*P, 4*M ), LWR ) + LW3 = ( N + M )*( M + P ) + MAX( 5*M, 4*P, LWR ) + LW4 = ( N + M )*( M + P ) + MAX( M*( M + 2 ), 4*M, 4*P, LWR ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( STABD .OR. LSAME( FACT, 'I' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( LSAME( JOBMR, 'B' ) .OR. + $ LSAME( JOBMR, 'N' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -5 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -6 + ELSE IF( STABD .AND. ( ( .NOT.DISCR .AND. ALPHA.GE.ZERO ) .OR. + $ ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GE.ONE ) ) ) ) + $ THEN + INFO = -7 + ELSE IF( N.LT.0 ) THEN + INFO = -8 + ELSE IF( M.LT.0 ) THEN + INFO = -9 + ELSE IF( P.LT.0 ) THEN + INFO = -10 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -11 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -17 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -19 + ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN + INFO = -23 + ELSE IF( ( LDWORK.LT.1 ) .OR. + $ ( STABD .AND. LEFT .AND. LDWORK.LT.LW1 ) .OR. + $ ( .NOT.STABD .AND. LEFT .AND. LDWORK.LT.LW2 ) .OR. + $ ( STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW3 ) .OR. + $ ( .NOT.STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW4 ) ) THEN + INFO = -27 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09GD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + NQ = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C + MAXRED = C100 + CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Perform the coprime factor model reduction procedure. +C + KD = 1 + IF( LEFT ) THEN +C -1 +C Compute a LCF G = R *Q. +C + MP = M + P + KDR = KD + MAXMP*MAXMP + KC = KDR + MAXMP*P + KB = KC + MAXMP*N + KBR = KB + N*MAXMP + KW = KBR + N*P + LWR = LDWORK - KW + 1 + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KB), N ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), MAXMP ) + CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KD), MAXMP ) +C + IF( STABD ) THEN +C +C Compute a LCF with prescribed stability degree. +C +C Workspace needed: N*(2*MAX(M,P)+P) + +C MAX(M,P)*(MAX(M,P)+P); +C Additional workspace: need N*P+MAX(N*(N+5),5*P,4*M); +C prefer larger. +C + CALL SB08ED( DICO, N, M, P, ALPHA, A, LDA, DWORK(KB), N, + $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, + $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL3, + $ DWORK(KW), LWR, IWARN, INFO ) + ELSE +C +C Compute a LCF with inner denominator. +C +C Workspace needed: N*(2*MAX(M,P)+P) + +C MAX(M,P)*(MAX(M,P)+P); +C Additional workspace: need N*P + +C MAX(N*(N+5),P*(P+2),4*P,4*M); +C prefer larger. +C + CALL SB08CD( DICO, N, M, P, A, LDA, DWORK(KB), N, + $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, + $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL3, + $ DWORK(KW), LWR, IWARN, INFO ) + END IF +C + IWARN = 10*IWARN + IF( INFO.NE.0 ) + $ RETURN +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C + IF( NQ.EQ.0 ) THEN + NR = 0 + IWORK(1) = 0 + DWORK(1) = WRKOPT + RETURN + END IF +C + IF( MAXMP.GT.M ) THEN +C +C Form the matrices ( BQ, BR ) and ( DQ, DR ) in consecutive +C columns (see SLICOT Library routines SB08CD/SB08ED). +C + KBT = KBR + KBR = KB + N*M + KDT = KDR + KDR = KD + MAXMP*M + CALL DLACPY( 'Full', NQ, P, DWORK(KBT), N, DWORK(KBR), N ) + CALL DLACPY( 'Full', P, P, DWORK(KDT), MAXMP, DWORK(KDR), + $ MAXMP ) + END IF +C +C Perform model reduction on ( Q, R ) to determine ( Qr, Rr ). +C +C Workspace needed: N*(2*MAX(M,P)+P) + +C MAX(M,P)*(MAX(M,P)+P) + 2*N*N; +C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; +C prefer larger. +C + KT = KW + KTI = KT + NQ*NQ + KW = KTI + NQ*NQ + CALL AB09BX( DICO, JOBMR, ORDSEL, NQ, MP, P, NR, A, LDA, + $ DWORK(KB), N, DWORK(KC), MAXMP, DWORK(KD), MAXMP, + $ HSV, DWORK(KT), N, DWORK(KTI), N, TOL1, TOL2, + $ IWORK, DWORK(KW), LDWORK-KW+1, IWARNK, IERR ) +C + IWARN = IWARN + IWARNK + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF +C + NMINR = IWORK(1) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C -1 +C Compute the reduced order system Gr = Rr *Qr. +C +C Workspace needed: N*(2*MAX(M,P)+P) + +C MAX(M,P)*(MAX(M,P)+P); +C Additional workspace: need 4*P. +C + KW = KT + CALL SB08GD( NR, M, P, A, LDA, DWORK(KB), N, DWORK(KC), MAXMP, + $ DWORK(KD), MAXMP, DWORK(KBR), N, DWORK(KDR), + $ MAXMP, IWORK, DWORK(KW), INFO ) +C +C Copy the reduced system matrices Br, Cr, and Dr to B, C, and D, +C respectively. +C + CALL DLACPY( 'Full', NR, M, DWORK(KB), N, B, LDB ) + CALL DLACPY( 'Full', P, NR, DWORK(KC), MAXMP, C, LDC ) + CALL DLACPY( 'Full', P, M, DWORK(KD), MAXMP, D, LDD ) + ELSE +C -1 +C Compute a RCF G = Q*R . +C + PM = P + M + KDR = KD + P + KC = KD + PM*M + KCR = KC + P + KW = KC + PM*N + LWR = LDWORK - KW + 1 + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), PM ) + CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KD), PM ) +C + IF( STABD ) THEN +C +C Compute a RCF with prescribed stability degree. +C +C Workspace needed: (N+M)*(M+P); +C Additional workspace: need MAX( N*(N+5), 5*M, 4*P ); +C prefer larger. +C + CALL SB08FD( DICO, N, M, P, ALPHA, A, LDA, B, LDB, + $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, + $ DWORK(KCR), PM, DWORK(KDR), PM, TOL3, + $ DWORK(KW), LWR, IWARN, INFO) + ELSE +C +C Compute a RCF with inner denominator. +C +C Workspace needed: (N+M)*(M+P); +C Additional workspace: need MAX(N*(N+5),M*(M+2),4*M,4*P); +C prefer larger. +C + CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, + $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, + $ DWORK(KCR), PM, DWORK(KDR), PM, TOL3, + $ DWORK(KW), LWR, IWARN, INFO) + END IF +C + IWARN = 10*IWARN + IF( INFO.NE.0 ) + $ RETURN +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C + IF( NQ.EQ.0 ) THEN + NR = 0 + IWORK(1) = 0 + DWORK(1) = WRKOPT + RETURN + END IF +C ( Q ) ( Qr ) +C Perform model reduction on ( R ) to determine ( Rr ). +C +C Workspace needed: (N+M)*(M+P) + 2*N*N; +C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; +C prefer larger. +C + KT = KW + KTI = KT + NQ*NQ + KW = KTI + NQ*NQ + CALL AB09BX( DICO, JOBMR, ORDSEL, NQ, M, PM, NR, A, LDA, + $ B, LDB, DWORK(KC), PM, DWORK(KD), PM, HSV, + $ DWORK(KT), N, DWORK(KTI), N, TOL1, TOL2, IWORK, + $ DWORK(KW), LDWORK-KW+1, IWARNK, IERR ) +C + IWARN = IWARN + IWARNK + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF +C + NMINR = IWORK(1) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C -1 +C Compute the reduced order system Gr = Qr*Rr . +C +C Workspace needed: (N+M)*(M+P); +C Additional workspace: need 4*M. +C + KW = KT + CALL SB08HD( NR, M, P, A, LDA, B, LDB, DWORK(KC), PM, + $ DWORK(KD), PM, DWORK(KCR), PM, DWORK(KDR), PM, + $ IWORK, DWORK(KW), INFO ) +C +C Copy the reduced system matrices Cr and Dr to C and D. +C + CALL DLACPY( 'Full', P, NR, DWORK(KC), PM, C, LDC ) + CALL DLACPY( 'Full', P, M, DWORK(KD), PM, D, LDD ) + END IF +C + IWORK(1) = NMINR + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB09GD *** + END diff --git a/mex/sources/libslicot/AB09HD.f b/mex/sources/libslicot/AB09HD.f new file mode 100644 index 000000000..1468accc6 --- /dev/null +++ b/mex/sources/libslicot/AB09HD.f @@ -0,0 +1,671 @@ + SUBROUTINE AB09HD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA, + $ BETA, A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV, + $ TOL1, TOL2, IWORK, DWORK, LDWORK, BWORK, IWARN, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C state-space representation (A,B,C,D) by using the stochastic +C balancing approach in conjunction with the square-root or +C the balancing-free square-root Balance & Truncate (B&T) +C or Singular Perturbation Approximation (SPA) model reduction +C methods for the ALPHA-stable part of the system. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root Balance & Truncate method; +C = 'F': use the balancing-free square-root +C Balance & Truncate method; +C = 'S': use the square-root Singular Perturbation +C Approximation method; +C = 'P': use the balancing-free square-root +C Singular Perturbation Approximation method. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e., the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C P <= M if BETA = 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of the +C resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. For a system with NU ALPHA-unstable +C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), +C NR is set as follows: if ORDSEL = 'F', NR is equal to +C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order +C on entry, and NMIN is the order of a minimal realization +C of the ALPHA-stable part of the given system; NMIN is +C determined as the number of Hankel singular values greater +C than NS*EPS, where EPS is the machine precision +C (see LAPACK Library Routine DLAMCH); +C if ORDSEL = 'A', NR is the sum of NU and the number of +C Hankel singular values greater than MAX(TOL1,NS*EPS); +C NR can be further reduced to ensure that +C HSV(NR-NU) > HSV(NR+1-NU). +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix A. For a continuous-time +C system (DICO = 'C'), ALPHA <= 0 is the boundary value for +C the real parts of eigenvalues, while for a discrete-time +C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary. +C +C BETA (input) DOUBLE PRECISION +C BETA > 0 specifies the absolute/relative error weighting +C parameter. A large positive value of BETA favours the +C minimization of the absolute approximation error, while a +C small value of BETA is appropriate for the minimization +C of the relative error. +C BETA = 0 means a pure relative error method and can be +C used only if rank(D) = P. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the reduced +C order system. +C The resulting A has a block-diagonal form with two blocks. +C For a system with NU ALPHA-unstable eigenvalues and +C NS ALPHA-stable eigenvalues (NU+NS = N), the leading +C NU-by-NU block contains the unreduced part of A +C corresponding to ALPHA-unstable eigenvalues in an +C upper real Schur form. +C The trailing (NR+NS-N)-by-(NR+NS-N) block contains +C the reduced part of A corresponding to ALPHA-stable +C eigenvalues. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NS (output) INTEGER +C The dimension of the ALPHA-stable subsystem. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, the leading NS elements of HSV contain the +C Hankel singular values of the phase system corresponding +C to the ALPHA-stable part of the original system. +C The Hankel singular values are ordered decreasingly. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value of TOL1 lies +C in the interval [0.00001,0.001]. +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = NS*EPS, where NS is the number of +C ALPHA-stable eigenvalues of A and EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C TOL1 < 1. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the phase system (see METHOD) corresponding +C to the ALPHA-stable part of the given system. +C The recommended value is TOL2 = NS*EPS. +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. +C TOL2 < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension MAX(1,2*N) +C On exit with INFO = 0, IWORK(1) contains the order of the +C minimal realization of the system. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK and DWORK(2) contains RCOND, the reciprocal +C condition number of the U11 matrix from the expression +C used to compute the solution X = U21*inv(U11) of the +C Riccati equation for spectral factorization. +C A small value RCOND indicates possible ill-conditioning +C of the respective Riccati equation. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 2*N*N + MB*(N+P) + MAX( 2, N*(MAX(N,MB,P)+5), +C 2*N*P+MAX(P*(MB+2),10*N*(N+1) ) ), +C where MB = M if BETA = 0 and MB = M+P if BETA > 0. +C For optimum performance LDWORK should be larger. +C +C BWORK LOGICAL array, dimension 2*N +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than NSMIN, the sum of the order of the +C ALPHA-unstable part and the order of a minimal +C realization of the ALPHA-stable part of the given +C system; in this case, the resulting NR is set equal +C to NSMIN; +C = 2: with ORDSEL = 'F', the selected order NR corresponds +C to repeated singular values for the ALPHA-stable +C part, which are neither all included nor all +C excluded from the reduced model; in this case, the +C resulting NR is automatically decreased to exclude +C all repeated singular values; +C = 3: with ORDSEL = 'F', the selected order NR is less +C than the order of the ALPHA-unstable part of the +C given system; in this case NR is set equal to the +C order of the ALPHA-unstable part. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of the ordered real Schur form of A +C failed; +C = 2: the reduction of the Hamiltonian matrix to real +C Schur form failed; +C = 3: the reordering of the real Schur form of the +C Hamiltonian matrix failed; +C = 4: the Hamiltonian matrix has less than N stable +C eigenvalues; +C = 5: the coefficient matrix U11 in the linear system +C X*U11 = U21 to determine X is singular to working +C precision; +C = 6: BETA = 0 and D has not a maximal row rank; +C = 7: the computation of Hankel singular values failed; +C = 8: the separation of the ALPHA-stable/unstable diagonal +C blocks failed because of very close eigenvalues; +C = 9: the resulting order of reduced stable part is less +C than the number of unstable zeros of the stable +C part. +C METHOD +C +C Let be the following linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t), (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09HD determines for +C the given system (1), the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t), (2) +C +C such that +C +C INFNORM[inv(conj(W))*(G-Gr)] <= +C (1+HSV(NR+NS-N+1)) / (1-HSV(NR+NS-N+1)) + ... +C + (1+HSV(NS)) / (1-HSV(NS)) - 1, +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, W is the right, minimum +C phase spectral factor satisfying +C +C G1*conj(G1) = conj(W)* W, (3) +C +C G1 is the NS-order ALPHA-stable part of G, and INFNORM(G) is the +C infinity-norm of G. HSV(1), ... , HSV(NS) are the Hankel-singular +C values of the stable part of the phase system (Ap,Bp,Cp) +C with the transfer-function matrix +C +C P = inv(conj(W))*G1. +C +C If BETA > 0, then the model reduction is performed on [G BETA*I] +C instead of G. This is the recommended approach to be used when D +C has not a maximal row rank or when a certain balance between +C relative and absolute approximation errors is desired. For +C increasingly large values of BETA, the obtained reduced system +C assymptotically approaches that computed by using the +C Balance & Truncate or Singular Perturbation Approximation methods. +C +C Note: conj(G) denotes either G'(-s) for a continuous-time system +C or G'(1/z) for a discrete-time system. +C inv(G) is the inverse of G. +C +C The following procedure is used to reduce a given G: +C +C 1) Decompose additively G as +C +C G = G1 + G2, +C +C such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and +C G2 = (Au,Bu,Cu) has only ALPHA-unstable poles. +C +C 2) Determine G1r, a reduced order approximation of the +C ALPHA-stable part G1 using the balancing stochastic method +C in conjunction with either the B&T [1,2] or SPA methods [3]. +C +C 3) Assemble the reduced model Gr as +C +C Gr = G1r + G2. +C +C Note: The employed stochastic truncation algorithm [2,3] has the +C property that right half plane zeros of G1 remain as right half +C plane zeros of G1r. Thus, the order can not be chosen smaller than +C the sum of the number of unstable poles of G and the number of +C unstable zeros of G1. +C +C The reduction of the ALPHA-stable part G1 is done as follows. +C +C If JOB = 'B', the square-root stochastic Balance & Truncate +C method of [1] is used. +C For an ALPHA-stable continuous-time system (DICO = 'C'), +C the resulting reduced model is stochastically balanced. +C +C If JOB = 'F', the balancing-free square-root version of the +C stochastic Balance & Truncate method [1] is used to reduce +C the ALPHA-stable part G1. +C +C If JOB = 'S', the stochastic balancing method is used to reduce +C the ALPHA-stable part G1, in conjunction with the square-root +C version of the Singular Perturbation Approximation method [3,4]. +C +C If JOB = 'P', the stochastic balancing method is used to reduce +C the ALPHA-stable part G1, in conjunction with the balancing-free +C square-root version of the Singular Perturbation Approximation +C method [3,4]. +C +C REFERENCES +C +C [1] Varga A. and Fasol K.H. +C A new square-root balancing-free stochastic truncation model +C reduction algorithm. +C Proc. 12th IFAC World Congress, Sydney, 1993. +C +C [2] Safonov M. G. and Chiang R. Y. +C Model reduction for robust control: a Schur relative error +C method. +C Int. J. Adapt. Contr. Sign. Proc., vol. 2, pp. 259-272, 1988. +C +C [3] Green M. and Anderson B. D. O. +C Generalized balanced stochastic truncation. +C Proc. 29-th CDC, Honolulu, Hawaii, pp. 476-481, 1990. +C +C [4] Varga A. +C Balancing-free square-root algorithm for computing +C singular perturbation approximations. +C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, +C Vol. 2, pp. 1062-1065. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. The effectiveness of the +C accuracy enhancing technique depends on the accuracy of the +C solution of a Riccati equation. An ill-conditioned Riccati +C solution typically results when [D BETA*I] is nearly +C rank deficient. +C 3 +C The algorithm requires about 100N floating point operations. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2000. +C D. Sima, University of Bucharest, May 2000. +C V. Sima, Research Institute for Informatics, Bucharest, May 2000. +C Partly based on the RASP routine SRBFS, by A. Varga, 1992. +C +C REVISIONS +C +C A. Varga, Australian National University, Canberra, November 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000. +C Oct. 2001. +C +C KEYWORDS +C +C Minimal realization, model reduction, multivariable system, +C state-space model, state-space representation, +C stochastic balancing. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, TWOBY3, C100 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ TWOBY3 = TWO/3.0D0, C100 = 100.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, + $ M, N, NR, NS, P + DOUBLE PRECISION ALPHA, BETA, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*) + LOGICAL BWORK(*) +C .. Local Scalars .. + LOGICAL BTA, DISCR, FIXORD, LEQUIL, SPA + INTEGER IERR, IWARNL, KB, KD, KT, KTI, KU, KW, KWI, KWR, + $ LW, LWR, MB, N2, NMR, NN, NRA, NU, NU1, WRKOPT + DOUBLE PRECISION EPSM, MAXRED, RICOND, SCALEC, SCALEO +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB04MD, AB09HY, AB09IX, DLACPY, DLASET, TB01ID, + $ TB01KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) + LEQUIL = LSAME( EQUIL, 'S' ) + BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) + SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) + MB = M + IF( BETA.GT.ZERO ) MB = M + P + LW = 2*N*N + MB*(N+P) + MAX( 2, N*(MAX( N, MB, P )+5), + $ 2*N*P+MAX( P*(MB+2), 10*N*(N+1) ) ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LEQUIL .OR. LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 .OR. ( BETA.EQ.ZERO .AND. P.GT.M ) ) THEN + INFO = -7 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -8 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -9 + ELSE IF( BETA.LT.ZERO ) THEN + INFO = -10 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -18 + ELSE IF( TOL1.GE.ONE ) THEN + INFO = -21 + ELSE IF( ( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) + $ .OR. TOL2.GE.ONE ) THEN + INFO = -22 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -25 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09HD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 .OR. + $ ( BTA .AND. FIXORD .AND. NR.EQ.0 ) ) THEN + NR = 0 + NS = 0 + IWORK(1) = 0 + DWORK(1) = TWO + DWORK(2) = ONE + RETURN + END IF +C + IF( LEQUIL ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C Workspace: N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Allocate working storage. +C + NN = N*N + KU = 1 + KWR = KU + NN + KWI = KWR + N + KW = KWI + N + LWR = LDWORK - KW + 1 +C +C Reduce A to a block-diagonal real Schur form, with the +C ALPHA-unstable part in the leading diagonal position, using a +C non-orthogonal similarity transformation A <- inv(T)*A*T and +C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPHA, A, LDA, + $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KWR), + $ DWORK(KWI), DWORK(KW), LWR, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 1 + ELSE + INFO = 8 + END IF + RETURN + END IF +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C + IWARNL = 0 + NS = N - NU + IF( FIXORD ) THEN + NRA = MAX( 0, NR-NU ) + IF( NR.LT.NU ) + $ IWARNL = 3 + ELSE + NRA = 0 + END IF +C +C Finish if the system is completely unstable. +C + IF( NS.EQ.0 ) THEN + NR = NU + IWORK(1) = NS + DWORK(1) = WRKOPT + DWORK(2) = ONE + RETURN + END IF +C + NU1 = NU + 1 +C +C Allocate working storage. +C + N2 = N + N + KB = 1 + KD = KB + N*MB + KT = KD + P*MB + KTI = KT + N*N + KW = KTI + N*N +C +C Form [B 0] and [D BETA*I]. +C + CALL DLACPY( 'F', NS, M, B(NU1,1), LDB, DWORK(KB), N ) + CALL DLACPY( 'F', P, M, D, LDD, DWORK(KD), P ) + IF( BETA.GT.ZERO ) THEN + CALL DLASET( 'F', NS, P, ZERO, ZERO, DWORK(KB+N*M), N ) + CALL DLASET( 'F', P, P, ZERO, BETA, DWORK(KD+P*M), P ) + END IF +C +C For discrete-time case, apply the discrete-to-continuous bilinear +C transformation to the stable part. +C + IF( DISCR ) THEN +C +C Real workspace: need N, prefer larger; +C Integer workspace: need N. +C + CALL AB04MD( 'Discrete', NS, MB, P, ONE, ONE, A(NU1,NU1), LDA, + $ DWORK(KB), N, C(1,NU1), LDC, DWORK(KD), P, + $ IWORK, DWORK(KT), LDWORK-KT+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KT) ) + KT - 1 ) + END IF +C +C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors S and R +C of the controllability and observability Grammians, respectively. +C Real workspace: need 2*N*N + MB*(N+P)+ +C MAX( 2, N*(MAX(N,MB,P)+5), +C 2*N*P+MAX(P*(MB+2), 10*N*(N+1) ) ); +C prefer larger. +C Integer workspace: need 2*N. +C + CALL AB09HY( NS, MB, P, A(NU1,NU1), LDA, DWORK(KB), N, + $ C(1,NU1), LDC, DWORK(KD), P, SCALEC, SCALEO, + $ DWORK(KTI), N, DWORK(KT), N, IWORK, DWORK(KW), + $ LDWORK-KW+1, BWORK, INFO ) + IF( INFO.NE.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + RICOND = DWORK(KW+1) +C +C Compute a BTA or SPA of the stable part. +C Real workspace: need 2*N*N + MB*(N+P)+ +C MAX( 1, 2*N*N+5*N, N*MAX(MB,P) ). +C + EPSM = DLAMCH( 'Epsilon' ) + CALL AB09IX( 'C', JOB, 'Schur', ORDSEL, NS, MB, P, NRA, SCALEC, + $ SCALEO, A(NU1,NU1), LDA, DWORK(KB), N, C(1,NU1), LDC, + $ DWORK(KD), P, DWORK(KTI), N, DWORK(KT), N, NMR, HSV, + $ MAX( TOL1, N*EPSM ), TOL2, IWORK, DWORK(KW), + $ LDWORK-KW+1, IWARN, IERR ) + IWARN = MAX( IWARN, IWARNL ) + IF( IERR.NE.0 ) THEN + INFO = 7 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Check if the resulting order is greater than the number of +C unstable zeros (this check is implicit by looking at Hankel +C singular values equal to 1). +C + IF( NRA.LT.NS .AND. HSV(NRA+1).GE.ONE-EPSM**TWOBY3 ) THEN + INFO = 9 + RETURN + END IF +C +C For discrete-time case, apply the continuous-to-discrete +C bilinear transformation. +C + IF( DISCR ) THEN + CALL AB04MD( 'Continuous', NRA, MB, P, ONE, ONE, + $ A(NU1,NU1), LDA, DWORK(KB), N, C(1,NU1), LDC, + $ DWORK(KD), P, IWORK, DWORK, LDWORK, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + END IF +C + CALL DLACPY( 'F', NRA, M, DWORK(KB), N, B(NU1,1), LDB ) + CALL DLACPY( 'F', P, M, DWORK(KD), P, D, LDD ) +C + NR = NRA + NU +C + IWORK(1) = NMR + DWORK(1) = WRKOPT + DWORK(2) = RICOND +C + RETURN +C *** Last line of AB09HD *** + END diff --git a/mex/sources/libslicot/AB09HX.f b/mex/sources/libslicot/AB09HX.f new file mode 100644 index 000000000..4bba6fe3b --- /dev/null +++ b/mex/sources/libslicot/AB09HX.f @@ -0,0 +1,690 @@ + SUBROUTINE AB09HX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, + $ C, LDC, D, LDD, HSV, T, LDT, TI, LDTI, TOL1, + $ TOL2, IWORK, DWORK, LDWORK, BWORK, IWARN, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C stable state-space representation (A,B,C,D) by using the +C stochastic balancing approach in conjunction with the square-root +C or the balancing-free square-root Balance & Truncate (B&T) or +C Singular Perturbation Approximation (SPA) model reduction methods. +C The state dynamics matrix A of the original system is an upper +C quasi-triangular matrix in real Schur canonical form and D must be +C full row rank. +C +C For the B&T approach, the matrices of the reduced order system +C are computed using the truncation formulas: +C +C Ar = TI * A * T , Br = TI * B , Cr = C * T . (1) +C +C For the SPA approach, the matrices of a minimal realization +C (Am,Bm,Cm) are computed using the truncation formulas: +C +C Am = TI * A * T , Bm = TI * B , Cm = C * T . (2) +C +C Am, Bm, Cm and D serve further for computing the SPA of the given +C system. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root Balance & Truncate method; +C = 'F': use the balancing-free square-root +C Balance & Truncate method; +C = 'S': use the square-root Singular Perturbation +C Approximation method; +C = 'P': use the balancing-free square-root +C Singular Perturbation Approximation method. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e., the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. M >= P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR +C is the desired order on entry and NMIN is the order of a +C minimal realization of the given system; NMIN is +C determined as the number of Hankel singular values greater +C than N*EPS, where EPS is the machine precision +C (see LAPACK Library Routine DLAMCH); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL1,N*EPS). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A in a real Schur +C canonical form. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the Hankel singular values, +C ordered decreasingly, of the phase system. All singular +C values are less than or equal to 1. +C +C T (output) DOUBLE PRECISION array, dimension (LDT,N) +C If INFO = 0 and NR > 0, the leading N-by-NR part of this +C array contains the right truncation matrix T in (1), for +C the B&T approach, or in (2), for the SPA approach. +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,N). +C +C TI (output) DOUBLE PRECISION array, dimension (LDTI,N) +C If INFO = 0 and NR > 0, the leading NR-by-N part of this +C array contains the left truncation matrix TI in (1), for +C the B&T approach, or in (2), for the SPA approach. +C +C LDTI INTEGER +C The leading dimension of array TI. LDTI >= MAX(1,N). +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value lies in the +C interval [0.00001,0.001]. +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = N*EPS, where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the phase system (see METHOD) corresponding +C to the given system. +C The recommended value is TOL2 = N*EPS. +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension MAX(1,2*N) +C On exit with INFO = 0, IWORK(1) contains the order of the +C minimal realization of the system. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK and DWORK(2) contains RCOND, the reciprocal +C condition number of the U11 matrix from the expression +C used to compute the solution X = U21*inv(U11) of the +C Riccati equation for spectral factorization. +C A small value RCOND indicates possible ill-conditioning +C of the respective Riccati equation. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 2, N*(MAX(N,M,P)+5), +C 2*N*P+MAX(P*(M+2),10*N*(N+1) ) ). +C For optimum performance LDWORK should be larger. +C +C BWORK LOGICAL array, dimension 2*N +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than the order of a minimal realization of the +C given system. In this case, the resulting NR is +C set automatically to a value corresponding to the +C order of a minimal realization of the system. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the state matrix A is not stable (if DICO = 'C') +C or not convergent (if DICO = 'D'), or it is not in +C a real Schur form; +C = 2: the reduction of Hamiltonian matrix to real +C Schur form failed; +C = 3: the reordering of the real Schur form of the +C Hamiltonian matrix failed; +C = 4: the Hamiltonian matrix has less than N stable +C eigenvalues; +C = 5: the coefficient matrix U11 in the linear system +C X*U11 = U21, used to determine X, is singular to +C working precision; +C = 6: the feedthrough matrix D has not a full row rank P; +C = 7: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t), (3) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09HX determines for +C the given system (3), the matrices of a reduced NR-rder system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t), (4) +C +C such that +C +C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C If JOB = 'B', the square-root stochastic Balance & Truncate +C method of [1] is used and the resulting model is balanced. +C +C If JOB = 'F', the balancing-free square-root version of the +C stochastic Balance & Truncate method [1] is used. +C +C If JOB = 'S', the stochastic balancing method, in conjunction +C with the square-root version of the Singular Perturbation +C Approximation method [2,3] is used. +C +C If JOB = 'P', the stochastic balancing method, in conjunction +C with the balancing-free square-root version of the Singular +C Perturbation Approximation method [2,3] is used. +C +C By setting TOL1 = TOL2, the routine can be also used to compute +C Balance & Truncate approximations. +C +C REFERENCES +C +C [1] Varga A. and Fasol K.H. +C A new square-root balancing-free stochastic truncation +C model reduction algorithm. +C Proc. of 12th IFAC World Congress, Sydney, 1993. +C +C [2] Liu Y. and Anderson B.D.O. +C Singular Perturbation Approximation of balanced systems. +C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. +C +C [3] Varga A. +C Balancing-free square-root algorithm for computing singular +C perturbation approximations. +C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, +C Vol. 2, pp. 1062-1065. +C +C NUMERICAL ASPECTS +C +C The implemented method relies on accuracy enhancing square-root +C or balancing-free square-root methods. The effectiveness of the +C accuracy enhancing technique depends on the accuracy of the +C solution of a Riccati equation. Ill-conditioned Riccati solution +C typically results when D is nearly rank deficient. +C 3 +C The algorithm requires about 100N floating point operations. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2000. +C D. Sima, University of Bucharest, May 2000. +C V. Sima, Research Institute for Informatics, Bucharest, May 2000. +C Partly based on the RASP routine SRBFS1, by A. Varga, 1992. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001. +C +C KEYWORDS +C +C Balance and truncate, minimal state-space representation, +C model reduction, multivariable system, +C singular perturbation approximation, state-space model, +C stochastic balancing. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TWO, ZERO + PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDT, LDTI, + $ LDWORK, M, N, NR, P + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*), T(LDT,*), TI(LDTI,*) + LOGICAL BWORK(*) +C .. Local Scalars .. + LOGICAL BAL, BTA, DISCR, FIXORD, SPA + INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, LW, + $ NMINR, NR1, NS, WRKOPT + DOUBLE PRECISION ATOL, RCOND, RICOND, SCALEC, SCALEO, TEMP, + $ TOLDEF +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB04MD, AB09DD, AB09HY, DGEMM, DGEMV, DGEQRF, + $ DGETRF, DGETRS, DLACPY, DORGQR, DSCAL, DTRMM, + $ DTRMV, MA02AD, MB03UD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) + SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) + BAL = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'S' ) + FIXORD = LSAME( ORDSEL, 'F' ) + LW = MAX( 2, N*(MAX( N, M, P )+5), + $ 2*N*P+MAX( P*(M+2), 10*N*(N+1) ) ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 .OR. P.GT.M ) THEN + INFO = -6 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN + INFO = -20 + ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN + INFO = -22 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -25 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09HX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + IWORK(1) = 0 + DWORK(1) = TWO + DWORK(2) = ONE + RETURN + END IF +C +C For discrete-time case, apply the discrete-to-continuous bilinear +C transformation. +C + IF( DISCR ) THEN +C +C Real workspace: need N, prefer larger; +C Integer workspace: need N. +C + CALL AB04MD( 'Discrete', N, M, P, ONE, ONE, A, LDA, B, LDB, + $ C, LDC, D, LDD, IWORK, DWORK, LDWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WRKOPT = MAX( N, INT( DWORK(1) ) ) + ELSE + WRKOPT = 0 + END IF +C +C Compute in TI and T the Cholesky factors Su and Ru of the +C controllability and observability Grammians, respectively. +C Real workspace: need MAX( 2, N*(MAX(N,M,P)+5), +C 2*N*P+MAX(P*(M+2),10*N*(N+1) ) ); +C prefer larger. +C Integer workspace: need 2*N. +C + CALL AB09HY( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ SCALEC, SCALEO, TI, LDTI, T, LDT, IWORK, + $ DWORK, LDWORK, BWORK, INFO ) + IF( INFO.NE.0) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + RICOND = DWORK(2) +C +C Save Su in V. +C + KU = 1 + KV = KU + N*N + KW = KV + N*N + CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) +C | x x | +C Compute Ru*Su in the form | 0 x | in TI. +C + DO 10 J = 1, N + CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, + $ TI(1,J), 1 ) + 10 CONTINUE +C +C Compute the singular value decomposition Ru*Su = V*S*UT +C of the upper triangular matrix Ru*Su, with UT in TI and V in U. +C +C Workspace: need 2*N*N + 5*N; +C prefer larger. +C + CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 7 + RETURN + ENDIF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Scale the singular values. +C + CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) +C +C Partition S, U and V conformally as: +C +C S = diag(S1,S2,S3), U = [U1,U2,U3] (U' in TI) and V = [V1,V2,V3] +C (in U). +C +C Compute the order NR of reduced system, as the order of S1. +C + TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) + ATOL = TOLDEF + IF( FIXORD ) THEN + IF( NR.GT.0 ) THEN + IF( HSV(NR).LE.ATOL ) THEN + NR = 0 + IWARN = 1 + FIXORD = .FALSE. + ENDIF + ENDIF + ELSE + ATOL = MAX( TOL1, ATOL ) + NR = 0 + ENDIF + IF( .NOT.FIXORD ) THEN + DO 20 J = 1, N + IF( HSV(J).LE.ATOL ) GO TO 30 + NR = NR + 1 + 20 CONTINUE + 30 CONTINUE + ENDIF +C +C Compute the order of minimal realization as the order of [S1 S2]. +C + NR1 = NR + 1 + NMINR = NR + IF( NR.LT.N ) THEN + IF( SPA ) ATOL = MAX( TOL2, TOLDEF ) + DO 40 J = NR1, N + IF( HSV(J).LE.ATOL ) GO TO 50 + NMINR = NMINR + 1 + 40 CONTINUE + 50 CONTINUE + END IF +C +C Finish if the order is zero. +C + IF( NR.EQ.0 ) THEN + IF( SPA ) THEN + CALL AB09DD( 'Continuous', N, M, P, NR, A, LDA, B, LDB, + $ C, LDC, D, LDD, RCOND, IWORK, DWORK, IERR ) + IWORK(1) = NMINR + ELSE + IWORK(1) = 0 + END IF + DWORK(1) = WRKOPT + DWORK(2) = RICOND + RETURN + END IF +C +C Compute NS, the order of S2. +C Note: For BTA, NS is always zero, because NMINR = NR. +C + NS = NMINR - NR +C +C Compute the truncation matrices. +C +C Compute TI' = | TI1' TI2' | = Ru'*| V1 V2 | in U. +C + CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NMINR, + $ ONE, T, LDT, DWORK(KU), N ) +C +C Compute T = | T1 T2 | = Su*| U1 U2 | . +C + CALL MA02AD( 'Full', NMINR, N, TI, LDTI, T, LDT ) + CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, + $ NMINR, ONE, DWORK(KV), N, T, LDT ) + KTAU = KV +C + IF( BAL ) THEN + IJ = KU +C +C Square-Root B&T/SPA method. +C +C Compute the truncation matrices for balancing +C -1/2 -1/2 +C T1*S1 and TI1'*S1 . +C + DO 70 J = 1, NR + TEMP = ONE/SQRT( HSV(J) ) + CALL DSCAL( N, TEMP, T(1,J), 1 ) + CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) + IJ = IJ + N + 70 CONTINUE + ELSE +C +C Balancing-Free B&T/SPA method. +C +C Compute orthogonal bases for the images of matrices T1 and +C TI1'. +C +C Workspace: need N*MAX(N,M,P) + 2*NR; +C prefer N*MAX(N,M,P) + NR*(NB+1) +C (NB determined by ILAENV for DGEQRF). +C + KW = KTAU + NR + LDW = LDWORK - KW + 1 + CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) + CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + ENDIF + IF( NS.GT.0 ) THEN +C +C Compute orthogonal bases for the images of matrices T2 and +C TI2'. +C +C Workspace: need N*MAX(N,M,P) + 2*NS; +C prefer N*MAX(N,M,P) + NS*(NB+1) +C (NB determined by ILAENV for DGEQRF). + KW = KTAU + NS + LDW = LDWORK - KW + 1 + CALL DGEQRF( N, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + CALL DORGQR( N, NS, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + CALL DGEQRF( N, NS, DWORK(KU+N*NR), N, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL DORGQR( N, NS, NS, DWORK(KU+N*NR), N, DWORK(KTAU), + $ DWORK(KW), LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + ENDIF +C +C Transpose TI' in TI. +C + CALL MA02AD( 'Full', N, NMINR, DWORK(KU), N, TI, LDTI ) +C + IF( .NOT.BAL ) THEN +C -1 +C Compute (TI1*T1) *TI1 in TI. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, + $ LDTI, T, LDT, ZERO, DWORK(KU), N ) + CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) + CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, + $ LDTI, IERR ) +C + IF( NS.GT.0 ) THEN +C -1 +C Compute (TI2*T2) *TI2 in TI2. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NS, NS, N, ONE, + $ TI(NR1,1), LDTI, T(1,NR1), LDT, ZERO, DWORK(KU), + $ N ) + CALL DGETRF( NS, NS, DWORK(KU), N, IWORK, IERR ) + CALL DGETRS( 'NoTranspose', NS, N, DWORK(KU), N, IWORK, + $ TI(NR1,1), LDTI, IERR ) + END IF + END IF +C +C Compute TI*A*T (A is in RSF). +C + IJ = KU + DO 80 J = 1, N + K = MIN( J+1, N ) + CALL DGEMV( 'NoTranspose', NMINR, K, ONE, TI, LDTI, A(1,J), 1, + $ ZERO, DWORK(IJ), 1 ) + IJ = IJ + N + 80 CONTINUE + CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, NMINR, N, ONE, + $ DWORK(KU), N, T, LDT, ZERO, A, LDA ) +C +C Compute TI*B and C*T. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, M, N, ONE, TI, + $ LDTI, DWORK(KU), N, ZERO, B, LDB ) +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NMINR, N, ONE, + $ DWORK(KU), P, T, LDT, ZERO, C, LDC ) +C +C Compute the singular perturbation approximation if possible. +C Note that IERR = 1 on exit from AB09DD cannot appear here. +C +C Workspace: need real 4*(NMINR-NR); +C need integer 2*(NMINR-NR). +C + CALL AB09DD( 'Continuous', NMINR, M, P, NR, A, LDA, B, LDB, + $ C, LDC, D, LDD, RCOND, IWORK, DWORK, IERR ) +C +C For discrete-time case, apply the continuous-to-discrete +C bilinear transformation. +C + IF( DISCR ) THEN + CALL AB04MD( 'Continuous', NR, M, P, ONE, ONE, A, LDA, B, LDB, + $ C, LDC, D, LDD, IWORK, DWORK, LDWORK, IERR ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + END IF + IWORK(1) = NMINR + DWORK(1) = WRKOPT + DWORK(2) = RICOND +C + RETURN +C *** Last line of AB09HX *** + END diff --git a/mex/sources/libslicot/AB09HY.f b/mex/sources/libslicot/AB09HY.f new file mode 100644 index 000000000..78a1093e6 --- /dev/null +++ b/mex/sources/libslicot/AB09HY.f @@ -0,0 +1,396 @@ + SUBROUTINE AB09HY( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ SCALEC, SCALEO, S, LDS, R, LDR, IWORK, + $ DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Cholesky factors Su and Ru of the controllability +C Grammian P = Su*Su' and observability Grammian Q = Ru'*Ru, +C respectively, satisfying +C +C A*P + P*A' + scalec^2*B*B' = 0, (1) +C +C A'*Q + Q*A + scaleo^2*Cw'*Cw = 0, (2) +C +C where +C Cw = Hw - Bw'*X, +C Hw = inv(Dw)*C, +C Bw = (B*D' + P*C')*inv(Dw'), +C D*D' = Dw*Dw' (Dw upper triangular), +C +C and, with Aw = A - Bw*Hw, X is the stabilizing solution of the +C Riccati equation +C +C Aw'*X + X*Aw + Hw'*Hw + X*Bw*Bw'*X = 0. (3) +C +C The P-by-M matrix D must have full row rank. Matrix A must be +C stable and in a real Schur form. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of state-space representation, i.e., +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. M >= P >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C stable state dynamics matrix A in a real Schur canonical +C form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B, corresponding to the Schur matrix A. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C, corresponding to the Schur +C matrix A. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must +C contain the full row rank input/output matrix D. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C SCALEC (output) DOUBLE PRECISION +C Scaling factor for the controllability Grammian in (1). +C +C SCALEO (output) DOUBLE PRECISION +C Scaling factor for the observability Grammian in (2). +C +C S (output) DOUBLE PRECISION array, dimension (LDS,N) +C The leading N-by-N upper triangular part of this array +C contains the Cholesky factor Su of the cotrollability +C Grammian P = Su*Su' satisfying (1). +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,N). +C +C R (output) DOUBLE PRECISION array, dimension (LDR,N) +C The leading N-by-N upper triangular part of this array +C contains the Cholesky factor Ru of the observability +C Grammian Q = Ru'*Ru satisfying (2). +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C Workspace +C +C IWORK INTEGER array, dimension 2*N +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK and DWORK(2) contains RCOND, the reciprocal +C condition number of the U11 matrix from the expression +C used to compute X = U21*inv(U11). A small value RCOND +C indicates possible ill-conditioning of the Riccati +C equation (3). +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 2, N*(MAX(N,M,P)+5), +C 2*N*P+MAX(P*(M+2),10*N*(N+1) ) ). +C For optimum performance LDWORK should be larger. +C +C BWORK LOGICAL array, dimension 2*N +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the state matrix A is not stable or is not in a +C real Schur form; +C = 2: the reduction of Hamiltonian matrix to real Schur +C form failed; +C = 3: the reordering of the real Schur form of the +C Hamiltonian matrix failed; +C = 4: the Hamiltonian matrix has less than N stable +C eigenvalues; +C = 5: the coefficient matrix U11 in the linear system +C X*U11 = U21, used to determine X, is singular to +C working precision; +C = 6: the feedthrough matrix D has not a full row rank P. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2000. +C D. Sima, University of Bucharest, May 2000. +C V. Sima, Research Institute for Informatics, Bucharest, May 2000. +C Based on the RASP routines SRGRO and SRGRO1, by A. Varga, 1992. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001. +C +C KEYWORDS +C +C Minimal realization, model reduction, multivariable system, +C state-space model, state-space representation, +C stochastic balancing. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDR, LDS, LDWORK, M, N, + $ P + DOUBLE PRECISION SCALEC, SCALEO +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), R(LDR,*), S(LDS,*) + LOGICAL BWORK(*) +C .. Local Scalars .. + INTEGER I, IERR, KBW, KCW, KD, KDW, KG, KQ, KS, KTAU, KU, + $ KW, KWI, KWR, LW, N2, WRKOPT + DOUBLE PRECISION RCOND, RTOL +C .. External Functions .. + DOUBLE PRECISION DLANGE, DLAMCH + EXTERNAL DLANGE, DLAMCH +C .. External Subroutines .. + EXTERNAL DGEMM, DGERQF, DLACPY, DORGRQ, DSYRK, DTRMM, + $ DTRSM, SB02MD, SB03OU, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LW = MAX( 2, N*( MAX( N, M, P ) + 5 ), + $ 2*N*P + MAX( P*(M + 2), 10*N*(N + 1) ) ) +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 .OR. P.GT.M ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDR.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -20 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09HY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + SCALEC = ONE + SCALEO = ONE + IF( MIN( N, M, P ).EQ.0 ) THEN + DWORK(1) = TWO + DWORK(2) = ONE + RETURN + END IF +C +C Solve for Su the Lyapunov equation +C 2 +C A*(Su*Su') + (Su*Su')*A' + scalec *B*B' = 0 . +C +C Workspace: need N*(MAX(N,M) + 5); +C prefer larger. +C + KU = 1 + KTAU = KU + N*MAX( N, M ) + KW = KTAU + N +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) + CALL SB03OU( .FALSE., .TRUE., N, M, A, LDA, DWORK(KU), N, + $ DWORK(KTAU), S, LDS, SCALEC, DWORK(KW), + $ LDWORK - KW + 1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + ENDIF + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Allocate workspace for Bw' (P*N), Cw (P*N), Q2 (P*M), +C where Q2 = inv(Dw)*D. +C Workspace: need 2*N*P + P*M. +C + KBW = 1 + KCW = KBW + P*N + KD = KCW + P*N + KDW = KD + P*(M - P) + KTAU = KD + P*M + KW = KTAU + P +C +C Compute an upper-triangular Dw such that D*D' = Dw*Dw', using +C the RQ-decomposition of D: D = [0 Dw]*( Q1 ). +C ( Q2 ) +C Additional workspace: need 2*P; prefer P + P*NB. +C + CALL DLACPY( 'F', P, M, D, LDD, DWORK(KD), P ) + CALL DGERQF( P, M, DWORK(KD), P, DWORK(KTAU), DWORK(KW), + $ LDWORK-KW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Check the full row rank of D. +C + RTOL = DBLE( M ) * DLAMCH( 'E' ) * + $ DLANGE( '1', P, M, D, LDD, DWORK ) + DO 10 I = KDW, KDW+P*P-1, P+1 + IF( ABS( DWORK(I) ).LE.RTOL ) THEN + INFO = 6 + RETURN + END IF + 10 CONTINUE +C -1 +C Compute Hw = Dw *C. +C + CALL DLACPY( 'F', P, N, C, LDC, DWORK(KCW), P ) + CALL DTRSM( 'Left', 'Upper', 'No-transpose', 'Non-unit', P, N, + $ ONE, DWORK(KDW), P, DWORK(KCW), P ) +C +C Compute Bw' = inv(Dw)*(D*B' + C*Su*Su'). +C +C Compute first Hw*Su*Su' in Bw'. +C + CALL DLACPY( 'F', P, N, DWORK(KCW), P, DWORK(KBW), P ) + CALL DTRMM( 'Right', 'Upper', 'No-transpose', 'Non-unit', P, N, + $ ONE, S, LDS, DWORK(KBW), P ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', P, N, + $ ONE, S, LDS, DWORK(KBW), P ) +C +C Compute Q2 = inv(Dw)*D, as the last P lines of the orthogonal +C matrix ( Q1 ) from the RQ decomposition of D. +C ( Q2 ) +C Additional workspace: need P; prefer P*NB. +C + CALL DORGRQ( P, M, P, DWORK(KD), P, DWORK(KTAU), DWORK(KW), + $ LDWORK-KW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Compute Bw' <- Bw' + Q2*B'. +C + CALL DGEMM( 'No-transpose', 'Transpose', P, N, M, ONE, + $ DWORK(KD), P, B, LDB, ONE, DWORK(KBW), P ) +C +C Compute Aw = A - Bw*Hw in R. +C + CALL DLACPY( 'F', N, N, A, LDA, R, LDR ) + CALL DGEMM( 'Transpose', 'No-transpose', N, N, P, -ONE, + $ DWORK(KBW), P, DWORK(KCW), P, ONE, R, LDR ) +C +C Allocate storage to solve the Riccati equation (3) for +C G(N*N), Q(N*N), WR(2N), WI(2N), S(2N*2N), U(2N*2N). +C + N2 = N + N + KG = KD + KQ = KG + N*N + KWR = KQ + N*N + KWI = KWR + N2 + KS = KWI + N2 + KU = KS + N2*N2 + KW = KU + N2*N2 +C +C Compute G = -Bw*Bw'. +C + CALL DSYRK( 'Upper', 'Transpose', N, P, -ONE, DWORK(KBW), P, ZERO, + $ DWORK(KG), N ) +C +C Compute Q = Hw'*Hw. +C + CALL DSYRK( 'Upper', 'Transpose', N, P, ONE, DWORK(KCW), P, ZERO, + $ DWORK(KQ), N ) +C +C Solve +C +C Aw'*X + X*Aw + Q - X*G*X = 0, +C +C with Q = Hw'*Hw and G = -Bw*Bw'. +C Additional workspace: need 6*N; +C prefer larger. +C + CALL SB02MD( 'Continuous', 'None', 'Upper', 'General', 'Stable', + $ N, R, LDR, DWORK(KG), N, DWORK(KQ), N, RCOND, + $ DWORK(KWR), DWORK(KWI), DWORK(KS), N2, + $ DWORK(KU), N2, IWORK, DWORK(KW), LDWORK-KW+1, + $ BWORK, INFO ) + IF( INFO.NE.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Compute Cw = Hw - Bw'*X. +C + CALL DGEMM ( 'No-transpose', 'No-transpose', P, N, N, -ONE, + $ DWORK(KBW), P, DWORK(KQ), N, ONE, DWORK(KCW), P ) +C +C Solve for Ru the Lyapunov equation +C 2 +C A'*(Ru'*Ru) + (Ru'*Ru)*A + scaleo * Cw'*Cw = 0 . +C +C Workspace: need N*(MAX(N,P) + 5); +C prefer larger. +C + KTAU = KCW + N*MAX( N, P ) + KW = KTAU + N +C + CALL SB03OU( .FALSE., .FALSE., N, P, A, LDA, DWORK(KCW), P, + $ DWORK(KTAU), R, LDR, SCALEO, DWORK(KW), + $ LDWORK - KW + 1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Save optimal workspace and RCOND. +C + DWORK(1) = WRKOPT + DWORK(2) = RCOND +C + RETURN +C *** Last line of AB09HY *** + END diff --git a/mex/sources/libslicot/AB09ID.f b/mex/sources/libslicot/AB09ID.f new file mode 100644 index 000000000..2448d4660 --- /dev/null +++ b/mex/sources/libslicot/AB09ID.f @@ -0,0 +1,1048 @@ + SUBROUTINE AB09ID( DICO, JOBC, JOBO, JOB, WEIGHT, EQUIL, ORDSEL, + $ N, M, P, NV, PV, NW, MW, NR, ALPHA, ALPHAC, + $ ALPHAO, A, LDA, B, LDB, C, LDC, D, LDD, + $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, + $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, + $ NS, HSV, TOL1, TOL2, IWORK, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C state-space representation (A,B,C,D) by using the frequency +C weighted square-root or balancing-free square-root +C Balance & Truncate (B&T) or Singular Perturbation Approximation +C (SPA) model reduction methods. The algorithm tries to minimize +C the norm of the frequency-weighted error +C +C ||V*(G-Gr)*W|| +C +C where G and Gr are the transfer-function matrices of the original +C and reduced order models, respectively, and V and W are +C frequency-weighting transfer-function matrices. V and W must not +C have poles on the imaginary axis for a continuous-time +C system or on the unit circle for a discrete-time system. +C If G is unstable, only the ALPHA-stable part of G is reduced. +C In case of possible pole-zero cancellations in V*G and/or G*W, +C the absolute values of parameters ALPHAO and/or ALPHAC must be +C different from 1. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBC CHARACTER*1 +C Specifies the choice of frequency-weighted controllability +C Grammian as follows: +C = 'S': choice corresponding to a combination method [4] +C of the approaches of Enns [1] and Lin-Chiu [2,3]; +C = 'E': choice corresponding to the stability enhanced +C modified combination method of [4]. +C +C JOBO CHARACTER*1 +C Specifies the choice of frequency-weighted observability +C Grammian as follows: +C = 'S': choice corresponding to a combination method [4] +C of the approaches of Enns [1] and Lin-Chiu [2,3]; +C = 'E': choice corresponding to the stability enhanced +C modified combination method of [4]. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root Balance & Truncate method; +C = 'F': use the balancing-free square-root +C Balance & Truncate method; +C = 'S': use the square-root Singular Perturbation +C Approximation method; +C = 'P': use the balancing-free square-root +C Singular Perturbation Approximation method. +C +C WEIGHT CHARACTER*1 +C Specifies the type of frequency weighting, as follows: +C = 'N': no weightings are used (V = I, W = I); +C = 'L': only left weighting V is used (W = I); +C = 'R': only right weighting W is used (V = I); +C = 'B': both left and right weightings V and W are used. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e., the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NV (input) INTEGER +C The order of the matrix AV. Also the number of rows of +C the matrix BV and the number of columns of the matrix CV. +C NV represents the dimension of the state vector of the +C system with the transfer-function matrix V. NV >= 0. +C +C PV (input) INTEGER +C The number of rows of the matrices CV and DV. PV >= 0. +C PV represents the dimension of the output vector of the +C system with the transfer-function matrix V. +C +C NW (input) INTEGER +C The order of the matrix AW. Also the number of rows of +C the matrix BW and the number of columns of the matrix CW. +C NW represents the dimension of the state vector of the +C system with the transfer-function matrix W. NW >= 0. +C +C MW (input) INTEGER +C The number of columns of the matrices BW and DW. MW >= 0. +C MW represents the dimension of the input vector of the +C system with the transfer-function matrix W. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of the +C resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. For a system with NU ALPHA-unstable +C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), +C NR is set as follows: if ORDSEL = 'F', NR is equal to +C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order +C on entry, NMIN is the number of frequency-weighted Hankel +C singular values greater than NS*EPS*S1, EPS is the +C machine precision (see LAPACK Library Routine DLAMCH) +C and S1 is the largest Hankel singular value (computed +C in HSV(1)); NR can be further reduced to ensure +C HSV(NR-NU) > HSV(NR+1-NU); +C if ORDSEL = 'A', NR is the sum of NU and the number of +C Hankel singular values greater than MAX(TOL1,NS*EPS*S1). +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix A. For a continuous-time +C system (DICO = 'C'), ALPHA <= 0 is the boundary value for +C the real parts of eigenvalues, while for a discrete-time +C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary. +C +C ALPHAC (input) DOUBLE PRECISION +C Combination method parameter for defining the +C frequency-weighted controllability Grammian (see METHOD); +C ABS(ALPHAC) <= 1. +C +C ALPHAO (input) DOUBLE PRECISION +C Combination method parameter for defining the +C frequency-weighted observability Grammian (see METHOD); +C ABS(ALPHAO) <= 1. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system. +C The resulting A has a block-diagonal form with two blocks. +C For a system with NU ALPHA-unstable eigenvalues and +C NS ALPHA-stable eigenvalues (NU+NS = N), the leading +C NU-by-NU block contains the unreduced part of A +C corresponding to ALPHA-unstable eigenvalues. +C The trailing (NR+NS-N)-by-(NR+NS-N) block contains +C the reduced part of A corresponding to ALPHA-stable +C eigenvalues. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) +C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV +C part of this array must contain the state matrix AV of +C the system with the transfer-function matrix V. +C On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and +C INFO = 0, the leading NVR-by-NVR part of this array +C contains the state matrix of a minimal realization of V +C in a real Schur form. NVR is returned in IWORK(2). +C AV is not referenced if WEIGHT = 'R' or 'N', +C or MIN(N,M,P) = 0. +C +C LDAV INTEGER +C The leading dimension of array AV. +C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; +C LDAV >= 1, if WEIGHT = 'R' or 'N'. +C +C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) +C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part +C of this array must contain the input matrix BV of the +C system with the transfer-function matrix V. +C On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and +C INFO = 0, the leading NVR-by-P part of this array contains +C the input matrix of a minimal realization of V. +C BV is not referenced if WEIGHT = 'R' or 'N', +C or MIN(N,M,P) = 0. +C +C LDBV INTEGER +C The leading dimension of array BV. +C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; +C LDBV >= 1, if WEIGHT = 'R' or 'N'. +C +C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) +C On entry, if WEIGHT = 'L' or 'B', the leading PV-by-NV +C part of this array must contain the output matrix CV of +C the system with the transfer-function matrix V. +C On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and +C INFO = 0, the leading PV-by-NVR part of this array +C contains the output matrix of a minimal realization of V. +C CV is not referenced if WEIGHT = 'R' or 'N', +C or MIN(N,M,P) = 0. +C +C LDCV INTEGER +C The leading dimension of array CV. +C LDCV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; +C LDCV >= 1, if WEIGHT = 'R' or 'N'. +C +C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) +C If WEIGHT = 'L' or 'B', the leading PV-by-P part of this +C array must contain the feedthrough matrix DV of the system +C with the transfer-function matrix V. +C DV is not referenced if WEIGHT = 'R' or 'N', +C or MIN(N,M,P) = 0. +C +C LDDV INTEGER +C The leading dimension of array DV. +C LDDV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; +C LDDV >= 1, if WEIGHT = 'R' or 'N'. +C +C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) +C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW +C part of this array must contain the state matrix AW of +C the system with the transfer-function matrix W. +C On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and +C INFO = 0, the leading NWR-by-NWR part of this array +C contains the state matrix of a minimal realization of W +C in a real Schur form. NWR is returned in IWORK(3). +C AW is not referenced if WEIGHT = 'L' or 'N', +C or MIN(N,M,P) = 0. +C +C LDAW INTEGER +C The leading dimension of array AW. +C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; +C LDAW >= 1, if WEIGHT = 'L' or 'N'. +C +C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,MW) +C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-MW +C part of this array must contain the input matrix BW of the +C system with the transfer-function matrix W. +C On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and +C INFO = 0, the leading NWR-by-MW part of this array +C contains the input matrix of a minimal realization of W. +C BW is not referenced if WEIGHT = 'L' or 'N', +C or MIN(N,M,P) = 0. +C +C LDBW INTEGER +C The leading dimension of array BW. +C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; +C LDBW >= 1, if WEIGHT = 'L' or 'N'. +C +C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) +C On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part +C of this array must contain the output matrix CW of the +C system with the transfer-function matrix W. +C On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and +C INFO = 0, the leading M-by-NWR part of this array contains +C the output matrix of a minimal realization of W. +C CW is not referenced if WEIGHT = 'L' or 'N', +C or MIN(N,M,P) = 0. +C +C LDCW INTEGER +C The leading dimension of array CW. +C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; +C LDCW >= 1, if WEIGHT = 'L' or 'N'. +C +C DW (input) DOUBLE PRECISION array, dimension (LDDW,MW) +C If WEIGHT = 'R' or 'B', the leading M-by-MW part of this +C array must contain the feedthrough matrix DW of the system +C with the transfer-function matrix W. +C DW is not referenced if WEIGHT = 'L' or 'N', +C or MIN(N,M,P) = 0. +C +C LDDW INTEGER +C The leading dimension of array DW. +C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; +C LDDW >= 1, if WEIGHT = 'L' or 'N'. +C +C NS (output) INTEGER +C The dimension of the ALPHA-stable subsystem. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, the leading NS elements of this array contain +C the frequency-weighted Hankel singular values, ordered +C decreasingly, of the ALPHA-stable part of the original +C system. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*S1, where c is a constant in the +C interval [0.00001,0.001], and S1 is the largest +C frequency-weighted Hankel singular value of the +C ALPHA-stable part of the original system (computed +C in HSV(1)). +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = NS*EPS*S1, where NS is the number of +C ALPHA-stable eigenvalues of A and EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the ALPHA-stable part of the given system. +C The recommended value is TOL2 = NS*EPS*S1. +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension +C ( MAX( 3, LIWRK1, LIWRK2, LIWRK3 ) ), where +C LIWRK1 = 0, if JOB = 'B'; +C LIWRK1 = N, if JOB = 'F'; +C LIWRK1 = 2*N, if JOB = 'S' or 'P'; +C LIWRK2 = 0, if WEIGHT = 'R' or 'N' or NV = 0; +C LIWRK2 = NV+MAX(P,PV), if WEIGHT = 'L' or 'B' and NV > 0; +C LIWRK3 = 0, if WEIGHT = 'L' or 'N' or NW = 0; +C LIWRK3 = NW+MAX(M,MW), if WEIGHT = 'R' or 'B' and NW > 0. +C On exit, if INFO = 0, IWORK(1) contains the order of a +C minimal realization of the stable part of the system, +C IWORK(2) and IWORK(3) contain the actual orders +C of the state space realizations of V and W, respectively. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( LMINL, LMINR, LRCF, +C 2*N*N + MAX( 1, LLEFT, LRIGHT, 2*N*N+5*N, +C N*MAX(M,P) ) ), +C where +C LMINL = 0, if WEIGHT = 'R' or 'N' or NV = 0; otherwise, +C LMINL = MAX(LLCF,NV+MAX(NV,3*P)) if P = PV; +C LMINL = MAX(P,PV)*(2*NV+MAX(P,PV))+ +C MAX(LLCF,NV+MAX(NV,3*P,3*PV)) if P <> PV; +C LRCF = 0, and +C LMINR = 0, if WEIGHT = 'L' or 'N' or NW = 0; otherwise, +C LMINR = NW+MAX(NW,3*M) if M = MW; +C LMINR = 2*NW*MAX(M,MW)+NW+MAX(NW,3*M,3*MW) if M <> MW; +C LLCF = PV*(NV+PV)+PV*NV+MAX(NV*(NV+5), PV*(PV+2), +C 4*PV, 4*P); +C LRCF = MW*(NW+MW)+MAX(NW*(NW+5),MW*(MW+2),4*MW,4*M) +C LLEFT = (N+NV)*(N+NV+MAX(N+NV,PV)+5) +C if WEIGHT = 'L' or 'B' and PV > 0; +C LLEFT = N*(P+5) if WEIGHT = 'R' or 'N' or PV = 0; +C LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5) +C if WEIGHT = 'R' or 'B' and MW > 0; +C LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or MW = 0. +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than NSMIN, the sum of the order of the +C ALPHA-unstable part and the order of a minimal +C realization of the ALPHA-stable part of the given +C system; in this case, the resulting NR is set equal +C to NSMIN; +C = 2: with ORDSEL = 'F', the selected order NR corresponds +C to repeated singular values for the ALPHA-stable +C part, which are neither all included nor all +C excluded from the reduced model; in this case, the +C resulting NR is automatically decreased to exclude +C all repeated singular values; +C = 3: with ORDSEL = 'F', the selected order NR is less +C than the order of the ALPHA-unstable part of the +C given system; in this case NR is set equal to the +C order of the ALPHA-unstable part. +C = 10+K: K violations of the numerical stability condition +C occured during the assignment of eigenvalues in the +C SLICOT Library routines SB08CD and/or SB08DD. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of the ordered real Schur form of A +C failed; +C = 2: the separation of the ALPHA-stable/unstable +C diagonal blocks failed because of very close +C eigenvalues; +C = 3: the reduction to a real Schur form of the state +C matrix of a minimal realization of V failed; +C = 4: a failure was detected during the ordering of the +C real Schur form of the state matrix of a minimal +C realization of V or in the iterative process to +C compute a left coprime factorization with inner +C denominator; +C = 5: if DICO = 'C' and the matrix AV has an observable +C eigenvalue on the imaginary axis, or DICO = 'D' and +C AV has an observable eigenvalue on the unit circle; +C = 6: the reduction to a real Schur form of the state +C matrix of a minimal realization of W failed; +C = 7: a failure was detected during the ordering of the +C real Schur form of the state matrix of a minimal +C realization of W or in the iterative process to +C compute a right coprime factorization with inner +C denominator; +C = 8: if DICO = 'C' and the matrix AW has a controllable +C eigenvalue on the imaginary axis, or DICO = 'D' and +C AW has a controllable eigenvalue on the unit circle; +C = 9: the computation of eigenvalues failed; +C = 10: the computation of Hankel singular values failed. +C +C METHOD +C +C Let G be the transfer-function matrix of the original +C linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t), (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09ID determines +C the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t), (2) +C +C such that the corresponding transfer-function matrix Gr minimizes +C the norm of the frequency-weighted error +C +C V*(G-Gr)*W, (3) +C +C where V and W are transfer-function matrices without poles on the +C imaginary axis in continuous-time case or on the unit circle in +C discrete-time case. +C +C The following procedure is used to reduce G: +C +C 1) Decompose additively G, of order N, as +C +C G = G1 + G2, +C +C such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and +C G2 = (A2,B2,C2,0), of order NU, has only ALPHA-unstable poles. +C +C 2) Compute for G1 a B&T or SPA frequency-weighted approximation +C G1r of order NR-NU using the combination method or the +C modified combination method of [4]. +C +C 3) Assemble the reduced model Gr as +C +C Gr = G1r + G2. +C +C For the frequency-weighted reduction of the ALPHA-stable part, +C several methods described in [4] can be employed in conjunction +C with the combination method and modified combination method +C proposed in [4]. +C +C If JOB = 'B', the square-root B&T method is used. +C If JOB = 'F', the balancing-free square-root version of the +C B&T method is used. +C If JOB = 'S', the square-root version of the SPA method is used. +C If JOB = 'P', the balancing-free square-root version of the +C SPA method is used. +C +C For each of these methods, left and right truncation matrices +C are determined using the Cholesky factors of an input +C frequency-weighted controllability Grammian P and an output +C frequency-weighted observability Grammian Q. +C P and Q are computed from the controllability Grammian Pi of G*W +C and the observability Grammian Qo of V*G. Using special +C realizations of G*W and V*G, Pi and Qo are computed in the +C partitioned forms +C +C Pi = ( P11 P12 ) and Qo = ( Q11 Q12 ) , +C ( P12' P22 ) ( Q12' Q22 ) +C +C where P11 and Q11 are the leading N-by-N parts of Pi and Qo, +C respectively. Let P0 and Q0 be non-negative definite matrices +C defined below +C -1 +C P0 = P11 - ALPHAC**2*P12*P22 *P21 , +C -1 +C Q0 = Q11 - ALPHAO**2*Q12*Q22 *Q21. +C +C The frequency-weighted controllability and observability +C Grammians, P and Q, respectively, are defined as follows: +C P = P0 if JOBC = 'S' (standard combination method [4]); +C P = P1 >= P0 if JOBC = 'E', where P1 is the controllability +C Grammian defined to enforce stability for a modified combination +C method of [4]; +C Q = Q0 if JOBO = 'S' (standard combination method [4]); +C Q = Q1 >= Q0 if JOBO = 'E', where Q1 is the observability +C Grammian defined to enforce stability for a modified combination +C method of [4]. +C +C If JOBC = JOBO = 'S' and ALPHAC = ALPHAO = 0, the choice of +C Grammians corresponds to the method of Enns [1], while if +C ALPHAC = ALPHAO = 1, the choice of Grammians corresponds +C to the method of Lin and Chiu [2,3]. +C +C If JOBC = 'S' and ALPHAC = 1, no pole-zero cancellations must +C occur in G*W. If JOBO = 'S' and ALPHAO = 1, no pole-zero +C cancellations must occur in V*G. The presence of pole-zero +C cancellations leads to meaningless results and must be avoided. +C +C The frequency-weighted Hankel singular values HSV(1), ...., +C HSV(N) are computed as the square roots of the eigenvalues +C of the product P*Q. +C +C REFERENCES +C +C [1] Enns, D. +C Model reduction with balanced realizations: An error bound +C and a frequency weighted generalization. +C Proc. 23-th CDC, Las Vegas, pp. 127-132, 1984. +C +C [2] Lin, C.-A. and Chiu, T.-Y. +C Model reduction via frequency-weighted balanced realization. +C Control Theory and Advanced Technology, vol. 8, +C pp. 341-351, 1992. +C +C [3] Sreeram, V., Anderson, B.D.O and Madievski, A.G. +C New results on frequency weighted balanced reduction +C technique. +C Proc. ACC, Seattle, Washington, pp. 4004-4009, 1995. +C +C [4] Varga, A. and Anderson, B.D.O. +C Square-root balancing-free methods for the frequency-weighted +C balancing related model reduction. +C (report in preparation) +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root +C techniques. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. +C D. Sima, University of Bucharest, August 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. +C +C REVISIONS +C +C A. Varga, Australian National University, Canberra, November 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, +C Sep. 2001. +C +C KEYWORDS +C +C Frequency weighting, model reduction, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION C100, ONE, ZERO + PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOB, JOBC, JOBO, ORDSEL, WEIGHT + INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, + $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, MW, + $ N, NR, NS, NV, NW, P, PV + DOUBLE PRECISION ALPHA, ALPHAC, ALPHAO, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), + $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), + $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), + $ D(LDD,*), DV(LDDV,*), DW(LDDW,*), DWORK(*), + $ HSV(*) +C .. Local Scalars .. + LOGICAL BAL, BTA, DISCR, FIXORD, FRWGHT, LEFTW, RIGHTW, + $ SCALE, SPA + INTEGER IERR, IWARNL, KBR, KBV, KBW, KCR, KCV, KCW, KDR, + $ KDV, KI, KL, KT, KTI, KU, KW, LCF, LDW, LW, NMR, + $ NN, NNQ, NNR, NNV, NNW, NRA, NU, NU1, NVR, NWR, + $ PPV, WRKOPT + DOUBLE PRECISION ALPWRK, MAXRED, SCALEC, SCALEO +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB09IX, AB09IY, DLACPY, SB08CD, SB08DD, TB01ID, + $ TB01KD, TB01PD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) + SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) + BAL = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'S' ) + SCALE = LSAME( EQUIL, 'S' ) + FIXORD = LSAME( ORDSEL, 'F' ) + LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) + RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) + FRWGHT = LEFTW .OR. RIGHTW +C + LW = 1 + NN = N*N + NNV = N + NV + NNW = N + NW + PPV = MAX( P, PV ) +C + IF( LEFTW .AND. PV.GT.0 ) THEN + LW = MAX( LW, NNV*( NNV + MAX( NNV, PV ) + 5 ) ) + ELSE + LW = MAX( LW, N*( P + 5 ) ) + END IF +C + IF( RIGHTW .AND. MW.GT.0 ) THEN + LW = MAX( LW, NNW*( NNW + MAX( NNW, MW ) + 5 ) ) + ELSE + LW = MAX( LW, N*( M + 5 ) ) + END IF + LW = 2*NN + MAX( LW, 2*NN + 5*N, N*MAX( M, P ) ) +C + IF( LEFTW .AND. NV.GT.0 ) THEN + LCF = PV*( NV + PV ) + PV*NV + + $ MAX( NV*( NV + 5 ), PV*( PV + 2 ), 4*PPV ) + IF( PV.EQ.P ) THEN + LW = MAX( LW, LCF, NV + MAX( NV, 3*P ) ) + ELSE + LW = MAX( LW, PPV*( 2*NV + PPV ) + + $ MAX( LCF, NV + MAX( NV, 3*PPV ) ) ) + END IF + END IF +C + IF( RIGHTW .AND. NW.GT.0 ) THEN + IF( MW.EQ.M ) THEN + LW = MAX( LW, NW + MAX( NW, 3*M ) ) + ELSE + LW = MAX( LW, 2*NW*MAX( M, MW ) + + $ NW + MAX( NW, 3*M, 3*MW ) ) + END IF + LW = MAX( LW, MW*( NW + MW ) + + $ MAX( NW*( NW + 5 ), MW*( MW + 2 ), 4*MW, 4*M ) ) + END IF +C +C Check the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) + $ THEN + INFO = -2 + ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) + $ THEN + INFO = -3 + ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN + INFO = -4 + ELSE IF( .NOT. ( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN + INFO = -5 + ELSE IF( .NOT. ( SCALE .OR. LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -6 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -7 + ELSE IF( N.LT.0 ) THEN + INFO = -8 + ELSE IF( M.LT.0 ) THEN + INFO = -9 + ELSE IF( P.LT.0 ) THEN + INFO = -10 + ELSE IF( NV.LT.0 ) THEN + INFO = -11 + ELSE IF( PV.LT.0 ) THEN + INFO = -12 + ELSE IF( NW.LT.0 ) THEN + INFO = -13 + ELSE IF( MW.LT.0 ) THEN + INFO = -14 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -15 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -16 + ELSE IF( ABS( ALPHAC ).GT.ONE ) THEN + INFO = -17 + ELSE IF( ABS( ALPHAO ).GT.ONE ) THEN + INFO = -18 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -20 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -22 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -24 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -26 + ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN + INFO = -28 + ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN + INFO = -30 + ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.PV ) ) THEN + INFO = -32 + ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.PV ) ) THEN + INFO = -34 + ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN + INFO = -36 + ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN + INFO = -38 + ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN + INFO = -40 + ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN + INFO = -42 + ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN + INFO = -46 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -49 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09ID', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + NS = 0 + IWORK(1) = 0 + IWORK(2) = NV + IWORK(3) = NW + DWORK(1) = ONE + RETURN + END IF +C + IF( SCALE ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C Workspace: N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Correct the value of ALPHA to ensure stability. +C + ALPWRK = ALPHA + IF( DISCR ) THEN + IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) + ELSE + IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) + END IF +C +C Allocate working storage. +C + KU = 1 + KL = KU + NN + KI = KL + N + KW = KI + N +C +C Reduce A to a block-diagonal real Schur form, with the +C ALPHA-unstable part in the leading diagonal position, using a +C non-orthogonal similarity transformation, A <- inv(T)*A*T, and +C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, + $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), + $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 1 + ELSE + INFO = 2 + END IF + RETURN + END IF +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Determine NRA, the desired order for the reduction of stable part. +C + IWARNL = 0 + NS = N - NU + IF( FIXORD ) THEN + NRA = MAX( 0, NR-NU ) + IF( NR.LT.NU ) + $ IWARNL = 3 + ELSE + NRA = 0 + END IF +C +C Finish if only unstable part is present. +C + IF( NS.EQ.0 ) THEN + NR = NU + DWORK(1) = WRKOPT + IWORK(1) = 0 + IWORK(2) = NV + IWORK(3) = NW + RETURN + END IF +C + NVR = NV + IF( LEFTW .AND. NV.GT.0 ) THEN +C +C Compute a left-coprime factorization with inner denominator +C of a minimal realization of V. The resulting AV is in +C real Schur form. +C Workspace needed: real LV+MAX( 1, LCF, +C NV + MAX( NV, 3*P, 3*PV ) ), +C where +C LV = 0 if P = PV and +C LV = MAX(P,PV)*(2*NV+MAX(P,PV)) +C otherwise; +C LCF = PV*(NV+PV) + +C MAX( 1, PV*NV + MAX( NV*(NV+5), +C PV*(PV+2),4*PV,4*P ) ); +C prefer larger; +C integer NV + MAX(P,PV). +C + IF( P.EQ.PV ) THEN + KW = 1 + CALL TB01PD( 'Minimal', 'Scale', NV, P, PV, AV, LDAV, + $ BV, LDBV, CV, LDCV, NVR, ZERO, + $ IWORK, DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + KBR = 1 + KDR = KBR + PV*NVR + KW = KDR + PV*PV + CALL SB08CD( DICO, NVR, P, PV, AV, LDAV, BV, LDBV, CV, LDCV, + $ DV, LDDV, NNQ, NNR, DWORK(KBR), MAX( 1, NVR ), + $ DWORK(KDR), PV, ZERO, DWORK(KW), LDWORK-KW+1, + $ IWARN, IERR ) + ELSE + LDW = MAX( P, PV ) + KBV = 1 + KCV = KBV + NV*LDW + KW = KCV + NV*LDW + CALL DLACPY( 'Full', NV, P, BV, LDBV, DWORK(KBV), NV ) + CALL DLACPY( 'Full', PV, NV, CV, LDCV, DWORK(KCV), LDW ) + CALL TB01PD( 'Minimal', 'Scale', NV, P, PV, AV, LDAV, + $ DWORK(KBV), NV, DWORK(KCV), LDW, NVR, ZERO, + $ IWORK, DWORK(KW), LDWORK-KW+1, INFO ) + KDV = KW + KBR = KDV + LDW*LDW + KDR = KBR + PV*NVR + KW = KDR + PV*PV + CALL DLACPY( 'Full', PV, P, DV, LDDV, DWORK(KDV), LDW ) + CALL SB08CD( DICO, NVR, P, PV, AV, LDAV, DWORK(KBV), NV, + $ DWORK(KCV), LDW, DWORK(KDV), LDW, NNQ, NNR, + $ DWORK(KBR), MAX( 1, NVR ), DWORK(KDR), PV, + $ ZERO, DWORK(KW), LDWORK-KW+1, IWARN, IERR ) + CALL DLACPY( 'Full', NVR, P, DWORK(KBV), NV, BV, LDBV ) + CALL DLACPY( 'Full', PV, NVR, DWORK(KCV), LDW, CV, LDCV ) + CALL DLACPY( 'Full', PV, P, DWORK(KDV), LDW, DV, LDDV ) + END IF + IF( IERR.NE.0 ) THEN + INFO = IERR + 2 + RETURN + END IF + NVR = NNQ + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + IF( IWARN.GT.0 ) + $ IWARN = 10 + IWARN + END IF +C + NWR = NW + IF( RIGHTW .AND. NW.GT.0 ) THEN +C +C Compute a minimal realization of W. +C Workspace needed: real LW+MAX(1, NW + MAX(NW, 3*M, 3*MW)); +C where +C LW = 0, if M = MW and +C LW = 2*NW*MAX(M,MW), otherwise; +C prefer larger; +C integer NW + MAX(M,MW). +C + IF( M.EQ.MW ) THEN + KW = 1 + CALL TB01PD( 'Minimal', 'Scale', NW, MW, M, AW, LDAW, + $ BW, LDBW, CW, LDCW, NWR, ZERO, IWORK, DWORK, + $ LDWORK, INFO ) + ELSE + LDW = MAX( M, MW ) + KBW = 1 + KCW = KBW + NW*LDW + KW = KCW + NW*LDW + CALL DLACPY( 'Full', NW, MW, BW, LDBW, DWORK(KBW), NW ) + CALL DLACPY( 'Full', M, NW, CW, LDCW, DWORK(KCW), LDW ) + CALL TB01PD( 'Minimal', 'Scale', NW, MW, M, AW, LDAW, + $ DWORK(KBW), NW, DWORK(KCW), LDW, NWR, ZERO, + $ IWORK, DWORK(KW), LDWORK-KW+1, INFO ) + CALL DLACPY( 'Full', NWR, MW, DWORK(KBW), NW, BW, LDBW ) + CALL DLACPY( 'Full', M, NWR, DWORK(KCW), LDW, CW, LDCW ) + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF +C + IF( RIGHTW .AND. NWR.GT.0 ) THEN +C +C Compute a right-coprime factorization with inner denominator +C of the minimal realization of W. The resulting AW is in +C real Schur form. +C +C Workspace needed: MW*(NW+MW) + +C MAX( 1, NW*(NW+5), MW*(MW+2), 4*MW, 4*M ); +C prefer larger. +C + LDW = MAX( 1, MW ) + KCR = 1 + KDR = KCR + NWR*LDW + KW = KDR + MW*LDW + CALL SB08DD( DICO, NWR, MW, M, AW, LDAW, BW, LDBW, CW, LDCW, + $ DW, LDDW, NNQ, NNR, DWORK(KCR), LDW, DWORK(KDR), + $ LDW, ZERO, DWORK(KW), LDWORK-KW+1, IWARN, IERR ) + IF( IERR.NE.0 ) THEN + INFO = IERR + 5 + RETURN + END IF + NWR = NNQ + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + IF( IWARN.GT.0 ) + $ IWARN = 10 + IWARN + END IF +C + NU1 = NU + 1 +C +C Allocate working storage. +C + KT = 1 + KTI = KT + NN + KW = KTI + NN +C +C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors S and R +C of the controllability and observability Grammians, respectively. +C Real workspace: need 2*N*N + MAX( 1, LLEFT, LRIGHT ), +C where +C LLEFT = (N+NV)*(N+NV+MAX(N+NV,PV)+5) +C if WEIGHT = 'L' or 'B' and PV > 0; +C LLEFT = N*(P+5) if WEIGHT = 'R' or 'N' or PV = 0; +C LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5) +C if WEIGHT = 'R' or 'B' and MW > 0; +C LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or MW = 0. +C prefer larger. +C + CALL AB09IY( DICO, JOBC, JOBO, WEIGHT, NS, M, P, NVR, PV, NWR, + $ MW, ALPHAC, ALPHAO, A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, AV, LDAV, BV, LDBV, CV, LDCV, + $ DV, LDDV, AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, + $ SCALEC, SCALEO, DWORK(KTI), N, DWORK(KT), N, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 9 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Compute a BTA or SPA of the stable part. +C Real workspace: need 2*N*N + MAX( 1, 2*N*N+5*N, N*MAX(M,P) ). +C + CALL AB09IX( DICO, JOB, 'Schur', ORDSEL, NS, M, P, NRA, + $ SCALEC, SCALEO, A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, DWORK(KTI), N, DWORK(KT), N, + $ NMR, HSV, TOL1, TOL2, IWORK, DWORK(KW), LDWORK-KW+1, + $ IWARN, IERR ) + IWARN = MAX( IWARN, IWARNL ) + IF( IERR.NE.0 ) THEN + INFO = 10 + RETURN + END IF + NR = NRA + NU +C + DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + IWORK(1) = NMR + IWORK(2) = NVR + IWORK(3) = NWR +C + RETURN +C *** Last line of AB09ID *** + END diff --git a/mex/sources/libslicot/AB09IX.f b/mex/sources/libslicot/AB09IX.f new file mode 100644 index 000000000..f3ad3b395 --- /dev/null +++ b/mex/sources/libslicot/AB09IX.f @@ -0,0 +1,695 @@ + SUBROUTINE AB09IX( DICO, JOB, FACT, ORDSEL, N, M, P, NR, + $ SCALEC, SCALEO, A, LDA, B, LDB, C, LDC, D, LDD, + $ TI, LDTI, T, LDT, NMINR, HSV, TOL1, TOL2, + $ IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C state-space representation (A,B,C,D) by using the square-root or +C balancing-free square-root Balance & Truncate (B&T) or +C Singular Perturbation Approximation (SPA) model reduction methods. +C The computation of truncation matrices TI and T is based on +C the Cholesky factor S of a controllability Grammian P = S*S' +C and the Cholesky factor R of an observability Grammian Q = R'*R, +C where S and R are given upper triangular matrices. +C +C For the B&T approach, the matrices of the reduced order system +C are computed using the truncation formulas: +C +C Ar = TI * A * T , Br = TI * B , Cr = C * T . (1) +C +C For the SPA approach, the matrices of a minimal realization +C (Am,Bm,Cm) are computed using the truncation formulas: +C +C Am = TI * A * T , Bm = TI * B , Cm = C * T . (2) +C +C Am, Bm, Cm and D serve further for computing the SPA of the given +C system. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root B&T method; +C = 'F': use the balancing-free square-root B&T method; +C = 'S': use the square-root SPA method; +C = 'P': use the balancing-free square-root SPA method. +C +C FACT CHARACTER*1 +C Specifies whether or not, on entry, the matrix A is in a +C real Schur form, as follows: +C = 'S': A is in a real Schur form; +C = 'N': A is a general dense square matrix. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e., the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(NR,NMINR), where NR +C is the desired order on entry and NMINR is the number of +C the Hankel singular values greater than N*EPS*S1, where +C EPS is the machine precision (see LAPACK Library Routine +C DLAMCH) and S1 is the largest Hankel singular value +C (computed in HSV(1)); +C NR can be further reduced to ensure HSV(NR) > HSV(NR+1); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL1,N*EPS*S1). +C +C SCALEC (input) DOUBLE PRECISION +C Scaling factor for the Cholesky factor S of the +C controllability Grammian, i.e., S/SCALEC is used to +C compute the Hankel singular values. SCALEC > 0. +C +C SCALEO (input) DOUBLE PRECISION +C Scaling factor for the Cholesky factor R of the +C observability Grammian, i.e., R/SCALEO is used to +C compute the Hankel singular values. SCALEO > 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. If FACT = 'S', +C A is in a real Schur form. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, if JOB = 'S' or JOB = 'P', the leading P-by-M +C part of this array must contain the original input/output +C matrix D. +C On exit, if INFO = 0 and JOB = 'S' or JOB = 'P', the +C leading P-by-M part of this array contains the +C input/output matrix Dr of the reduced order system. +C If JOB = 'B' or JOB = 'F', this array is not referenced. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= 1, if JOB = 'B' or JOB = 'F'; +C LDD >= MAX(1,P), if JOB = 'S' or JOB = 'P'. +C +C TI (input/output) DOUBLE PRECISION array, dimension (LDTI,N) +C On entry, the leading N-by-N upper triangular part of +C this array must contain the Cholesky factor S of a +C controllability Grammian P = S*S'. +C On exit, if INFO = 0, and NR > 0, the leading NMINR-by-N +C part of this array contains the left truncation matrix +C TI in (1), for the B&T approach, or in (2), for the +C SPA approach. +C +C LDTI INTEGER +C The leading dimension of array TI. LDTI >= MAX(1,N). +C +C T (input/output) DOUBLE PRECISION array, dimension (LDT,N) +C On entry, the leading N-by-N upper triangular part of +C this array must contain the Cholesky factor R of an +C observability Grammian Q = R'*R. +C On exit, if INFO = 0, and NR > 0, the leading N-by-NMINR +C part of this array contains the right truncation matrix +C T in (1), for the B&T approach, or in (2), for the +C SPA approach. +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,N). +C +C NMINR (output) INTEGER +C The number of Hankel singular values greater than +C MAX(TOL2,N*EPS*S1). +C Note: If S and R are the Cholesky factors of the +C controllability and observability Grammians of the +C original system (A,B,C,D), respectively, then NMINR is +C the order of a minimal realization of the original system. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the Hankel singular values, +C ordered decreasingly. The Hankel singular values are +C singular values of the product R*S. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of the reduced system. +C For model reduction, the recommended value lies in the +C interval [0.00001,0.001]. +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = N*EPS*S1, where EPS is the machine precision +C (see LAPACK Library Routine DLAMCH) and S1 is the largest +C Hankel singular value (computed in HSV(1)). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the system. +C The recommended value is TOL2 = N*EPS*S1. +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0, and ORDSEL = 'A', then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension LIWORK, where +C LIWORK = 0, if JOB = 'B'; +C LIWORK = N, if JOB = 'F'; +C LIWORK = 2*N, if JOB = 'S' or 'P'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, 2*N*N + 5*N, N*MAX(M,P) ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than NMINR, the order of a minimal realization of +C the given system; in this case, the resulting NR is +C set automatically to NMINR; +C = 2: with ORDSEL = 'F', the selected order NR corresponds +C to repeated singular values, which are neither all +C included nor all excluded from the reduced model; +C in this case, the resulting NR is set automatically +C to the largest value such that HSV(NR) > HSV(NR+1). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t), (3) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09IX determines for +C the given system (3), the matrices of a reduced NR order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t), (4) +C +C by using the square-root or balancing-free square-root +C Balance & Truncate (B&T) or Singular Perturbation Approximation +C (SPA) model reduction methods. +C +C The projection matrices TI and T are determined using the +C Cholesky factors S and R of a controllability Grammian P and an +C observability Grammian Q. +C The Hankel singular values HSV(1), ...., HSV(N) are computed as +C singular values of the product R*S. +C +C If JOB = 'B', the square-root Balance & Truncate technique +C of [1] is used. +C +C If JOB = 'F', the balancing-free square-root version of the +C Balance & Truncate technique [2] is used. +C +C If JOB = 'S', the square-root version of the Singular Perturbation +C Approximation method [3,4] is used. +C +C If JOB = 'P', the balancing-free square-root version of the +C Singular Perturbation Approximation method [3,4] is used. +C +C REFERENCES +C +C [1] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [2] Varga A. +C Efficient minimal realization procedure based on balancing. +C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, +C A. El Moudni, P. Borne, S. G. Tzafestas (Eds.), +C Vol. 2, pp. 42-46. +C +C [3] Liu Y. and Anderson B.D.O. +C Singular Perturbation Approximation of balanced systems. +C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. +C +C [4] Varga A. +C Balancing-free square-root algorithm for computing singular +C perturbation approximations. +C Proc. 30-th CDC, Brighton, Dec. 11-13, 1991, +C Vol. 2, pp. 1062-1065. +C +C NUMERICAL ASPECTS +C +C The implemented method relies on accuracy enhancing square-root +C or balancing-free square-root methods. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. +C D. Sima, University of Bucharest, August 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, +C Sep. 2001. +C +C KEYWORDS +C +C Balance and truncate, minimal state-space representation, +C model reduction, multivariable system, +C singular perturbation approximation, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, FACT, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDT, LDTI, + $ LDWORK, M, N, NMINR, NR, P + DOUBLE PRECISION SCALEC, SCALEO, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*), T(LDT,*), TI(LDTI,*) +C .. Local Scalars .. + LOGICAL BAL, BTA, DISCR, FIXORD, RSF, SPA + INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, LW, + $ NRED, NR1, NS, WRKOPT + DOUBLE PRECISION ATOL, RCOND, SKP, TEMP, TOLDEF +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB09DD, DGEMM, DGEMV, DGEQRF, DGETRF, DGETRS, + $ DLACPY, DORGQR, DSCAL, DTRMM, DTRMV, MA02AD, + $ MB03UD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) + SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) + BAL = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'S' ) + RSF = LSAME( FACT, 'S' ) + FIXORD = LSAME( ORDSEL, 'F' ) +C + LW = MAX( 1, 2*N*N + 5*N, N*MAX( M, P ) ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( RSF .OR. LSAME( FACT, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -8 + ELSE IF( SCALEC.LE.ZERO ) THEN + INFO = -9 + ELSE IF( SCALEO.LE.ZERO ) THEN + INFO = -10 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( LDD.LT.1 .OR. ( SPA .AND. LDD.LT.P ) ) THEN + INFO = -18 + ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN + INFO = -20 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -22 + ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN + INFO = -26 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -29 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09IX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + NMINR = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Save S in DWORK(KV). +C + KV = 1 + KU = KV + N*N + KW = KU + N*N + CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) +C | x x | +C Compute R*S in the form | 0 x | in TI. +C + DO 10 J = 1, N + CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, + $ TI(1,J), 1 ) + 10 CONTINUE +C +C Compute the singular value decomposition R*S = V*Sigma*UT of the +C upper triangular matrix R*S, with UT in TI and V in DWORK(KU). +C +C Workspace: need 2*N*N + 5*N; +C prefer larger. +C + CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + ENDIF + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Scale the singular values. +C + CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) +C +C Partition Sigma, U and V conformally as: +C +C Sigma = diag(Sigma1,Sigma2,Sigma3), U = [U1,U2,U3] (U' in TI) and +C V = [V1,V2,V3] (in DWORK(KU)). +C +C Compute NMINR, the order of a minimal realization, as the order +C of [Sigma1 Sigma2]. +C + TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) + ATOL = MAX( TOL2, TOLDEF*HSV(1) ) + NMINR = N + 20 IF( NMINR.GT.0 ) THEN + IF( HSV(NMINR).LE.ATOL ) THEN + NMINR = NMINR - 1 + GO TO 20 + END IF + END IF +C +C Compute the order NR of reduced system, as the order of Sigma1. +C + IF( FIXORD ) THEN +C +C Check if the desired order is less than the order of a minimal +C realization. +C + IF( NR.GT.NMINR ) THEN +C +C Reduce the order to NMINR. +C + NR = NMINR + IWARN = 1 + END IF +C +C Check for singular value multiplicity at cut-off point. +C + IF( NR.GT.0 .AND. NR.LT.NMINR ) THEN + SKP = HSV(NR) + IF( SKP-HSV(NR+1).LE.TOLDEF*SKP ) THEN + IWARN = 2 +C +C Reduce the order such that HSV(NR) > HSV(NR+1). +C + 30 NR = NR - 1 + IF( NR.GT.0 ) THEN + IF( HSV(NR)-SKP.LE.TOLDEF*SKP ) GO TO 30 + END IF + END IF + END IF + ELSE +C +C The order is given as the number of singular values +C exceeding MAX( TOL1, N*EPS*HSV(1) ). +C + ATOL = MAX( TOL1, ATOL ) + NR = 0 + DO 40 J = 1, NMINR + IF( HSV(J).LE.ATOL ) GO TO 50 + NR = NR + 1 + 40 CONTINUE + 50 CONTINUE + ENDIF +C +C Finish if the order is zero. +C + IF( NR.EQ.0 ) THEN + IF( SPA ) + $ CALL AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC, + $ D, LDD, RCOND, IWORK, DWORK, IERR ) + DWORK(1) = WRKOPT + RETURN + END IF +C +C Compute NS, the order of Sigma2. For BTA, NS = 0. +C + IF( SPA ) THEN + NRED = NMINR + ELSE + NRED = NR + END IF + NS = NRED - NR +C +C Compute the truncation matrices. +C +C Compute TI' = | TI1' TI2' | = R'*| V1 V2 | in DWORK(KU). +C + CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NRED, + $ ONE, T, LDT, DWORK(KU), N ) +C +C Compute T = | T1 T2 | = S*| U1 U2 | . +C + CALL MA02AD( 'Full', NRED, N, TI, LDTI, T, LDT ) + CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, + $ NRED, ONE, DWORK(KV), N, T, LDT ) +C + KTAU = KW + IF( BAL ) THEN + IJ = KU +C +C Square-Root B&T/SPA method. +C +C Compute the truncation matrices for balancing +C -1/2 -1/2 +C T1*Sigma1 and TI1'*Sigma1 . +C + DO 60 J = 1, NR + TEMP = ONE/SQRT( HSV(J) ) + CALL DSCAL( N, TEMP, T(1,J), 1 ) + CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) + IJ = IJ + N + 60 CONTINUE +C + ELSE +C +C Balancing-Free B&T/SPA method. +C +C Compute orthogonal bases for the images of matrices T1 and +C TI1'. +C +C Workspace: need 2*N*N + 2*N; +C prefer larger. +C + KW = KTAU + NR + LDW = LDWORK - KW + 1 + CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) + CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + ENDIF +C + IF( NS.GT.0 ) THEN +C +C Compute orthogonal bases for the images of matrices T2 and +C TI2'. +C +C Workspace: need 2*N*N + 2*N; +C prefer larger. +C + NR1 = NR + 1 + KW = KTAU + NS + LDW = LDWORK - KW + 1 + CALL DGEQRF( N, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + CALL DORGQR( N, NS, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + CALL DGEQRF( N, NS, DWORK(KU+N*NR), N, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL DORGQR( N, NS, NS, DWORK(KU+N*NR), N, DWORK(KTAU), + $ DWORK(KW), LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + ENDIF +C +C Transpose TI' in TI. +C + CALL MA02AD( 'Full', N, NRED, DWORK(KU), N, TI, LDTI ) +C + IF( .NOT.BAL ) THEN +C -1 +C Compute (TI1*T1) *TI1 in TI. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, + $ LDTI, T, LDT, ZERO, DWORK(KU), N ) + CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) + CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, + $ LDTI, IERR ) +C + IF( NS.GT.0 ) THEN +C -1 +C Compute (TI2*T2) *TI2 in TI2. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NS, NS, N, ONE, + $ TI(NR1,1), LDTI, T(1,NR1), LDT, ZERO, DWORK(KU), + $ N ) + CALL DGETRF( NS, NS, DWORK(KU), N, IWORK, IERR ) + CALL DGETRS( 'NoTranspose', NS, N, DWORK(KU), N, IWORK, + $ TI(NR1,1), LDTI, IERR ) + END IF + END IF +C +C Compute TI*A*T. Exploit RSF of A if possible. +C Workspace: need N*N. +C + IF( RSF ) THEN + IJ = 1 + DO 80 J = 1, N + K = MIN( J+1, N ) + CALL DGEMV( 'NoTranspose', NRED, K, ONE, TI, LDTI, + $ A(1,J), 1, ZERO, DWORK(IJ), 1 ) + IJ = IJ + N + 80 CONTINUE + ELSE + CALL DGEMM( 'NoTranspose', 'NoTranspose', NRED, N, N, ONE, + $ TI, LDTI, A, LDA, ZERO, DWORK, N ) + END IF + CALL DGEMM( 'NoTranspose', 'NoTranspose', NRED, NRED, N, ONE, + $ DWORK, N, T, LDT, ZERO, A, LDA ) +C +C Compute TI*B and C*T. +C Workspace: need N*MAX(M,P). +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', NRED, M, N, ONE, TI, + $ LDTI, DWORK, N, ZERO, B, LDB ) +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NRED, N, ONE, + $ DWORK, P, T, LDT, ZERO, C, LDC ) +C +C Compute the singular perturbation approximation if possible. +C Note that IERR = 1 on exit from AB09DD cannot appear here. +C +C Workspace: need real 4*(NMINR-NR); +C need integer 2*(NMINR-NR). +C + IF( SPA) THEN + CALL AB09DD( DICO, NRED, M, P, NR, A, LDA, B, LDB, + $ C, LDC, D, LDD, RCOND, IWORK, DWORK, IERR ) + ELSE + NMINR = NR + END IF + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB09IX *** + END diff --git a/mex/sources/libslicot/AB09IY.f b/mex/sources/libslicot/AB09IY.f new file mode 100644 index 000000000..475505219 --- /dev/null +++ b/mex/sources/libslicot/AB09IY.f @@ -0,0 +1,859 @@ + SUBROUTINE AB09IY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NV, PV, + $ NW, MW, ALPHAC, ALPHAO, A, LDA, B, LDB, C, LDC, + $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, + $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, + $ SCALEC, SCALEO, S, LDS, R, LDR, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute for given state-space representations +C (A,B,C,0), (AV,BV,CV,DV), and (AW,BW,CW,DW) of the +C transfer-function matrices G, V and W, respectively, +C the Cholesky factors of the frequency-weighted +C controllability and observability Grammians corresponding +C to a frequency-weighted model reduction problem. +C G, V and W must be stable transfer-function matrices with +C the state matrices A, AV, and AW in real Schur form. +C It is assumed that the state space realizations (AV,BV,CV,DV) +C and (AW,BW,CW,DW) are minimal. In case of possible pole-zero +C cancellations in forming V*G and/or G*W, the parameters for the +C choice of frequency-weighted Grammians ALPHAO and/or ALPHAC, +C respectively, must be different from 1. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the systems as follows: +C = 'C': G, V and W are continuous-time systems; +C = 'D': G, V and W are discrete-time systems. +C +C JOBC CHARACTER*1 +C Specifies the choice of frequency-weighted controllability +C Grammian as follows: +C = 'S': choice corresponding to a combination method [4] +C of the approaches of Enns [1] and Lin-Chiu [2,3]; +C = 'E': choice corresponding to the stability enhanced +C modified combination method of [4]. +C +C JOBO CHARACTER*1 +C Specifies the choice of frequency-weighted observability +C Grammian as follows: +C = 'S': choice corresponding to a combination method [4] +C of the approaches of Enns [1] and Lin-Chiu [2,3]; +C = 'E': choice corresponding to the stability enhanced +C modified combination method of [4]. +C +C WEIGHT CHARACTER*1 +C Specifies the type of frequency weighting, as follows: +C = 'N': no weightings are used (V = I, W = I); +C = 'L': only left weighting V is used (W = I); +C = 'R': only right weighting W is used (V = I); +C = 'B': both left and right weightings V and W are used. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation of G, i.e., +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrix B and +C the number of rows of the matrices CW and DW. M >= 0. +C M represents the dimension of the input vector of the +C system with the transfer-function matrix G and +C also the dimension of the output vector of the system +C with the transfer-function matrix W. +C +C P (input) INTEGER +C The number of rows of the matrix C and the +C number of columns of the matrices BV and DV. P >= 0. +C P represents the dimension of the output vector of the +C system with the transfer-function matrix G and +C also the dimension of the input vector of the system +C with the transfer-function matrix V. +C +C NV (input) INTEGER +C The order of the matrix AV. Also the number of rows of +C the matrix BV and the number of columns of the matrix CV. +C NV represents the dimension of the state vector of the +C system with the transfer-function matrix V. NV >= 0. +C +C PV (input) INTEGER +C The number of rows of the matrices CV and DV. PV >= 0. +C PV represents the dimension of the output vector of the +C system with the transfer-function matrix V. +C +C NW (input) INTEGER +C The order of the matrix AW. Also the number of rows of +C the matrix BW and the number of columns of the matrix CW. +C NW represents the dimension of the state vector of the +C system with the transfer-function matrix W. NW >= 0. +C +C MW (input) INTEGER +C The number of columns of the matrices BW and DW. MW >= 0. +C MW represents the dimension of the input vector of the +C system with the transfer-function matrix W. +C +C ALPHAC (input) DOUBLE PRECISION +C Combination method parameter for defining the +C frequency-weighted controllability Grammian (see METHOD); +C ABS(ALPHAC) <= 1. +C +C ALPHAO (input) DOUBLE PRECISION +C Combination method parameter for defining the +C frequency-weighted observability Grammian (see METHOD); +C ABS(ALPHAO) <= 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must +C contain the state matrix A (of the system with the +C transfer-function matrix G) in a real Schur form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C AV (input) DOUBLE PRECISION array, dimension (LDAV,NV) +C If WEIGHT = 'L' or 'B', the leading NV-by-NV part of this +C array must contain the state matrix AV (of the system with +C the transfer-function matrix V) in a real Schur form. +C AV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDAV INTEGER +C The leading dimension of array AV. +C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; +C LDAV >= 1, if WEIGHT = 'R' or 'N'. +C +C BV (input) DOUBLE PRECISION array, dimension (LDBV,P) +C If WEIGHT = 'L' or 'B', the leading NV-by-P part of this +C array must contain the input matrix BV of the system with +C the transfer-function matrix V. +C BV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDBV INTEGER +C The leading dimension of array BV. +C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; +C LDBV >= 1, if WEIGHT = 'R' or 'N'. +C +C CV (input) DOUBLE PRECISION array, dimension (LDCV,NV) +C If WEIGHT = 'L' or 'B', the leading PV-by-NV part of this +C array must contain the output matrix CV of the system with +C the transfer-function matrix V. +C CV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDCV INTEGER +C The leading dimension of array CV. +C LDCV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; +C LDCV >= 1, if WEIGHT = 'R' or 'N'. +C +C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) +C If WEIGHT = 'L' or 'B', the leading PV-by-P part of this +C array must contain the feedthrough matrix DV of the system +C with the transfer-function matrix V. +C DV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDDV INTEGER +C The leading dimension of array DV. +C LDDV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; +C LDDV >= 1, if WEIGHT = 'R' or 'N'. +C +C AW (input) DOUBLE PRECISION array, dimension (LDAW,NW) +C If WEIGHT = 'R' or 'B', the leading NW-by-NW part of this +C array must contain the state matrix AW (of the system with +C the transfer-function matrix W) in a real Schur form. +C AW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDAW INTEGER +C The leading dimension of array AW. +C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; +C LDAW >= 1, if WEIGHT = 'L' or 'N'. +C +C BW (input) DOUBLE PRECISION array, dimension (LDBW,MW) +C If WEIGHT = 'R' or 'B', the leading NW-by-MW part of this +C array must contain the input matrix BW of the system with +C the transfer-function matrix W. +C BW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDBW INTEGER +C The leading dimension of array BW. +C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; +C LDBW >= 1, if WEIGHT = 'L' or 'N'. +C +C CW (input) DOUBLE PRECISION array, dimension (LDCW,NW) +C If WEIGHT = 'R' or 'B', the leading M-by-NW part of this +C array must contain the output matrix CW of the system with +C the transfer-function matrix W. +C CW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDCW INTEGER +C The leading dimension of array CW. +C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; +C LDCW >= 1, if WEIGHT = 'L' or 'N'. +C +C DW (input) DOUBLE PRECISION array, dimension (LDDW,MW) +C If WEIGHT = 'R' or 'B', the leading M-by-MW part of this +C array must contain the feedthrough matrix DW of the system +C with the transfer-function matrix W. +C DW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDDW INTEGER +C The leading dimension of array DW. +C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; +C LDDW >= 1, if WEIGHT = 'L' or 'N'. +C +C SCALEC (output) DOUBLE PRECISION +C Scaling factor for the controllability Grammian in (1) +C or (3). See METHOD. +C +C SCALEO (output) DOUBLE PRECISION +C Scaling factor for the observability Grammian in (2) +C or (4). See METHOD. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,N) +C The leading N-by-N upper triangular part of this array +C contains the Cholesky factor S of the frequency-weighted +C cotrollability Grammian P = S*S'. See METHOD. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,N). +C +C R (output) DOUBLE PRECISION array, dimension (LDR,N) +C The leading N-by-N upper triangular part of this array +C contains the Cholesky factor R of the frequency-weighted +C observability Grammian Q = R'*R. See METHOD. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, LLEFT, LRIGHT ), +C where +C LLEFT = (N+NV)*(N+NV+MAX(N+NV,PV)+5) +C if WEIGHT = 'L' or 'B' and PV > 0; +C LLEFT = N*(P+5) if WEIGHT = 'R' or 'N' or PV = 0; +C LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5) +C if WEIGHT = 'R' or 'B' and MW > 0; +C LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or MW = 0. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the state matrices A and/or AV are not stable or +C not in a real Schur form; +C = 2: if the state matrices A and/or AW are not stable or +C not in a real Schur form; +C = 3: eigenvalues computation failure. +C +C METHOD +C +C Let Pi = Si*Si' and Qo = Ro'*Ro be the Cholesky factored +C controllability and observability Grammians satisfying +C in the continuous-time case +C +C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0, (1) +C +C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0, (2) +C +C and in the discrete-time case +C +C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0, (3) +C +C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0, (4) +C +C where +C +C Ai = ( A B*Cw ) , Bi = ( B*Dw ) , +C ( 0 Aw ) ( Bw ) +C +C Ao = ( A 0 ) , Co = ( Dv*C Cv ) . +C ( Bv*C Av ) +C +C Consider the partitioned Grammians +C +C Pi = ( P11 P12 ) and Qo = ( Q11 Q12 ) , +C ( P12' P22 ) ( Q12' Q22 ) +C +C where P11 and Q11 are the leading N-by-N parts of Pi and Qo, +C respectively, and let P0 and Q0 be non-negative definite matrices +C defined in the combination method [4] +C -1 +C P0 = P11 - ALPHAC**2*P12*P22 *P21 , +C -1 +C Q0 = Q11 - ALPHAO**2*Q12*Q22 *Q21. +C +C The frequency-weighted controllability and observability +C Grammians, P and Q, respectively, are defined as follows: +C P = P0 if JOBC = 'S' (standard combination method [4]); +C P = P1 >= P0 if JOBC = 'E', where P1 is the controllability +C Grammian defined to enforce stability for a modified combination +C method of [4]; +C Q = Q0 if JOBO = 'S' (standard combination method [4]); +C Q = Q1 >= Q0 if JOBO = 'E', where Q1 is the observability +C Grammian defined to enforce stability for a modified combination +C method of [4]. +C +C If JOBC = JOBO = 'S' and ALPHAC = ALPHAO = 0, the choice of +C Grammians corresponds to the method of Enns [1], while if +C ALPHAC = ALPHAO = 1, the choice of Grammians corresponds to the +C method of Lin and Chiu [2,3]. +C +C The routine computes directly the Cholesky factors S and R +C such that P = S*S' and Q = R'*R according to formulas +C developed in [4]. No matrix inversions are involved. +C +C REFERENCES +C +C [1] Enns, D. +C Model reduction with balanced realizations: An error bound +C and a frequency weighted generalization. +C Proc. CDC, Las Vegas, pp. 127-132, 1984. +C +C [2] Lin, C.-A. and Chiu, T.-Y. +C Model reduction via frequency-weighted balanced realization. +C Control Theory and Advanced Technology, vol. 8, +C pp. 341-351, 1992. +C +C [3] Sreeram, V., Anderson, B.D.O and Madievski, A.G. +C New results on frequency weighted balanced reduction +C technique. +C Proc. ACC, Seattle, Washington, pp. 4004-4009, 1995. +C +C [4] Varga, A. and Anderson, B.D.O. +C Square-root balancing-free methods for the frequency-weighted +C balancing related model reduction. +C (report in preparation) +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. +C D. Sima, University of Bucharest, August 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. +C +C REVISIONS +C +C A. Varga, Australian National University, Canberra, November 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000. +C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2001. +C +C KEYWORDS +C +C Frequency weighting, model reduction, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBC, JOBO, WEIGHT + INTEGER INFO, LDA, LDAV, LDAW, LDB, LDBV, LDBW, + $ LDC, LDCV, LDCW, LDDV, LDDW, LDR, LDS, LDWORK, + $ M, MW, N, NV, NW, P, PV + DOUBLE PRECISION ALPHAC, ALPHAO, SCALEC, SCALEO +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), + $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), + $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), + $ DV(LDDV,*), DW(LDDW,*), + $ DWORK(*), R(LDR,*), S(LDS,*) +C .. Local Scalars .. + LOGICAL DISCR, FRWGHT, LEFTW, RIGHTW + INTEGER I, IERR, J, KAW, KTAU, KU, KW, LDU, LW, MBBAR, + $ NNV, NNW, PCBAR + DOUBLE PRECISION T, TOL, WORK +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLACPY, DLASET, DSCAL, DSYEV, + $ MB01WD, MB04ND, MB04OD, SB03OU, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) + RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) + FRWGHT = LEFTW .OR. RIGHTW +C + INFO = 0 + LW = 1 + NNV = N + NV + NNW = N + NW + IF( LEFTW .AND. PV.GT.0 ) THEN + LW = MAX( LW, NNV*( NNV + MAX( NNV, PV ) + 5 ) ) + ELSE + LW = MAX( LW, N*( P + 5 ) ) + END IF + IF( RIGHTW .AND. MW.GT.0 ) THEN + LW = MAX( LW, NNW*( NNW + MAX( NNW, MW ) + 5 ) ) + ELSE + LW = MAX( LW, N*( M + 5 ) ) + END IF +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) + $ THEN + INFO = -2 + ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) + $ THEN + INFO = -3 + ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( NV.LT.0 ) THEN + INFO = -8 + ELSE IF( PV.LT.0 ) THEN + INFO = -9 + ELSE IF( NW.LT.0 ) THEN + INFO = -10 + ELSE IF( MW.LT.0 ) THEN + INFO = -11 + ELSE IF( ABS( ALPHAC ).GT.ONE ) THEN + INFO = -12 + ELSE IF( ABS( ALPHAO ).GT.ONE ) THEN + INFO = -13 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -19 + ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN + INFO = -21 + ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN + INFO = -23 + ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.PV ) ) THEN + INFO = -25 + ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.PV ) ) THEN + INFO = -27 + ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN + INFO = -29 + ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN + INFO = -31 + ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN + INFO = -33 + ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN + INFO = -35 + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN + INFO = -39 + ELSE IF( LDR.LT.MAX( 1, N ) ) THEN + INFO = -41 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -43 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09IY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + SCALEC = ONE + SCALEO = ONE + IF( MIN( N, M, P ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + WORK = 1 + IF( LEFTW .AND. PV.GT.0 ) THEN +C +C Build the extended permuted matrices +C +C Ao = ( Av Bv*C ) , Co = ( Cv Dv*C ) . +C ( 0 A ) +C + KAW = 1 + KU = KAW + NNV*NNV + LDU = MAX( NNV, PV ) + CALL DLACPY( 'Full', NV, NV, AV, LDAV, DWORK(KAW), NNV ) + CALL DLASET( 'Full', N, NV, ZERO, ZERO, DWORK(KAW+NV), NNV ) + CALL DGEMM( 'No-transpose', 'No-transpose', NV, N, P, ONE, + $ BV, LDBV, C, LDC, ZERO, DWORK(KAW+NNV*NV), NNV ) + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW+NNV*NV+NV), NNV ) +C + CALL DLACPY( 'Full', PV, NV, CV, LDCV, DWORK(KU), LDU ) + CALL DGEMM( 'No-transpose', 'No-transpose', PV, N, P, ONE, + $ DV, LDDV, C, LDC, ZERO, DWORK(KU+LDU*NV), LDU ) +C +C Solve for the Cholesky factor Ro of Qo, Qo = Ro'*Ro, +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0. +C +C Workspace: need (N+NV)*(N+NV+MAX(N+NV,PV)+5); +C prefer larger. +C + KTAU = KU + LDU*NNV + KW = KTAU + NNV +C + CALL SB03OU( DISCR, .FALSE., NNV, PV, DWORK(KAW), NNV, + $ DWORK(KU), LDU, DWORK(KTAU), DWORK(KU), LDU, + $ SCALEO, DWORK(KW), LDWORK-KW+1, IERR ) +C + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C +C Partition Ro as Ro = ( R11 R12 ) and compute R such that +C ( 0 R22 ) +C +C R'*R = R22'*R22 + (1-ALPHAO**2)*R12'*R12. +C + KW = KU + LDU*NV + NV + CALL DLACPY( 'Upper', N, N, DWORK(KW), LDU, R, LDR ) + IF( ALPHAO.NE.ZERO ) THEN + T = SQRT( ONE - ALPHAO*ALPHAO ) + DO 10 J = KU + LDU*NV, KU + LDU*(NNV-1), LDU + CALL DSCAL( NV, T, DWORK(J), 1 ) + 10 CONTINUE + END IF + IF( ALPHAO.LT.ONE .AND. NV.GT.0 ) THEN + KTAU = 1 + CALL MB04OD( 'Full', N, 0, NV, R, LDR, DWORK(KU+LDU*NV), + $ LDU, DUM, 1, DUM, 1, DWORK(KTAU), DWORK(KW) ) +C + DO 30 J = 1, N + DWORK(J) = R(J,J) + DO 20 I = 1, J + IF ( DWORK(I).LT.ZERO ) R(I,J) = -R(I,J) + 20 CONTINUE + 30 CONTINUE +C + END IF +C + IF( LSAME( JOBO, 'E' ) .AND. ALPHAO.LT.ONE ) THEN +C +C Form Y = -A'*(R'*R)-(R'*R)*A if DICO = 'C', or +C Y = -A'*(R'*R)*A+(R'*R) if DICO = 'D'. +C + CALL DLACPY( 'Upper', N, N, R, LDR, DWORK(KU), N ) + CALL MB01WD( DICO, 'Upper', 'No-transpose', 'Hessenberg', N, + $ -ONE, ZERO, R, LDR, DWORK(KAW+NNV*NV+NV), NNV, + $ DWORK(KU), N, IERR ) +C +C Compute the eigendecomposition of Y as Y = Z*Sigma*Z'. +C + KU = N + 1 + CALL DSYEV( 'Vectors', 'Upper', N, R, LDR, DWORK, DWORK(KU), + $ LDWORK-N, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 3 + RETURN + END IF + WORK = MAX( WORK, DWORK(KU) + DBLE( N ) ) +C +C Partition Sigma = (Sigma1,Sigma2), such that +C Sigma1 <= 0, Sigma2 > 0. +C Partition correspondingly Z = [Z1 Z2]. +C + TOL = MAX( ABS( DWORK(1) ), ABS( DWORK(N) ) ) + $ * DLAMCH( 'Epsilon') +C _ +C Form C = [ sqrt(Sigma2)*Z2' ] +C + PCBAR = 0 + DO 40 J = 1, N + IF( DWORK(J).GT.TOL ) THEN + CALL DSCAL( N, SQRT( DWORK(J) ), R(1,J), 1 ) + CALL DCOPY( N, R(1,J), 1, DWORK(KU+PCBAR), N ) + PCBAR = PCBAR + 1 + END IF + 40 CONTINUE +C +C Solve for the Cholesky factor R of Q, Q = R'*R, +C the continuous-time Lyapunov equation (if DICO = 'C') +C _ _ +C A'*Q + Q*A + t^2*C'*C = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C _ _ +C A'*Q*A - Q + t^2*C'*C = 0. +C +C Workspace: need N*(N + 6); +C prefer larger. +C + KTAU = KU + N*N + KW = KTAU + N +C + CALL SB03OU( DISCR, .FALSE., N, PCBAR, A, LDA, DWORK(KU), N, + $ DWORK(KTAU), R, LDR, T, DWORK(KW), LDWORK-KW+1, + $ IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + SCALEO = SCALEO*T + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) + END IF +C + ELSE +C +C Solve for the Cholesky factor R of Q, Q = R'*R, +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C A'*Q + Q*A + scaleo^2*C'*C = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C A'*Q*A - Q + scaleo^2*C'*C = 0. +C +C Workspace: need N*(P + 5); +C prefer larger. +C + KU = 1 + KTAU = KU + P*N + KW = KTAU + N +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) + CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), P, + $ DWORK(KTAU), R, LDR, SCALEO, DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) + END IF +C + IF( RIGHTW .AND. MW.GT.0 ) THEN +C +C Build the extended matrices +C +C Ai = ( A B*Cw ) , Bi = ( B*Dw ) . +C ( 0 Aw ) ( Bw ) +C + KAW = 1 + KU = KAW + NNW*NNW + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), NNW ) + CALL DLASET( 'Full', NW, N, ZERO, ZERO, DWORK(KAW+N), NNW ) + CALL DGEMM( 'No-transpose', 'No-transpose', N, NW, M, ONE, + $ B, LDB, CW, LDCW, ZERO, DWORK(KAW+NNW*N), NNW ) + CALL DLACPY( 'Full', NW, NW, AW, LDAW, + $ DWORK(KAW+NNW*N+N), NNW ) +C + CALL DGEMM( 'No-transpose', 'No-transpose', N, MW, M, ONE, + $ B, LDB, DW, LDDW, ZERO, DWORK(KU), NNW ) + CALL DLACPY( 'Full', NW, MW, BW, LDBW, DWORK(KU+N), NNW ) +C +C Solve for the Cholesky factor Si of Pi, Pi = Si*Si', +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0. +C +C Workspace: need (N+NW)*(N+NW+MAX(N+NW,MW)+5); +C prefer larger. +C + KTAU = KU + NNW*MAX( NNW, MW ) + KW = KTAU + NNW +C + CALL SB03OU( DISCR, .TRUE., NNW, MW, DWORK(KAW), NNW, + $ DWORK(KU), NNW, DWORK(KTAU), DWORK(KU), NNW, + $ SCALEC, DWORK(KW), LDWORK-KW+1, IERR ) +C + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C +C Partition Si as Si = ( S11 S12 ) and compute S such that +C ( 0 S22 ) +C +C S*S' = S11*S11' + (1-ALPHAC**2)*S12*S12'. +C + CALL DLACPY( 'Upper', N, N, DWORK(KU), NNW, S, LDS ) + IF( ALPHAC.NE.ZERO ) THEN + T = SQRT( ONE - ALPHAC*ALPHAC ) + DO 50 J = KU + NNW*N, KU + NNW*(NNW-1), NNW + CALL DSCAL( N, T, DWORK(J), 1 ) + 50 CONTINUE + END IF + IF( ALPHAC.LT.ONE .AND. NW.GT.0 ) THEN + KTAU = N*NNW + 1 + KW = KTAU + N + CALL MB04ND( 'Full', N, 0, NW, S, LDS, DWORK(KU+NNW*N), NNW, + $ DUM, 1, DUM, 1, DWORK(KTAU), DWORK(KW) ) +C + DO 70 J = 1, N + IF ( S(J,J).LT.ZERO ) THEN + DO 60 I = 1, J + S(I,J) = -S(I,J) + 60 CONTINUE + END IF + 70 CONTINUE + END IF +C + IF( LSAME( JOBC, 'E' ) .AND. ALPHAC.LT.ONE ) THEN +C +C Form X = -A*(S*S')-(S*S')*A' if DICO = 'C', or +C X = -A*(S*S')*A'+(S*S') if DICO = 'D'. +C + CALL DLACPY( 'Upper', N, N, S, LDS, DWORK(KU), N ) + CALL MB01WD( DICO, 'Upper', 'Transpose', 'Hessenberg', N, + $ -ONE, ZERO, S, LDS, DWORK(KAW), NNW, DWORK(KU), + $ N, IERR ) +C +C Compute the eigendecomposition of X as X = Z*Sigma*Z'. +C + KU = N + 1 + CALL DSYEV( 'Vectors', 'Upper', N, S, LDS, DWORK, DWORK(KU), + $ LDWORK-N, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 3 + RETURN + END IF + WORK = MAX( WORK, DWORK(KU) + DBLE( N ) ) +C +C Partition Sigma = (Sigma1,Sigma2), such that +C Sigma1 =< 0, Sigma2 > 0. +C Partition correspondingly Z = [Z1 Z2]. +C + TOL = MAX( ABS( DWORK(1) ), ABS( DWORK(N) ) ) + $ * DLAMCH( 'Epsilon') +C _ +C Form B = [ Z2*sqrt(Sigma2) ] +C + MBBAR = 0 + I = KU + DO 80 J = 1, N + IF( DWORK(J).GT.TOL ) THEN + MBBAR = MBBAR + 1 + CALL DSCAL( N, SQRT( DWORK(J) ), S(1,J), 1 ) + CALL DCOPY( N, S(1,J), 1, DWORK(I), 1 ) + I = I + N + END IF + 80 CONTINUE +C +C Solve for the Cholesky factor S of P, P = S*S', +C the continuous-time Lyapunov equation (if DICO = 'C') +C _ _ +C A*P + P*A' + t^2*B*B' = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C _ _ +C A*P*A' - P + t^2*B*B' = 0. +C +C Workspace: need maximum N*(N + 6); +C prefer larger. +C + KTAU = KU + MBBAR*N + KW = KTAU + N +C + CALL SB03OU( DISCR, .TRUE., N, MBBAR, A, LDA, DWORK(KU), N, + $ DWORK(KTAU), S, LDS, T, DWORK(KW), LDWORK-KW+1, + $ IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + SCALEC = SCALEC*T + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) + END IF +C + ELSE +C +C Solve for the Cholesky factor S of P, P = S*S', +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C A*P + P*A' + scalec^2*B*B' = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C A*P*A' - P + scalec^2*B*B' = 0. +C +C Workspace: need N*(M+5); +C prefer larger. +C + KU = 1 + KTAU = KU + N*M + KW = KTAU + N +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) + CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KU), N, + $ DWORK(KTAU), S, LDS, SCALEC, DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) + END IF +C +C Save optimal workspace. +C + DWORK(1) = WORK +C + RETURN +C *** Last line of AB09IY *** + END diff --git a/mex/sources/libslicot/AB09JD.f b/mex/sources/libslicot/AB09JD.f new file mode 100644 index 000000000..8729aa4e8 --- /dev/null +++ b/mex/sources/libslicot/AB09JD.f @@ -0,0 +1,1482 @@ + SUBROUTINE AB09JD( JOBV, JOBW, JOBINV, DICO, EQUIL, ORDSEL, + $ N, NV, NW, M, P, NR, ALPHA, A, LDA, B, LDB, + $ C, LDC, D, LDD, AV, LDAV, BV, LDBV, + $ CV, LDCV, DV, LDDV, AW, LDAW, BW, LDBW, + $ CW, LDCW, DW, LDDW, NS, HSV, TOL1, TOL2, + $ IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C state-space representation (A,B,C,D) by using the frequency +C weighted optimal Hankel-norm approximation method. +C The Hankel norm of the weighted error +C +C op(V)*(G-Gr)*op(W) +C +C is minimized, where G and Gr are the transfer-function matrices +C of the original and reduced systems, respectively, V and W are +C invertible transfer-function matrices representing the left and +C right frequency weights, and op(X) denotes X, inv(X), conj(X) or +C conj(inv(X)). V and W are specified by their state space +C realizations (AV,BV,CV,DV) and (AW,BW,CW,DW), respectively. +C When minimizing ||V*(G-Gr)*W||, V and W must be antistable. +C When minimizing inv(V)*(G-Gr)*inv(W), V and W must have only +C antistable zeros. +C When minimizing conj(V)*(G-Gr)*conj(W), V and W must be stable. +C When minimizing conj(inv(V))*(G-Gr)*conj(inv(W)), V and W must +C be minimum-phase. +C If the original system is unstable, then the frequency weighted +C Hankel-norm approximation is computed only for the +C ALPHA-stable part of the system. +C +C For a transfer-function matrix G, conj(G) denotes the conjugate +C of G given by G'(-s) for a continuous-time system or G'(1/z) +C for a discrete-time system. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBV CHARACTER*1 +C Specifies the left frequency-weighting as follows: +C = 'N': V = I; +C = 'V': op(V) = V; +C = 'I': op(V) = inv(V); +C = 'C': op(V) = conj(V); +C = 'R': op(V) = conj(inv(V)). +C +C JOBW CHARACTER*1 +C Specifies the right frequency-weighting as follows: +C = 'N': W = I; +C = 'W': op(W) = W; +C = 'I': op(W) = inv(W); +C = 'C': op(W) = conj(W); +C = 'R': op(W) = conj(inv(W)). +C +C JOBINV CHARACTER*1 +C Specifies the computational approach to be used as +C follows: +C = 'N': use the inverse free descriptor system approach; +C = 'I': use the inversion based standard approach; +C = 'A': switch automatically to the inverse free +C descriptor approach in case of badly conditioned +C feedthrough matrices in V or W (see METHOD). +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e., the order of the matrix A. N >= 0. +C +C NV (input) INTEGER +C The order of the realization of the left frequency +C weighting V, i.e., the order of the matrix AV. NV >= 0. +C +C NW (input) INTEGER +C The order of the realization of the right frequency +C weighting W, i.e., the order of the matrix AW. NW >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. For a system with NU ALPHA-unstable +C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), +C NR is set as follows: if ORDSEL = 'F', NR is equal to +C NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the +C multiplicity of the Hankel singular value HSV(NR-NU+1), +C NR is the desired order on entry, and NMIN is the order +C of a minimal realization of the ALPHA-stable part of the +C given system; NMIN is determined as the number of Hankel +C singular values greater than NS*EPS*HNORM(As,Bs,Cs), where +C EPS is the machine precision (see LAPACK Library Routine +C DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the +C ALPHA-stable part of the weighted system (computed in +C HSV(1)); +C if ORDSEL = 'A', NR is the sum of NU and the number of +C Hankel singular values greater than +C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix A. For a continuous-time +C system (DICO = 'C'), ALPHA <= 0 is the boundary value for +C the real parts of eigenvalues, while for a discrete-time +C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system in a real Schur form. +C The resulting A has a block-diagonal form with two blocks. +C For a system with NU ALPHA-unstable eigenvalues and +C NS ALPHA-stable eigenvalues (NU+NS = N), the leading +C NU-by-NU block contains the unreduced part of A +C corresponding to ALPHA-unstable eigenvalues. +C The trailing (NR+NS-N)-by-(NR+NS-N) block contains +C the reduced part of A corresponding to ALPHA-stable +C eigenvalues. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) +C On entry, if JOBV <> 'N', the leading NV-by-NV part of +C this array must contain the state matrix AV of a state +C space realization of the left frequency weighting V. +C On exit, if JOBV <> 'N', and INFO = 0, the leading +C NV-by-NV part of this array contains the real Schur form +C of AV. +C AV is not referenced if JOBV = 'N'. +C +C LDAV INTEGER +C The leading dimension of the array AV. +C LDAV >= MAX(1,NV), if JOBV <> 'N'; +C LDAV >= 1, if JOBV = 'N'. +C +C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) +C On entry, if JOBV <> 'N', the leading NV-by-P part of +C this array must contain the input matrix BV of a state +C space realization of the left frequency weighting V. +C On exit, if JOBV <> 'N', and INFO = 0, the leading +C NV-by-P part of this array contains the transformed +C input matrix BV corresponding to the transformed AV. +C BV is not referenced if JOBV = 'N'. +C +C LDBV INTEGER +C The leading dimension of the array BV. +C LDBV >= MAX(1,NV), if JOBV <> 'N'; +C LDBV >= 1, if JOBV = 'N'. +C +C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) +C On entry, if JOBV <> 'N', the leading P-by-NV part of +C this array must contain the output matrix CV of a state +C space realization of the left frequency weighting V. +C On exit, if JOBV <> 'N', and INFO = 0, the leading +C P-by-NV part of this array contains the transformed output +C matrix CV corresponding to the transformed AV. +C CV is not referenced if JOBV = 'N'. +C +C LDCV INTEGER +C The leading dimension of the array CV. +C LDCV >= MAX(1,P), if JOBV <> 'N'; +C LDCV >= 1, if JOBV = 'N'. +C +C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) +C If JOBV <> 'N', the leading P-by-P part of this array +C must contain the feedthrough matrix DV of a state space +C realization of the left frequency weighting V. +C DV is not referenced if JOBV = 'N'. +C +C LDDV INTEGER +C The leading dimension of the array DV. +C LDDV >= MAX(1,P), if JOBV <> 'N'; +C LDDV >= 1, if JOBV = 'N'. +C +C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) +C On entry, if JOBW <> 'N', the leading NW-by-NW part of +C this array must contain the state matrix AW of a state +C space realization of the right frequency weighting W. +C On exit, if JOBW <> 'N', and INFO = 0, the leading +C NW-by-NW part of this array contains the real Schur form +C of AW. +C AW is not referenced if JOBW = 'N'. +C +C LDAW INTEGER +C The leading dimension of the array AW. +C LDAW >= MAX(1,NW), if JOBW <> 'N'; +C LDAW >= 1, if JOBW = 'N'. +C +C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,M) +C On entry, if JOBW <> 'N', the leading NW-by-M part of +C this array must contain the input matrix BW of a state +C space realization of the right frequency weighting W. +C On exit, if JOBW <> 'N', and INFO = 0, the leading +C NW-by-M part of this array contains the transformed +C input matrix BW corresponding to the transformed AW. +C BW is not referenced if JOBW = 'N'. +C +C LDBW INTEGER +C The leading dimension of the array BW. +C LDBW >= MAX(1,NW), if JOBW <> 'N'; +C LDBW >= 1, if JOBW = 'N'. +C +C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) +C On entry, if JOBW <> 'N', the leading M-by-NW part of +C this array must contain the output matrix CW of a state +C space realization of the right frequency weighting W. +C On exit, if JOBW <> 'N', and INFO = 0, the leading +C M-by-NW part of this array contains the transformed output +C matrix CW corresponding to the transformed AW. +C CW is not referenced if JOBW = 'N'. +C +C LDCW INTEGER +C The leading dimension of the array CW. +C LDCW >= MAX(1,M), if JOBW <> 'N'; +C LDCW >= 1, if JOBW = 'N'. +C +C DW (input) DOUBLE PRECISION array, dimension (LDDW,M) +C If JOBW <> 'N', the leading M-by-M part of this array +C must contain the feedthrough matrix DW of a state space +C realization of the right frequency weighting W. +C DW is not referenced if JOBW = 'N'. +C +C LDDW INTEGER +C The leading dimension of the array DW. +C LDDW >= MAX(1,M), if JOBW <> 'N'; +C LDDW >= 1, if JOBW = 'N'. +C +C NS (output) INTEGER +C The dimension of the ALPHA-stable subsystem. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, the leading NS elements of this array contain +C the Hankel singular values, ordered decreasingly, of the +C projection G1s of op(V)*G1*op(W) (see METHOD), where G1 +C is the ALPHA-stable part of the original system. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(G1s), where c is a constant in the +C interval [0.00001,0.001], and HNORM(G1s) is the +C Hankel-norm of the projection G1s of op(V)*G1*op(W) +C (see METHOD), computed in HSV(1). +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = NS*EPS*HNORM(G1s), where NS is the number of +C ALPHA-stable eigenvalues of A and EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C TOL1 < 1. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the ALPHA-stable part of the given system. +C The recommended value is TOL2 = NS*EPS*HNORM(G1s). +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. +C TOL2 < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = MAX(1,M,c,d), if DICO = 'C', +C LIWORK = MAX(1,N,M,c,d), if DICO = 'D', where +C c = 0, if JOBV = 'N', +C c = MAX(2*P,NV+P+N+6,2*NV+P+2), if JOBV <> 'N', +C d = 0, if JOBW = 'N', +C d = MAX(2*M,NW+M+N+6,2*NW+M+2), if JOBW <> 'N'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( LDW1, LDW2, LDW3, LDW4 ), where +C for NVP = NV+P and NWM = NW+M we have +C LDW1 = 0 if JOBV = 'N' and +C LDW1 = 2*NVP*(NVP+P) + P*P + +C MAX( 2*NVP*NVP + MAX( 11*NVP+16, P*NVP ), +C NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ) +C if JOBV <> 'N', +C LDW2 = 0 if JOBW = 'N' and +C LDW2 = 2*NWM*(NWM+M) + M*M + +C MAX( 2*NWM*NWM + MAX( 11*NWM+16, M*NWM ), +C NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ) +C if JOBW <> 'N', +C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, +C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + +C MAX( 3*M+1, MIN(N,M)+P ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than NSMIN, the sum of the order of the +C ALPHA-unstable part and the order of a minimal +C realization of the ALPHA-stable part of the given +C system. In this case, the resulting NR is set equal +C to NSMIN. +C = 2: with ORDSEL = 'F', the selected order NR is less +C than the order of the ALPHA-unstable part of the +C given system. In this case NR is set equal to the +C order of the ALPHA-unstable part. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of the ordered real Schur form of A +C failed; +C = 2: the separation of the ALPHA-stable/unstable +C diagonal blocks failed because of very close +C eigenvalues; +C = 3: the reduction of AV to a real Schur form failed; +C = 4: the reduction of AW to a real Schur form failed; +C = 5: the reduction to generalized Schur form of the +C descriptor pair corresponding to the inverse of V +C failed; +C = 6: the reduction to generalized Schur form of the +C descriptor pair corresponding to the inverse of W +C failed; +C = 7: the computation of Hankel singular values failed; +C = 8: the computation of stable projection in the +C Hankel-norm approximation algorithm failed; +C = 9: the order of computed stable projection in the +C Hankel-norm approximation algorithm differs +C from the order of Hankel-norm approximation; +C = 10: the reduction of AV-BV*inv(DV)*CV to a +C real Schur form failed; +C = 11: the reduction of AW-BW*inv(DW)*CW to a +C real Schur form failed; +C = 12: the solution of the Sylvester equation failed +C because the poles of V (if JOBV = 'V') or of +C conj(V) (if JOBV = 'C') are not distinct from +C the poles of G1 (see METHOD); +C = 13: the solution of the Sylvester equation failed +C because the poles of W (if JOBW = 'W') or of +C conj(W) (if JOBW = 'C') are not distinct from +C the poles of G1 (see METHOD); +C = 14: the solution of the Sylvester equation failed +C because the zeros of V (if JOBV = 'I') or of +C conj(V) (if JOBV = 'R') are not distinct from +C the poles of G1sr (see METHOD); +C = 15: the solution of the Sylvester equation failed +C because the zeros of W (if JOBW = 'I') or of +C conj(W) (if JOBW = 'R') are not distinct from +C the poles of G1sr (see METHOD); +C = 16: the solution of the generalized Sylvester system +C failed because the zeros of V (if JOBV = 'I') or +C of conj(V) (if JOBV = 'R') are not distinct from +C the poles of G1sr (see METHOD); +C = 17: the solution of the generalized Sylvester system +C failed because the zeros of W (if JOBW = 'I') or +C of conj(W) (if JOBW = 'R') are not distinct from +C the poles of G1sr (see METHOD); +C = 18: op(V) is not antistable; +C = 19: op(W) is not antistable; +C = 20: V is not invertible; +C = 21: W is not invertible. +C +C METHOD +C +C Let G be the transfer-function matrix of the original +C linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t), (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09JD determines +C the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t), (2) +C +C such that the corresponding transfer-function matrix Gr minimizes +C the Hankel-norm of the frequency-weighted error +C +C op(V)*(G-Gr)*op(W). (3) +C +C For minimizing (3) with op(V) = V and op(W) = W, V and W are +C assumed to have poles distinct from those of G, while with +C op(V) = conj(V) and op(W) = conj(W), conj(V) and conj(W) are +C assumed to have poles distinct from those of G. For minimizing (3) +C with op(V) = inv(V) and op(W) = inv(W), V and W are assumed to +C have zeros distinct from the poles of G, while with +C op(V) = conj(inv(V)) and op(W) = conj(inv(W)), conj(V) and conj(W) +C are assumed to have zeros distinct from the poles of G. +C +C Note: conj(G) = G'(-s) for a continuous-time system and +C conj(G) = G'(1/z) for a discrete-time system. +C +C The following procedure is used to reduce G (see [1]): +C +C 1) Decompose additively G as +C +C G = G1 + G2, +C +C such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and +C G2 = (A2,B2,C2,0) has only ALPHA-unstable poles. +C +C 2) Compute G1s, the projection of op(V)*G1*op(W) containing the +C poles of G1, using explicit formulas [4] or the inverse-free +C descriptor system formulas of [5]. +C +C 3) Determine G1sr, the optimal Hankel-norm approximation of G1s, +C of order r. +C +C 4) Compute G1r, the projection of inv(op(V))*G1sr*inv(op(W)) +C containing the poles of G1sr, using explicit formulas [4] +C or the inverse-free descriptor system formulas of [5]. +C +C 5) Assemble the reduced model Gr as +C +C Gr = G1r + G2. +C +C To reduce the weighted ALPHA-stable part G1s at step 3, the +C optimal Hankel-norm approximation method of [2], based on the +C square-root balancing projection formulas of [3], is employed. +C +C The optimal weighted approximation error satisfies +C +C HNORM[op(V)*(G-Gr)*op(W)] >= S(r+1), +C +C where S(r+1) is the (r+1)-th Hankel singular value of G1s, the +C transfer-function matrix computed at step 2 of the above +C procedure, and HNORM(.) denotes the Hankel-norm. +C +C REFERENCES +C +C [1] Latham, G.A. and Anderson, B.D.O. +C Frequency-weighted optimal Hankel-norm approximation of stable +C transfer functions. +C Systems & Control Letters, Vol. 5, pp. 229-236, 1985. +C +C [2] Glover, K. +C All optimal Hankel norm approximation of linear +C multivariable systems and their L-infinity error bounds. +C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. +C +C [3] Tombs, M.S. and Postlethwaite, I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [4] Varga, A. +C Explicit formulas for an efficient implementation +C of the frequency-weighting model reduction approach. +C Proc. 1993 European Control Conference, Groningen, NL, +C pp. 693-696, 1993. +C +C [5] Varga, A. +C Efficient and numerically reliable implementation of the +C frequency-weighted Hankel-norm approximation model reduction +C approach. +C Proc. 2001 ECC, Porto, Portugal, 2001. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on an accuracy enhancing square-root +C technique. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2001. +C D. Sima, University of Bucharest, April 2001. +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001. +C +C REVISIONS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. +C V. Sima, Research Institute for Informatics, Bucharest, June 2001, +C March 2005. +C +C KEYWORDS +C +C Frequency weighting, model reduction, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION C100, ONE, P0001, ZERO + PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, P0001 = 0.0001D0, + $ ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOBINV, JOBV, JOBW, ORDSEL + INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, + $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, N, + $ NR, NS, NV, NW, P + DOUBLE PRECISION ALPHA, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), + $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), + $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), + $ D(LDD,*), DV(LDDV,*), DW(LDDW,*), DWORK(*), + $ HSV(*) +C .. Local Scalars .. + CHARACTER JOBVL, JOBWL + LOGICAL AUTOM, CONJV, CONJW, DISCR, FIXORD, FRWGHT, + $ INVFR, LEFTI, LEFTW, RIGHTI, RIGHTW + INTEGER IERR, IWARNL, KAV, KAW, KBV, KBW, KCV, KCW, KDV, + $ KDW, KEV, KEW, KI, KL, KU, KW, LDABV, LDABW, + $ LDCDV, LDCDW, LW, NRA, NU, NU1, NVP, NWM, RANK + DOUBLE PRECISION ALPWRK, MAXRED, RCOND, SQREPS, TOL, WRKOPT +C .. Local Arrays .. + DOUBLE PRECISION TEMP(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB07ND, AB08MD, AB09CX, AB09JV, AB09JW, AG07BD, + $ DLACPY, TB01ID, TB01KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) + LEFTI = LSAME( JOBV, 'I' ) .OR. LSAME( JOBV, 'R' ) + LEFTW = LSAME( JOBV, 'V' ) .OR. LSAME( JOBV, 'C' ) .OR. LEFTI + CONJV = LSAME( JOBV, 'C' ) .OR. LSAME( JOBV, 'R' ) + RIGHTI = LSAME( JOBW, 'I' ) .OR. LSAME( JOBW, 'R' ) + RIGHTW = LSAME( JOBW, 'W' ) .OR. LSAME( JOBW, 'C' ) .OR. RIGHTI + CONJW = LSAME( JOBW, 'C' ) .OR. LSAME( JOBW, 'R' ) + FRWGHT = LEFTW .OR. RIGHTW + INVFR = LSAME( JOBINV, 'N' ) + AUTOM = LSAME( JOBINV, 'A' ) +C + LW = 1 + IF( LEFTW ) THEN + NVP = NV + P + LW = MAX( LW, 2*NVP*( NVP + P ) + P*P + + $ MAX( 2*NVP*NVP + MAX( 11*NVP + 16, P*NVP ), + $ NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ) ) + END IF + IF( RIGHTW ) THEN + NWM = NW + M + LW = MAX( LW, 2*NWM*( NWM + M ) + M*M + + $ MAX( 2*NWM*NWM + MAX( 11*NWM + 16, M*NWM ), + $ NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ) ) + END IF + LW = MAX( LW, N*( 2*N + MAX( N, M, P ) + 5 ) + ( N*( N + 1 ) )/2 ) + LW = MAX( LW, N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + + $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) +C +C Check the input scalar arguments. +C + IF( .NOT. ( LSAME( JOBV, 'N' ) .OR. LEFTW ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( JOBW, 'N' ) .OR. RIGHTW ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( INVFR .OR. AUTOM .OR. LSAME( JOBINV, 'I' ) ) ) + $ THEN + INFO = -3 + ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -4 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -5 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -6 + ELSE IF( N.LT.0 ) THEN + INFO = -7 + ELSE IF( NV.LT.0 ) THEN + INFO = -8 + ELSE IF( NW.LT.0 ) THEN + INFO = -9 + ELSE IF( M.LT.0 ) THEN + INFO = -10 + ELSE IF( P.LT.0 ) THEN + INFO = -11 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -12 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -13 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -19 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -21 + ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN + INFO = -23 + ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN + INFO = -25 + ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.P ) ) THEN + INFO = -27 + ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.P ) ) THEN + INFO = -29 + ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN + INFO = -31 + ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN + INFO = -33 + ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN + INFO = -35 + ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN + INFO = -37 + ELSE IF( TOL1.GE.ONE ) THEN + INFO = -40 + ELSE IF( ( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) + $ .OR. TOL2.GE.ONE ) THEN + INFO = -41 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -44 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09JD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + NS = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C Workspace: N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Correct the value of ALPHA to ensure stability. +C + ALPWRK = ALPHA + SQREPS = SQRT( DLAMCH( 'E' ) ) + IF( DISCR ) THEN + IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQREPS + ELSE + IF( ALPHA.EQ.ZERO ) ALPWRK = -SQREPS + END IF +C +C Allocate working storage. +C + KU = 1 + KL = KU + N*N + KI = KL + N + KW = KI + N +C +C Compute an additive decomposition G = G1 + G2, where G1 +C is the ALPHA-stable projection of G. +C +C Reduce A to a block-diagonal real Schur form, with the NU-th order +C ALPHA-unstable part in the leading diagonal position, using a +C non-orthogonal similarity transformation A <- inv(T)*A*T and +C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, + $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), + $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 1 + ELSE + INFO = 2 + END IF + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) + IWARNL = 0 +C + NS = N - NU + IF( FIXORD ) THEN + NRA = MAX( 0, NR-NU ) + IF( NR.LT.NU ) + $ IWARNL = 2 + ELSE + NRA = 0 + END IF +C +C Finish if only unstable part is present. +C + IF( NS.EQ.0 ) THEN + NR = NU + DWORK(1) = WRKOPT + RETURN + END IF +C + NU1 = NU + 1 + IF( CONJV ) THEN + JOBVL = 'C' + ELSE + JOBVL = 'V' + END IF + IF( CONJW ) THEN + JOBWL = 'C' + ELSE + JOBWL = 'W' + END IF + IF( LEFTW ) THEN +C +C Check if V is invertible. +C Real workspace: need (NV+P)**2 + MAX( P + MAX(3*P,NV), +C MIN(P+1,NV) + MAX(3*(P+1),NV+P) ); +C prefer larger. +C Integer workspace: need 2*NV+P+2. +C + TOL = ZERO + CALL AB08MD( 'S', NV, P, P, AV, LDAV, BV, LDBV, CV, LDCV, + $ DV, LDDV, RANK, TOL, IWORK, DWORK, LDWORK, + $ IERR ) + IF( RANK.NE.P ) THEN + INFO = 20 + RETURN + END IF + WRKOPT = MAX( WRKOPT, DWORK(1) ) +C + IF( LEFTI ) THEN + IF( INVFR ) THEN + IERR = 1 + ELSE +C +C Allocate storage for a standard inverse of V. +C Workspace: need NV*(NV+2*P) + P*P. +C + KAV = 1 + KBV = KAV + NV*NV + KCV = KBV + NV*P + KDV = KCV + P*NV + KW = KDV + P*P +C + LDABV = MAX( NV, 1 ) + LDCDV = P + CALL DLACPY( 'Full', NV, NV, AV, LDAV, + $ DWORK(KAV), LDABV ) + CALL DLACPY( 'Full', NV, P, BV, LDBV, + $ DWORK(KBV), LDABV ) + CALL DLACPY( 'Full', P, NV, CV, LDCV, + $ DWORK(KCV), LDCDV ) + CALL DLACPY( 'Full', P, P, DV, LDDV, + $ DWORK(KDV), LDCDV ) +C +C Compute the standard inverse of V. +C Additional real workspace: need MAX(1,4*P); +C prefer larger. +C Integer workspace: need 2*P. +C + CALL AB07ND( NV, P, DWORK(KAV), LDABV, DWORK(KBV), LDABV, + $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, + $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) +C +C Check if inversion is accurate. +C + IF( AUTOM ) THEN + IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 + ELSE + IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 + END IF + IF( IERR.NE.0 .AND. NV.EQ.0 ) THEN + INFO = 20 + RETURN + END IF + END IF +C + IF( IERR.NE.0 ) THEN +C +C Allocate storage for a descriptor inverse of V. +C + KAV = 1 + KEV = KAV + NVP*NVP + KBV = KEV + NVP*NVP + KCV = KBV + NVP*P + KDV = KCV + P*NVP + KW = KDV + P*P +C + LDABV = MAX( NVP, 1 ) + LDCDV = P +C +C DV is singular or ill-conditioned. +C Form a descriptor inverse of V. +C Workspace: need 2*(NV+P)*(NV+2*P) + P*P. +C + CALL AG07BD( 'I', NV, P, AV, LDAV, TEMP, 1, BV, LDBV, + $ CV, LDCV, DV, LDDV, DWORK(KAV), LDABV, + $ DWORK(KEV), LDABV, DWORK(KBV), LDABV, + $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IERR ) +C +C Compute the projection containing the poles of weighted +C reduced ALPHA-stable part using descriptor inverse of V +C of order NVP = NV + P. +C Additional real workspace: need +C MAX( 2*NVP*NVP + MAX( 11*NVP+16, P*NVP ), +C NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ); +C prefer larger. +C Integer workspace: need NVP+N+6. +C + CALL AB09JV( JOBVL, DICO, 'G', 'C', NS, M, P, NVP, P, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, + $ DWORK(KAV), LDABV, DWORK(KEV), LDABV, + $ DWORK(KBV), LDABV, DWORK(KCV), LDCDV, + $ DWORK(KDV), LDCDV, IWORK, DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 5 + ELSE IF( IERR.EQ.2 ) THEN + INFO = 16 + ELSE IF( IERR.EQ.4 ) THEN + INFO = 18 + END IF + RETURN + END IF + ELSE +C +C Compute the projection containing the poles of weighted +C reduced ALPHA-stable part using explicit inverse of V. +C Additional real workspace: need +C MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) +C a = 0, if DICO = 'C' or JOBVL = 'V', +C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; +C prefer larger. +C + CALL AB09JV( JOBVL, DICO, 'I', 'C', NS, M, P, NV, P, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, DWORK(KAV), LDABV, + $ TEMP, 1, DWORK(KBV), LDABV, + $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IWORK, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 10 + ELSE IF( IERR.EQ.3 ) THEN + INFO = 14 + ELSE IF( IERR.EQ.4 ) THEN + INFO = 18 + END IF + RETURN + END IF + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) + ELSE +C +C Compute the projection of V*G1 or conj(V)*G1 containing the +C poles of G. +C +C Workspace need: +C real MAX( 1, NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) +C a = 0, if DICO = 'C' or JOBVL = 'V', +C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; +C prefer larger. +C + CALL AB09JV( JOBVL, DICO, 'I', 'C', NS, M, P, NV, P, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, AV, LDAV, + $ TEMP, 1, BV, LDBV, CV, LDCV, DV, LDDV, IWORK, + $ DWORK, LDWORK, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 3 + ELSE IF( IERR.EQ.3 ) THEN + INFO = 12 + ELSE IF( IERR.EQ.4 ) THEN + INFO = 18 + END IF + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(1) ) + END IF + END IF +C + IF( RIGHTW ) THEN +C +C Check if W is invertible. +C Real workspace: need (NW+M)**2 + MAX( M + MAX(3*M,NW), +C MIN(M+1,NW) + MAX(3*(M+1),NW+M) ); +C prefer larger. +C Integer workspace: need 2*NW+M+2. +C + TOL = ZERO + CALL AB08MD( 'S', NW, M, M, AW, LDAW, BW, LDBW, CW, LDCW, + $ DW, LDDW, RANK, TOL, IWORK, DWORK, LDWORK, + $ IERR ) + IF( RANK.NE.M ) THEN + INFO = 21 + RETURN + END IF + WRKOPT = MAX( WRKOPT, DWORK(1) ) +C + IF( RIGHTI ) THEN + IF( INVFR ) THEN + IERR = 1 + ELSE +C +C Allocate storage for a standard inverse of W. +C Workspace: need NW*(NW+2*M) + M*M. +C + KAW = 1 + KBW = KAW + NW*NW + KCW = KBW + NW*M + KDW = KCW + M*NW + KW = KDW + M*M +C + LDABW = MAX( NW, 1 ) + LDCDW = M + CALL DLACPY( 'Full', NW, NW, AW, LDAW, + $ DWORK(KAW), LDABW ) + CALL DLACPY( 'Full', NW, M, BW, LDBW, + $ DWORK(KBW), LDABW ) + CALL DLACPY( 'Full', M, NW, CW, LDCW, + $ DWORK(KCW), LDCDW ) + CALL DLACPY( 'Full', M, M, DW, LDDW, + $ DWORK(KDW), LDCDW ) +C +C Compute the standard inverse of W. +C Additional real workspace: need MAX(1,4*M); +C prefer larger. +C Integer workspace: need 2*M. +C + CALL AB07ND( NW, M, DWORK(KAW), LDABW, DWORK(KBW), LDABW, + $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, + $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) +C +C Check if inversion is accurate. +C + IF( AUTOM ) THEN + IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 + ELSE + IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 + END IF + IF( IERR.NE.0 .AND. NW.EQ.0 ) THEN + INFO = 21 + RETURN + END IF + END IF +C + IF( IERR.NE.0 ) THEN +C +C Allocate storage for a descriptor inverse of W. +C + KAW = 1 + KEW = KAW + NWM*NWM + KBW = KEW + NWM*NWM + KCW = KBW + NWM*M + KDW = KCW + M*NWM + KW = KDW + M*M +C + LDABW = MAX( NWM, 1 ) + LDCDW = M +C +C DW is singular or ill-conditioned. +C Form the descriptor inverse of W. +C Workspace: need 2*(NW+M)*(NW+2*M) + M*M. +C + CALL AG07BD( 'I', NW, M, AW, LDAW, TEMP, 1, BW, LDBW, + $ CW, LDCW, DW, LDDW, DWORK(KAW), LDABW, + $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, + $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, IERR ) +C +C Compute the projection containing the poles of weighted +C reduced ALPHA-stable part using descriptor inverse of W +C of order NWM = NW + M. +C Additional real workspace: need +C MAX( 2*NWM*NWM + MAX( 11*NWM+16, M*NWM ), +C NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ); +C prefer larger. +C Integer workspace: need NWM+N+6. +C + CALL AB09JW( JOBWL, DICO, 'G', 'C', NS, M, P, NWM, M, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, + $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, + $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, + $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 6 + ELSE IF( IERR.EQ.2 ) THEN + INFO = 17 + ELSE IF( IERR.EQ.4 ) THEN + INFO = 19 + END IF + RETURN + END IF + ELSE +C +C Compute the projection containing the poles of weighted +C reduced ALPHA-stable part using explicit inverse of W. +C Additional real workspace: need +C MAX( NW*(NW+5), NW*N + MAX( a, M*N, P*M ) ) +C a = 0, if DICO = 'C' or JOBWL = 'W', +C a = 2*NW, if DICO = 'D' and JOBWL = 'C'; +C prefer larger. +C + CALL AB09JW( JOBWL, DICO, 'I', 'C', NS, M, P, NW, M, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, + $ TEMP, 1, DWORK(KBW), LDABW, + $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, + $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 11 + ELSE IF( IERR.EQ.3 ) THEN + INFO = 15 + ELSE IF( IERR.EQ.4 ) THEN + INFO = 19 + END IF + RETURN + END IF + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) + ELSE +C +C Compute the projection G1s of V*G1*W or conj(V)*G1*conj(W) +C containing the poles of G. +C +C Workspace need: +C real MAX( 1, NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) +C b = 0, if DICO = 'C' or JOBWL = 'W', +C b = 2*NW, if DICO = 'D' and JOBWL = 'C'; +C prefer larger. +C + CALL AB09JW( JOBWL, DICO, 'I', 'C', NS, M, P, NW, M, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, C(1,NU1), LDC, + $ D, LDD, AW, LDAW, TEMP, 1, BW, LDBW, CW, LDCW, + $ DW, LDDW, IWORK, DWORK, LDWORK, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 4 + ELSE IF( IERR.EQ.3 ) THEN + INFO = 13 + ELSE IF( IERR.EQ.4 ) THEN + INFO = 19 + END IF + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(1) ) + END IF + END IF +C +C Determine a reduced order approximation G1sr of G1s using the +C Hankel-norm approximation method. The resulting A(NU1:N,NU1:N) +C is further in a real Schur form. +C +C Workspace: need MAX( LDW3, LDW4 ), +C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, +C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + +C MAX( 3*M+1, MIN(N,M)+P ); +C prefer larger. +C + CALL AB09CX( DICO, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, + $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, TOL1, + $ TOL2, IWORK, DWORK, LDWORK, IWARN, IERR ) +C + IF( IERR.NE.0 ) THEN +C +C Set INFO = 7, 8 or 9. +C + INFO = IERR + 5 + RETURN + END IF +C + IWARN = MAX( IWARNL, IWARN ) + WRKOPT = MAX( WRKOPT, DWORK(1) ) +C + IF( LEFTW ) THEN + IF( .NOT.LEFTI ) THEN + IF( INVFR ) THEN + IERR = 1 + ELSE +C +C Allocate storage for a standard inverse of V. +C Workspace: need NV*(NV+2*P) + P*P. +C + KAV = 1 + KBV = KAV + NV*NV + KCV = KBV + NV*P + KDV = KCV + P*NV + KW = KDV + P*P +C + LDABV = MAX( NV, 1 ) + LDCDV = P + CALL DLACPY( 'Full', NV, NV, AV, LDAV, + $ DWORK(KAV), LDABV ) + CALL DLACPY( 'Full', NV, P, BV, LDBV, + $ DWORK(KBV), LDABV ) + CALL DLACPY( 'Full', P, NV, CV, LDCV, + $ DWORK(KCV), LDCDV ) + CALL DLACPY( 'Full', P, P, DV, LDDV, + $ DWORK(KDV), LDCDV ) +C +C Compute the standard inverse of V. +C Additional real workspace: need MAX(1,4*P); +C prefer larger. +C Integer workspace: need 2*P. +C + CALL AB07ND( NV, P, DWORK(KAV), LDABV, DWORK(KBV), LDABV, + $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, + $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) +C +C Check if inversion is accurate. +C + IF( AUTOM ) THEN + IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 + ELSE + IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 + END IF + IF( IERR.NE.0 .AND. NV.EQ.0 ) THEN + INFO = 20 + RETURN + END IF + END IF +C + IF( IERR.NE.0 ) THEN +C +C Allocate storage for a descriptor inverse of V. +C + KAV = 1 + KEV = KAV + NVP*NVP + KBV = KEV + NVP*NVP + KCV = KBV + NVP*P + KDV = KCV + P*NVP + KW = KDV + P*P +C + LDABV = MAX( NVP, 1 ) + LDCDV = P +C +C DV is singular or ill-conditioned. +C Form a descriptor inverse of V. +C Workspace: need 2*(NV+P)*(NV+2*P) + P*P. +C + CALL AG07BD( 'I', NV, P, AV, LDAV, TEMP, 1, BV, LDBV, + $ CV, LDCV, DV, LDDV, DWORK(KAV), LDABV, + $ DWORK(KEV), LDABV, DWORK(KBV), LDABV, + $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IERR ) +C +C Compute the projection containing the poles of weighted +C reduced ALPHA-stable part using descriptor inverse of V +C of order NVP = NV + P. +C Additional real workspace: need +C MAX( 2*NVP*NVP + MAX( 11*NVP+16, P*NVP ), +C NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ); +C prefer larger. +C Integer workspace: need NVP+N+6. +C + CALL AB09JV( JOBVL, DICO, 'G', 'N', NRA, M, P, NVP, P, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, + $ DWORK(KAV), LDABV, DWORK(KEV), LDABV, + $ DWORK(KBV), LDABV, DWORK(KCV), LDCDV, + $ DWORK(KDV), LDCDV, IWORK, DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 5 + ELSE IF( IERR.EQ.2 ) THEN + INFO = 16 + END IF + RETURN + END IF + ELSE +C +C Compute the projection containing the poles of weighted +C reduced ALPHA-stable part using explicit inverse of V. +C Additional real workspace: need +C MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) +C a = 0, if DICO = 'C' or JOBVL = 'V', +C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; +C prefer larger. +C + CALL AB09JV( JOBVL, DICO, 'I', 'N', NRA, M, P, NV, P, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, DWORK(KAV), LDABV, + $ TEMP, 1, DWORK(KBV), LDABV, + $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IWORK, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 10 + ELSE IF( IERR.EQ.3 ) THEN + INFO = 14 + END IF + RETURN + END IF + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) + ELSE +C +C Compute the projection of V*G1sr or conj(V)*G1sr containing +C the poles of G. +C +C Workspace need: +C real MAX( 1, NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) +C a = 0, if DICO = 'C' or JOBVL = 'V', +C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; +C prefer larger. +C + CALL AB09JV( JOBVL, DICO, 'I', 'N', NRA, M, P, NV, P, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, AV, LDAV, + $ TEMP, 1, BV, LDBV, CV, LDCV, DV, LDDV, IWORK, + $ DWORK, LDWORK, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 3 + ELSE IF( IERR.EQ.3 ) THEN + INFO = 12 + END IF + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(1) ) + END IF + END IF +C + IF( RIGHTW ) THEN + IF( .NOT.RIGHTI ) THEN + IF( INVFR ) THEN + IERR = 1 + ELSE +C +C Allocate storage for a standard inverse of W. +C Workspace: need NW*(NW+2*M) + M*M. +C + KAW = 1 + KBW = KAW + NW*NW + KCW = KBW + NW*M + KDW = KCW + M*NW + KW = KDW + M*M +C + LDABW = MAX( NW, 1 ) + LDCDW = M + CALL DLACPY( 'Full', NW, NW, AW, LDAW, + $ DWORK(KAW), LDABW ) + CALL DLACPY( 'Full', NW, M, BW, LDBW, + $ DWORK(KBW), LDABW ) + CALL DLACPY( 'Full', M, NW, CW, LDCW, + $ DWORK(KCW), LDCDW ) + CALL DLACPY( 'Full', M, M, DW, LDDW, + $ DWORK(KDW), LDCDW ) +C +C Compute the standard inverse of W. +C Additional real workspace: need MAX(1,4*M); +C prefer larger. +C Integer workspace: need 2*M. +C + CALL AB07ND( NW, M, DWORK(KAW), LDABW, DWORK(KBW), LDABW, + $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, + $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) +C +C Check if inversion is accurate. +C + IF( AUTOM ) THEN + IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 + ELSE + IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 + END IF + IF( IERR.NE.0 .AND. NW.EQ.0 ) THEN + INFO = 21 + RETURN + END IF + END IF +C + IF( IERR.NE.0 ) THEN +C +C Allocate storage for a descriptor inverse of W. +C + KAW = 1 + KEW = KAW + NWM*NWM + KBW = KEW + NWM*NWM + KCW = KBW + NWM*M + KDW = KCW + M*NWM + KW = KDW + M*M +C + LDABW = MAX( NWM, 1 ) + LDCDW = M +C +C DW is singular or ill-conditioned. +C Form the descriptor inverse of W. +C Workspace: need 2*(NW+M)*(NW+2*M) + M*M. +C + CALL AG07BD( 'I', NW, M, AW, LDAW, TEMP, 1, BW, LDBW, + $ CW, LDCW, DW, LDDW, DWORK(KAW), LDABW, + $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, + $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, IERR ) +C +C Compute the projection containing the poles of weighted +C reduced ALPHA-stable part using descriptor inverse of W +C of order NWM = NW + M. +C Additional real workspace: need +C MAX( 2*NWM*NWM + MAX( 11*NWM+16, M*NWM ), +C NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ); +C prefer larger. +C Integer workspace: need NWM+N+6. +C + CALL AB09JW( JOBWL, DICO, 'G', 'N', NRA, M, P, NWM, M, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, + $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, + $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, + $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 6 + ELSE IF( IERR.EQ.2 ) THEN + INFO = 17 + END IF + RETURN + END IF + ELSE +C +C Compute the projection containing the poles of weighted +C reduced ALPHA-stable part using explicit inverse of W. +C Additional real workspace: need +C MAX( NW*(NW+5), NW*N + MAX( a, M*N, P*M ) ) +C a = 0, if DICO = 'C' or JOBWL = 'W', +C a = 2*NW, if DICO = 'D' and JOBWL = 'C'; +C prefer larger. +C + CALL AB09JW( JOBWL, DICO, 'I', 'N', NRA, M, P, NW, M, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, + $ TEMP, 1, DWORK(KBW), LDABW, + $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, + $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 11 + ELSE IF( IERR.EQ.3 ) THEN + INFO = 15 + END IF + RETURN + END IF + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) + ELSE +C +C Compute the projection G1r of V*G1sr*W or +C conj(V)*G1sr*conj(W) containing the poles of G. +C +C Workspace need: +C real MAX( 1, NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) +C b = 0, if DICO = 'C' or JOBWL = 'W', +C b = 2*NW, if DICO = 'D' and JOBWL = 'C'; +C prefer larger. +C + CALL AB09JW( JOBWL, DICO, 'I', 'N', NRA, M, P, NW, M, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, C(1,NU1), LDC, + $ D, LDD, AW, LDAW, TEMP, 1, BW, LDBW, CW, LDCW, + $ DW, LDDW, IWORK, DWORK, LDWORK, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 4 + ELSE IF( IERR.EQ.3 ) THEN + INFO = 13 + END IF + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(1) ) + END IF + END IF +C + NR = NRA + NU + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB09JD *** + END diff --git a/mex/sources/libslicot/AB09JV.f b/mex/sources/libslicot/AB09JV.f new file mode 100644 index 000000000..5a7d08ab2 --- /dev/null +++ b/mex/sources/libslicot/AB09JV.f @@ -0,0 +1,958 @@ + SUBROUTINE AB09JV( JOB, DICO, JOBEV, STBCHK, N, M, P, NV, PV, + $ A, LDA, B, LDB, C, LDC, D, LDD, AV, LDAV, + $ EV, LDEV, BV, LDBV, CV, LDCV, DV, LDDV, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct a state-space representation (A,BS,CS,DS) of the +C projection of V*G or conj(V)*G containing the poles of G, from the +C state-space representations (A,B,C,D) and (AV-lambda*EV,BV,CV,DV), +C of the transfer-function matrices G and V, respectively. +C G is assumed to be a stable transfer-function matrix and +C the state matrix A must be in a real Schur form. +C When computing the stable projection of V*G, it is assumed +C that G and V have completely distinct poles. +C When computing the stable projection of conj(V)*G, it is assumed +C that G and conj(V) have completely distinct poles. +C +C Note: For a transfer-function matrix G, conj(G) denotes the +C conjugate of G given by G'(-s) for a continuous-time system or +C G'(1/z) for a discrete-time system. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the projection to be computed as follows: +C = 'V': compute the projection of V*G containing +C the poles of G; +C = 'C': compute the projection of conj(V)*G containing +C the poles of G. +C +C DICO CHARACTER*1 +C Specifies the type of the systems as follows: +C = 'C': G and V are continuous-time systems; +C = 'D': G and V are discrete-time systems. +C +C JOBEV CHARACTER*1 +C Specifies whether EV is a general square or an identity +C matrix as follows: +C = 'G': EV is a general square matrix; +C = 'I': EV is the identity matrix. +C +C STBCHK CHARACTER*1 +C Specifies whether stability/antistability of V is to be +C checked as follows: +C = 'C': check stability if JOB = 'C' or antistability if +C JOB = 'V'; +C = 'N': do not check stability or antistability. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the state vector of the system with +C the transfer-function matrix G. N >= 0. +C +C M (input) INTEGER +C The dimension of the input vector of the system with +C the transfer-function matrix G. M >= 0. +C +C P (input) INTEGER +C The dimension of the output vector of the system with the +C transfer-function matrix G, and also the dimension of +C the input vector if JOB = 'V', or of the output vector +C if JOB = 'C', of the system with the transfer-function +C matrix V. P >= 0. +C +C NV (input) INTEGER +C The dimension of the state vector of the system with +C the transfer-function matrix V. NV >= 0. +C +C PV (input) INTEGER +C The dimension of the output vector, if JOB = 'V', or +C of the input vector, if JOB = 'C', of the system with +C the transfer-function matrix V. PV >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the system with the transfer-function +C matrix G in a real Schur form. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain +C the input/state matrix B of the system with the +C transfer-function matrix G. The matrix BS is equal to B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C of the system with the +C transfer-function matrix G. +C On exit, if INFO = 0, the leading PV-by-N part of this +C array contains the output matrix CS of the projection of +C V*G, if JOB = 'V', or of conj(V)*G, if JOB = 'C'. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,P,PV). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the feedthrough matrix D of the system with the +C transfer-function matrix G. +C On exit, if INFO = 0, the leading PV-by-M part of +C this array contains the feedthrough matrix DS of the +C projection of V*G, if JOB = 'V', or of conj(V)*G, +C if JOB = 'C'. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= MAX(1,P,PV). +C +C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) +C On entry, the leading NV-by-NV part of this array must +C contain the state matrix AV of the system with the +C transfer-function matrix V. +C On exit, if INFO = 0, the leading NV-by-NV part of this +C array contains a condensed matrix as follows: +C if JOBEV = 'I', it contains the real Schur form of AV; +C if JOBEV = 'G' and JOB = 'V', it contains a quasi-upper +C triangular matrix representing the real Schur matrix +C in the real generalized Schur form of the pair (AV,EV); +C if JOBEV = 'G', JOB = 'C' and DICO = 'C', it contains a +C quasi-upper triangular matrix corresponding to the +C generalized real Schur form of the pair (AV',EV'); +C if JOBEV = 'G', JOB = 'C' and DICO = 'D', it contains an +C upper triangular matrix corresponding to the generalized +C real Schur form of the pair (EV',AV'). +C +C LDAV INTEGER +C The leading dimension of the array AV. LDAV >= MAX(1,NV). +C +C EV (input/output) DOUBLE PRECISION array, dimension (LDEV,NV) +C On entry, if JOBEV = 'G', the leading NV-by-NV part of +C this array must contain the descriptor matrix EV of the +C system with the transfer-function matrix V. +C If JOBEV = 'I', EV is assumed to be an identity matrix +C and is not referenced. +C On exit, if INFO = 0 and JOBEV = 'G', the leading NV-by-NV +C part of this array contains a condensed matrix as follows: +C if JOB = 'V', it contains an upper triangular matrix +C corresponding to the real generalized Schur form of the +C pair (AV,EV); +C if JOB = 'C' and DICO = 'C', it contains an upper +C triangular matrix corresponding to the generalized real +C Schur form of the pair (AV',EV'); +C if JOB = 'C' and DICO = 'D', it contains a quasi-upper +C triangular matrix corresponding to the generalized +C real Schur form of the pair (EV',AV'). +C +C LDEV INTEGER +C The leading dimension of the array EV. +C LDEV >= MAX(1,NV), if JOBEV = 'G'; +C LDEV >= 1, if JOBEV = 'I'. +C +C BV (input/output) DOUBLE PRECISION array, +C dimension (LDBV,MBV), where MBV = P, if JOB = 'V', and +C MBV = PV, if JOB = 'C'. +C On entry, the leading NV-by-MBV part of this array must +C contain the input matrix BV of the system with the +C transfer-function matrix V. +C On exit, if INFO = 0, the leading NV-by-MBV part of this +C array contains Q'*BV, where Q is the orthogonal matrix +C that reduces AV to the real Schur form or the left +C orthogonal matrix used to reduce the pair (AV,EV), +C (AV',EV') or (EV',AV') to the generalized real Schur form. +C +C LDBV INTEGER +C The leading dimension of the array BV. LDBV >= MAX(1,NV). +C +C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) +C On entry, the leading PCV-by-NV part of this array must +C contain the output matrix CV of the system with the +C transfer-function matrix V, where PCV = PV, if JOB = 'V', +C or PCV = P, if JOB = 'C'. +C On exit, if INFO = 0, the leading PCV-by-NV part of this +C array contains CV*Q, where Q is the orthogonal matrix that +C reduces AV to the real Schur form, or CV*Z, where Z is the +C right orthogonal matrix used to reduce the pair (AV,EV), +C (AV',EV') or (EV',AV') to the generalized real Schur form. +C +C LDCV INTEGER +C The leading dimension of the array CV. +C LDCV >= MAX(1,PV) if JOB = 'V'; +C LDCV >= MAX(1,P) if JOB = 'C'. +C +C DV (input) DOUBLE PRECISION array, +C dimension (LDDV,MBV), where MBV = P, if JOB = 'V', and +C MBV = PV, if JOB = 'C'. +C The leading PCV-by-MBV part of this array must contain +C the feedthrough matrix DV of the system with the +C transfer-function matrix V, where PCV = PV, if JOB = 'V', +C or PCV = P, if JOB = 'C'. +C +C LDDV INTEGER +C The leading dimension of the array DV. +C LDDV >= MAX(1,PV) if JOB = 'V'; +C LDDV >= MAX(1,P) if JOB = 'C'. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = 0, if JOBEV = 'I'; +C LIWORK = NV+N+6, if JOBEV = 'G'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= LW1, if JOBEV = 'I', +C LDWORK >= LW2, if JOBEV = 'G', where +C LW1 = MAX( 1, NV*(NV+5), NV*N + MAX( a, PV*N, PV*M ) ) +C a = 0, if DICO = 'C' or JOB = 'V', +C a = 2*NV, if DICO = 'D' and JOB = 'C'; +C LW2 = MAX( 2*NV*NV + MAX( 11*NV+16, P*NV, PV*NV ), +C NV*N + MAX( NV*N+N*N, PV*N, PV*M ) ). +C For good performance, LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of the pair (AV,EV) to the real +C generalized Schur form failed (JOBEV = 'G'), +C or the reduction of the matrix AV to the real +C Schur form failed (JOBEV = 'I); +C = 2: the solution of the Sylvester equation failed +C because the matrix A and the pencil AV-lambda*EV +C have common eigenvalues (if JOB = 'V'), or the +C pencil -AV-lambda*EV and A have common eigenvalues +C (if JOB = 'C' and DICO = 'C'), or the pencil +C AV-lambda*EV has an eigenvalue which is the +C reciprocal of one of eigenvalues of A +C (if JOB = 'C' and DICO = 'D'); +C = 3: the solution of the Sylvester equation failed +C because the matrices A and AV have common +C eigenvalues (if JOB = 'V'), or the matrices A +C and -AV have common eigenvalues (if JOB = 'C' and +C DICO = 'C'), or the matrix A has an eigenvalue +C which is the reciprocal of one of eigenvalues of AV +C (if JOB = 'C' and DICO = 'D'); +C = 4: JOB = 'V' and the pair (AV,EV) has not completely +C unstable generalized eigenvalues, or JOB = 'C' and +C the pair (AV,EV) has not completely stable +C generalized eigenvalues. +C +C METHOD +C +C If JOB = 'V', the matrices of the stable projection of V*G are +C computed as +C +C BS = B, CS = CV*X + DV*C, DS = DV*D, +C +C where X satisfies the generalized Sylvester equation +C +C AV*X - EV*X*A + BV*C = 0. +C +C If JOB = 'C', the matrices of the stable projection of conj(V)*G +C are computed using the following formulas: +C +C - for a continuous-time system, the matrices BS, CS and DS of +C the stable projection are computed as +C +C BS = B, CS = BV'*X + DV'*C, DS = DV'*D, +C +C where X satisfies the generalized Sylvester equation +C +C AV'*X + EV'*X*A + CV'*C = 0. +C +C - for a discrete-time system, the matrices BS, CS and DS of +C the stable projection are computed as +C +C BS = B, CS = BV'*X*A + DV'*C, DS = DV'*D + BV'*X*B, +C +C where X satisfies the generalized Sylvester equation +C +C EV'*X - AV'*X*A = CV'*C. +C +C REFERENCES +C +C [1] Varga, A. +C Efficient and numerically reliable implementation of the +C frequency-weighted Hankel-norm approximation model reduction +C approach. +C Proc. 2001 ECC, Porto, Portugal, 2001. +C +C [2] Zhou, K. +C Frequency-weighted H-infinity norm and optimal Hankel norm +C model reduction. +C IEEE Trans. Autom. Control, vol. 40, pp. 1687-1699, 1995. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on numerically stable algorithms. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. +C D. Sima, University of Bucharest, March 2001. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. +C +C REVISIONS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. +C V. Sima, Research Institute for Informatics, Bucharest, June 2001. +C A. Varga, German Aerospace Center, Oberpfaffenhofen, Nov. 2003. +C +C KEYWORDS +C +C Frequency weighting, model reduction, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOB, JOBEV, STBCHK + INTEGER INFO, LDA, LDAV, LDB, LDBV, LDC, LDCV, + $ LDD, LDDV, LDEV, LDWORK, M, N, NV, P, PV +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), AV(LDAV,*), B(LDB,*), BV(LDBV,*), + $ C(LDC,*), CV(LDCV,*), D(LDD,*), DV(LDDV,*), + $ DWORK(*), EV(LDEV,*) +C .. Local Scalars .. + CHARACTER*1 EVTYPE, STDOM + LOGICAL CONJS, DISCR, STABCK, UNITEV + DOUBLE PRECISION ALPHA, DIF, SCALE, TOLINF, WORK + INTEGER I, IA, IERR, KAI, KAR, KB, KC, KE, KF, KQ, KW, + $ KZ, LDW, LDWN, LW, SDIM +C .. Local Arrays .. + LOGICAL BWORK(1) +C .. External Functions .. + LOGICAL DELCTG, LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DELCTG, DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL AB09JX, DGEMM, DGGES, DLACPY, DLASET, DSWAP, + $ DTGSYL, DTRSYL, SB04PY, TB01WD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, SQRT +C +C .. Executable Statements .. +C + CONJS = LSAME( JOB, 'C' ) + DISCR = LSAME( DICO, 'D' ) + UNITEV = LSAME( JOBEV, 'I' ) + STABCK = LSAME( STBCHK, 'C' ) +C + INFO = 0 + IF( UNITEV ) THEN + IF ( DISCR .AND. CONJS ) THEN + IA = 2*NV + ELSE + IA = 0 + END IF + LW = MAX( 1, NV*( NV + 5 ), NV*N + MAX( IA, PV*N, PV*M ) ) + ELSE + LW = MAX( 2*NV*NV + MAX( 11*NV+16, P*NV, PV*NV ), + $ NV*N + MAX( NV*N + N*N, PV*N, PV*M ) ) + END IF +C +C Test the input scalar arguments. +C + LDWN = MAX( 1, N ) + LDW = MAX( 1, NV ) + IF( .NOT. ( LSAME( JOB, 'V' ) .OR. CONJS ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( JOBEV, 'G' ) .OR. UNITEV ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( LSAME( STBCHK, 'N' ) .OR. STABCK ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( NV.LT.0 ) THEN + INFO = -8 + ELSE IF( PV.LT.0 ) THEN + INFO = -9 + ELSE IF( LDA.LT.LDWN ) THEN + INFO = -11 + ELSE IF( LDB.LT.LDWN ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P, PV ) ) THEN + INFO = -15 + ELSE IF( LDD.LT.MAX( 1, P, PV ) ) THEN + INFO = -17 + ELSE IF( LDAV.LT.LDW ) THEN + INFO = -19 + ELSE IF( LDEV.LT.1 .OR. ( .NOT.UNITEV .AND. LDEV.LT.NV ) ) THEN + INFO = -21 + ELSE IF( LDBV.LT.LDW ) THEN + INFO = -23 + ELSE IF( ( .NOT.CONJS .AND. LDCV.LT.MAX( 1, PV ) ) .OR. + $ ( CONJS .AND. LDCV.LT.MAX( 1, P ) ) ) THEN + INFO = -25 + ELSE IF( ( .NOT.CONJS .AND. LDDV.LT.MAX( 1, PV ) ) .OR. + $ ( CONJS .AND. LDDV.LT.MAX( 1, P ) ) ) THEN + INFO = -27 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -30 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09JV', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( P.EQ.0 .OR. PV.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Set options for stability/antistability checking. +C + IF( DISCR ) THEN + ALPHA = ONE + ELSE + ALPHA = ZERO + END IF +C + WORK = ONE + TOLINF = DLAMCH( 'Epsilon' ) +C + IF( UNITEV ) THEN +C +C EV is the identity matrix. +C + IF( NV.GT.0 ) THEN +C +C Reduce AV to the real Schur form using an orthogonal +C similarity transformation AV <- Q'*AV*Q and apply the +C transformation to BV and CV: BV <- Q'*BV and CV <- CV*Q. +C +C Workspace needed: NV*(NV+5); +C prefer larger. +C + KW = NV*( NV + 2 ) + 1 + IF( CONJS ) THEN + STDOM = 'S' + ALPHA = ALPHA + SQRT( TOLINF ) + CALL TB01WD( NV, PV, P, AV, LDAV, BV, LDBV, CV, LDCV, + $ DWORK(2*NV+1), NV, DWORK, DWORK(NV+1), + $ DWORK(KW), LDWORK-KW+1, IERR ) + ELSE + STDOM = 'U' + ALPHA = ALPHA - SQRT( TOLINF ) + CALL TB01WD( NV, P, PV, AV, LDAV, BV, LDBV, CV, LDCV, + $ DWORK(2*NV+1), NV, DWORK, DWORK(NV+1), + $ DWORK(KW), LDWORK-KW+1, IERR ) + END IF + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + IF( STABCK ) THEN +C +C Check stability/antistability of eigenvalues of AV. +C + CALL AB09JX( DICO, STDOM, 'S', NV, ALPHA, DWORK, + $ DWORK(NV+1), DWORK, TOLINF, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + END IF +C + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C + END IF +C + KW = NV*N + 1 + IF( CONJS ) THEN +C +C Compute the projection of conj(V)*G. +C +C Total workspace needed: NV*N + MAX( a, PV*N, PV*M ), where +C a = 0, if DICO = 'C', +C a = 2*NV, if DICO = 'D'. +C +C Compute -CV'*C. +C Workspace needed: NV*N. +C + CALL DGEMM( 'T', 'N', NV, N, P, -ONE, CV, LDCV, C, LDC, + $ ZERO, DWORK, LDW ) +C + IF( DISCR ) THEN +C +C Compute X and SCALE satisfying +C +C AV'*X*A - X = -SCALE*CV'*C. +C +C Additional workspace needed: 2*NV. +C + CALL SB04PY( 'T', 'N', -1, NV, N, AV, LDAV, A, LDA, + $ DWORK, LDW, SCALE, DWORK(KW), IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C +C Construct CS = DV'*C + BV'*X*A/SCALE, +C DS = DV'*D + BV'*X*B/SCALE. +C +C Additional workspace needed: MAX( PV*N, PV*M ). +C +C C <- DV'*C. +C + CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) +C +C D <- DV'*D. +C + CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) +C +C C <- C + BV'*X*A/SCALE. +C + CALL DGEMM( 'T', 'N', PV, N, NV, ONE / SCALE, BV, LDBV, + $ DWORK, LDW, ZERO, DWORK(KW), PV ) + CALL DGEMM( 'N', 'N', PV, N, N, ONE, DWORK(KW), PV, + $ A, LDA, ONE, C, LDC ) +C +C D <- D + BV'*X*B/SCALE. +C + CALL DGEMM( 'N', 'N', PV, M, N, ONE, DWORK(KW), PV, + $ B, LDB, ONE, D, LDD ) + ELSE +C +C Compute X and SCALE satisfying +C +C AV'*X + X*A + SCALE*CV'*C = 0. +C + IF( N.GT.0 ) THEN + CALL DTRSYL( 'T', 'N', 1, NV, N, AV, LDAV, A, LDA, + $ DWORK, LDW, SCALE, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF + END IF +C +C Construct CS = DV'*C + BV'*X/SCALE, +C DS = DV'*D. +C Additional workspace needed: MAX( PV*N, PV*M ). +C +C Construct C <- DV'*C + BV'*X/SCALE. +C + CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) + CALL DGEMM( 'T', 'N', PV, N, NV, ONE / SCALE, BV, LDBV, + $ DWORK, LDW, ONE, C, LDC ) +C +C Construct D <- DV'*D. +C + CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) + END IF + ELSE +C +C Compute the projection of V*G. +C +C Total workspace needed: NV*N + MAX( PV*N, PV*M ). +C +C Compute -BV*C. +C Workspace needed: NV*N. +C + CALL DGEMM( 'N', 'N', NV, N, P, -ONE, BV, LDBV, C, LDC, + $ ZERO, DWORK, LDW ) +C +C Compute X and SCALE satisfying +C +C AV*X - X*A + SCALE*BV*C = 0. +C + IF( N.GT.0 ) THEN + CALL DTRSYL( 'N', 'N', -1, NV, N, AV, LDAV, A, LDA, + $ DWORK, LDW, SCALE, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF + END IF +C +C Construct CS = DV*C + CV*X/SCALE, +C DS = DV*D. +C Additional workspace needed: MAX( PV*N, PV*M ). +C +C Construct C <- DV*C + CV*X/SCALE. +C + CALL DGEMM( 'N', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) + CALL DGEMM( 'N', 'N', PV, N, NV, ONE / SCALE, CV, LDCV, + $ DWORK, LDW, ONE, C, LDC ) +C +C Construct D <- DV*D. +C + CALL DGEMM( 'N', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) + END IF + ELSE +C +C EV is a general matrix. +C + IF( NV.GT.0 ) THEN + TOLINF = TOLINF * DLANGE( '1', NV, NV, EV, LDEV, DWORK ) +C +C Reduce (AV,EV), or (AV',EV') or (EV',AV') to a generalized +C real Schur form using an orthogonal equivalence +C transformation and apply the orthogonal transformation +C appropriately to BV and CV, or CV' and BV'. +C +C Workspace needed: 2*NV*NV + MAX( 11*NV+16, NV*P, NV*PV ); +C prefer larger. +C + KQ = 1 + KZ = KQ + NV*NV + KAR = KZ + NV*NV + KAI = KAR + NV + KB = KAI + NV + KW = KB + NV +C + IF( CONJS ) THEN + STDOM = 'S' + ALPHA = ALPHA + SQRT( TOLINF ) +C +C Transpose AV and EV, if non-scalar. +C + DO 10 I = 1, NV - 1 + CALL DSWAP( NV-I, AV(I+1,I), 1, AV(I,I+1), LDAV ) + CALL DSWAP( NV-I, EV(I+1,I), 1, EV(I,I+1), LDEV ) + 10 CONTINUE +C + IF( DISCR ) THEN +C +C Reduce (EV',AV') to a generalized real Schur form +C using orthogonal transformation matrices Q and Z +C such that Q'*EV'*Z results in a quasi-triangular form +C and Q'*AV'*Z results upper triangular. +C Total workspace needed: 2*NV*NV + 11*NV + 16. +C + EVTYPE = 'R' + CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', + $ DELCTG, NV, EV, LDEV, AV, LDAV, SDIM, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ DWORK(KQ), LDW, DWORK(KZ), LDW, + $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) + ELSE +C +C Reduce (AV',EV') to a generalized real Schur form +C using orthogonal transformation matrices Q and Z +C such that Q'*AV'*Z results in a quasi-triangular form +C and Q'*EV'*Z results upper triangular. +C Total workspace needed: 2*NV*NV + 11*NV + 16. +C + EVTYPE = 'G' + CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', + $ DELCTG, NV, AV, LDAV, EV, LDEV, SDIM, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ DWORK(KQ), LDW, DWORK(KZ), LDW, + $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) + END IF + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + IF( STABCK ) THEN +C +C Check stability/antistability of generalized +C eigenvalues of the pair (AV,EV). +C + CALL AB09JX( DICO, STDOM, EVTYPE, NV, ALPHA, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ TOLINF, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C +C Compute Z'*BV and CV*Q. +C Total workspace needed: 2*NV*NV + NV*MAX(P,PV). +C + KW = KAR + CALL DLACPY( 'Full', NV, PV, BV, LDBV, DWORK(KW), LDW ) + CALL DGEMM( 'T', 'N', NV, PV, NV, ONE, DWORK(KZ), LDW, + $ DWORK(KW), LDW, ZERO, BV, LDBV ) + CALL DLACPY( 'Full', P, NV, CV, LDCV, DWORK(KW), P ) + CALL DGEMM( 'N', 'N', P, NV, NV, ONE, DWORK(KW), P, + $ DWORK(KQ), LDW, ZERO, CV, LDCV ) + ELSE +C +C Reduce (AV,EV) to a generalized real Schur form +C using orthogonal transformation matrices Q and Z +C such that Q'*AV*Z results in a quasi-triangular form +C and Q'*EV*Z results upper triangular. +C Total workspace needed: 2*NV*NV + 11*NV + 16. +C + STDOM = 'U' + EVTYPE = 'G' + ALPHA = ALPHA - SQRT( TOLINF ) + CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', + $ DELCTG, NV, AV, LDAV, EV, LDEV, SDIM, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ DWORK(KQ), LDW, DWORK(KZ), LDW, + $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + IF( STABCK ) THEN +C +C Check stability/antistability of generalized +C eigenvalues of the pair (AV,EV). +C + CALL AB09JX( DICO, STDOM, EVTYPE, NV, ALPHA, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ TOLINF, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C +C Compute Q'*BV and CV*Z. +C Total workspace needed: 2*NV*NV + NV*MAX(P,PV). +C + KW = KAR + CALL DLACPY( 'Full', NV, P, BV, LDBV, DWORK(KW), LDW ) + CALL DGEMM( 'T', 'N', NV, P, NV, ONE, DWORK(KQ), LDW, + $ DWORK(KW), LDW, ZERO, BV, LDBV ) + CALL DLACPY( 'Full', PV, NV, CV, LDCV, DWORK(KW), PV ) + CALL DGEMM( 'N', 'N', PV, NV, NV, ONE, DWORK(KW), PV, + $ DWORK(KZ), LDW, ZERO, CV, LDCV ) + END IF + WORK = MAX( WORK, DBLE( 2*NV*NV + NV*MAX( P, PV ) ) ) +C + END IF +C + KC = 1 + KF = KC + NV*N + KE = KF + NV*N + KW = KE + N*N + CALL DLASET( 'Full', NV, N, ZERO, ZERO, DWORK(KF), LDW ) +C + IF( CONJS ) THEN +C +C Compute the projection of conj(V)*G. +C +C Total workspace needed: NV*N + MAX( NV*N+N*N, PV*N, PV*M ) +C +C Compute CV'*C. +C Workspace needed: NV*N. +C + CALL DGEMM( 'T', 'N', NV, N, P, ONE, CV, LDCV, C, LDC, + $ ZERO, DWORK(KC), LDW ) +C + IF( DISCR ) THEN +C +C Compute X and SCALE satisfying +C +C EV'*X - AV'*X*A = SCALE*CV'*C by solving equivalently +C +C EV'*X - Y*A = SCALE*CV'*C, +C AV'*X - Y = 0. +C +C Additional workspace needed: +C real NV*N + N*N; +C integer NV+N+6. +C + IF( N.GT.0 ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN + $ ) + CALL DTGSYL( 'N', 0, NV, N, EV, LDEV, A, LDA, + $ DWORK(KC), LDW, AV, LDAV, DWORK(KE), + $ LDWN, DWORK(KF), LDW, SCALE, DIF, + $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + END IF +C +C Construct C <- DV'*C + BV'*X*A/SCALE, +C D <- DV'*D + BV'*X*B/SCALE. +C +C Additional workspace needed: MAX( PV*N, PV*M ). +C +C C <- DV'*C. +C + KW = KF + CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) +C +C D <- DV'*D. +C + CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) +C +C C <- C + BV'*X*A/SCALE. +C + CALL DGEMM( 'T', 'N', PV, N, NV, ONE / SCALE, BV, LDBV, + $ DWORK(KC), LDW, ZERO, DWORK(KW), PV ) + CALL DGEMM( 'N', 'N', PV, N, N, ONE, DWORK(KW), PV, + $ A, LDA, ONE, C, LDC ) +C +C D <- D + BV'*X*B/SCALE. +C + CALL DGEMM( 'N', 'N', PV, M, N, ONE, DWORK(KW), PV, + $ B, LDB, ONE, D, LDD ) + ELSE +C +C Compute X and SCALE satisfying +C +C AV'*X + EV'*X*A + SCALE*CV'*C = 0 by solving equivalently +C +C AV'*X - Y*A = -SCALE*CV'*C, +C EV'*X - Y*(-I) = 0. +C +C Additional workspace needed: +C real NV*N+N*N; +C integer NV+N+6. +C + IF( N.GT.0 ) THEN + CALL DLASET( 'Full', N, N, ZERO, -ONE, DWORK(KE), LDWN + $ ) + CALL DTGSYL( 'N', 0, NV, N, AV, LDAV, A, LDA, + $ DWORK(KC), LDW, EV, LDEV, DWORK(KE), + $ LDWN, DWORK(KF), LDW, SCALE, DIF, + $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) +C +C Note that the computed solution in DWORK(KC) is -X. +C + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + END IF +C +C Construct C <- DV'*C + BV'*X/SCALE. +C + KW = KF + CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) + CALL DGEMM( 'T', 'N', PV, N, NV, -ONE / SCALE, BV, LDBV, + $ DWORK(KC), LDW, ONE, C, LDC ) +C +C Construct D <- DV'*D. +C + CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) + END IF + ELSE +C +C Compute the projection of V*G. +C +C Total workspace needed: NV*N + MAX( NV*N+N*N, PV*N, PV*M ) +C +C Compute -BV*C. +C Workspace needed: NV*N. +C + CALL DGEMM( 'N', 'N', NV, N, P, -ONE, BV, LDBV, C, LDC, + $ ZERO, DWORK, LDW ) +C +C Compute X and SCALE satisfying +C +C AV*X - EV*X*A + SCALE*BV*C = 0 by solving equivalently +C +C AV*X - Y*A = -SCALE*BV*C, +C EV*X - Y = 0. +C +C Additional workspace needed: +C real NV*N + N*N; +C integer NV+N+6. +C + IF( N.GT.0 ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN ) + CALL DTGSYL( 'N', 0, NV, N, AV, LDAV, A, LDA, + $ DWORK(KC), LDW, EV, LDEV, DWORK(KE), LDWN, + $ DWORK(KF), LDW, SCALE, DIF, DWORK(KW), + $ LDWORK-KW+1, IWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + END IF +C +C Construct C <- DV*C + CV*X/SCALE. +C + KW = KF + CALL DGEMM( 'N', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) + CALL DGEMM( 'N', 'N', PV, N, NV, ONE / SCALE, CV, LDCV, + $ DWORK, LDW, ONE, C, LDC ) +C +C Construct D <- DV*D. +C + CALL DGEMM( 'N', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) + END IF + END IF +C + DWORK(1) = MAX( WORK, DBLE( LW ) ) +C + RETURN +C *** Last line of AB09JV *** + END diff --git a/mex/sources/libslicot/AB09JW.f b/mex/sources/libslicot/AB09JW.f new file mode 100644 index 000000000..9c8068428 --- /dev/null +++ b/mex/sources/libslicot/AB09JW.f @@ -0,0 +1,972 @@ + SUBROUTINE AB09JW( JOB, DICO, JOBEW, STBCHK, N, M, P, NW, MW, + $ A, LDA, B, LDB, C, LDC, D, LDD, AW, LDAW, + $ EW, LDEW, BW, LDBW, CW, LDCW, DW, LDDW, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct a state-space representation (A,BS,CS,DS) of the +C projection of G*W or G*conj(W) containing the poles of G, from the +C state-space representations (A,B,C,D) and (AW-lambda*EW,BW,CW,DW), +C of the transfer-function matrices G and W, respectively. +C G is assumed to be a stable transfer-function matrix and +C the state matrix A must be in a real Schur form. +C When computing the stable projection of G*W, it is assumed +C that G and W have completely distinct poles. +C When computing the stable projection of G*conj(W), it is assumed +C that G and conj(W) have completely distinct poles. +C +C Note: For a transfer-function matrix G, conj(G) denotes the +C conjugate of G given by G'(-s) for a continuous-time system or +C G'(1/z) for a discrete-time system. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the projection to be computed as follows: +C = 'W': compute the projection of G*W containing +C the poles of G; +C = 'C': compute the projection of G*conj(W) containing +C the poles of G. +C +C DICO CHARACTER*1 +C Specifies the type of the systems as follows: +C = 'C': G and W are continuous-time systems; +C = 'D': G and W are discrete-time systems. +C +C JOBEW CHARACTER*1 +C Specifies whether EW is a general square or an identity +C matrix as follows: +C = 'G': EW is a general square matrix; +C = 'I': EW is the identity matrix. +C +C STBCHK CHARACTER*1 +C Specifies whether stability/antistability of W is to be +C checked as follows: +C = 'C': check stability if JOB = 'C' or antistability if +C JOB = 'W'; +C = 'N': do not check stability or antistability. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the state vector of the system with +C the transfer-function matrix G. N >= 0. +C +C M (input) INTEGER +C The dimension of the input vector of the system with +C the transfer-function matrix G, and also the dimension +C of the output vector if JOB = 'W', or of the input vector +C if JOB = 'C', of the system with the transfer-function +C matrix W. M >= 0. +C +C P (input) INTEGER +C The dimension of the output vector of the system with the +C transfer-function matrix G. P >= 0. +C +C NW (input) INTEGER +C The dimension of the state vector of the system with the +C transfer-function matrix W. NW >= 0. +C +C MW (input) INTEGER +C The dimension of the input vector, if JOB = 'W', or of +C the output vector, if JOB = 'C', of the system with the +C transfer-function matrix W. MW >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the system with the transfer-function +C matrix G in a real Schur form. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, +C dimension (LDB,MAX(M,MW)) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B of the system with the +C transfer-function matrix G. +C On exit, if INFO = 0, the leading N-by-MW part of this +C array contains the input matrix BS of the projection of +C G*W, if JOB = 'W', or of G*conj(W), if JOB = 'C'. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain +C the output/state matrix C of the system with the +C transfer-function matrix G. The matrix CS is equal to C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, +C dimension (LDB,MAX(M,MW)) +C On entry, the leading P-by-M part of this array must +C contain the feedthrough matrix D of the system with +C the transfer-function matrix G. +C On exit, if INFO = 0, the leading P-by-MW part of +C this array contains the feedthrough matrix DS of the +C projection of G*W, if JOB = 'W', or of G*conj(W), +C if JOB = 'C'. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= MAX(1,P). +C +C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) +C On entry, the leading NW-by-NW part of this array must +C contain the state matrix AW of the system with the +C transfer-function matrix W. +C On exit, if INFO = 0, the leading NW-by-NW part of this +C array contains a condensed matrix as follows: +C if JOBEW = 'I', it contains the real Schur form of AW; +C if JOBEW = 'G' and JOB = 'W', it contains a quasi-upper +C triangular matrix representing the real Schur matrix +C in the real generalized Schur form of the pair (AW,EW); +C if JOBEW = 'G', JOB = 'C' and DICO = 'C', it contains a +C quasi-upper triangular matrix corresponding to the +C generalized real Schur form of the pair (AW',EW'); +C if JOBEW = 'G', JOB = 'C' and DICO = 'D', it contains an +C upper triangular matrix corresponding to the generalized +C real Schur form of the pair (EW',AW'). +C +C LDAW INTEGER +C The leading dimension of the array AW. LDAW >= MAX(1,NW). +C +C EW (input/output) DOUBLE PRECISION array, dimension (LDEW,NW) +C On entry, if JOBEW = 'G', the leading NW-by-NW part of +C this array must contain the descriptor matrix EW of the +C system with the transfer-function matrix W. +C If JOBEW = 'I', EW is assumed to be an identity matrix +C and is not referenced. +C On exit, if INFO = 0 and JOBEW = 'G', the leading NW-by-NW +C part of this array contains a condensed matrix as follows: +C if JOB = 'W', it contains an upper triangular matrix +C corresponding to the real generalized Schur form of the +C pair (AW,EW); +C if JOB = 'C' and DICO = 'C', it contains an upper +C triangular matrix corresponding to the generalized real +C Schur form of the pair (AW',EW'); +C if JOB = 'C' and DICO = 'D', it contains a quasi-upper +C triangular matrix corresponding to the generalized +C real Schur form of the pair (EW',AW'). +C +C LDEW INTEGER +C The leading dimension of the array EW. +C LDEW >= MAX(1,NW), if JOBEW = 'G'; +C LDEW >= 1, if JOBEW = 'I'. +C +C BW (input/output) DOUBLE PRECISION array, +C dimension (LDBW,MBW), where MBW = MW, if JOB = 'W', and +C MBW = M, if JOB = 'C'. +C On entry, the leading NW-by-MBW part of this array must +C contain the input matrix BW of the system with the +C transfer-function matrix W. +C On exit, if INFO = 0, the leading NW-by-MBW part of this +C array contains Q'*BW, where Q is the orthogonal matrix +C that reduces AW to the real Schur form or the left +C orthogonal matrix used to reduce the pair (AW,EW), +C (AW',EW') or (EW',AW') to the generalized real Schur form. +C +C LDBW INTEGER +C The leading dimension of the array BW. LDBW >= MAX(1,NW). +C +C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) +C On entry, the leading PCW-by-NW part of this array must +C contain the output matrix CW of the system with the +C transfer-function matrix W, where PCW = M if JOB = 'W' or +C PCW = MW if JOB = 'C'. +C On exit, if INFO = 0, the leading PCW-by-NW part of this +C array contains CW*Q, where Q is the orthogonal matrix that +C reduces AW to the real Schur form, or CW*Z, where Z is the +C right orthogonal matrix used to reduce the pair (AW,EW), +C (AW',EW') or (EW',AW') to the generalized real Schur form. +C +C LDCW INTEGER +C The leading dimension of the array CW. +C LDCW >= MAX(1,PCW), where PCW = M if JOB = 'W', or +C PCW = MW if JOB = 'C'. +C +C DW (input) DOUBLE PRECISION array, +C dimension (LDDW,MBW), where MBW = MW if JOB = 'W', and +C MBW = M if JOB = 'C'. +C The leading PCW-by-MBW part of this array must contain +C the feedthrough matrix DW of the system with the +C transfer-function matrix W, where PCW = M if JOB = 'W', +C or PCW = MW if JOB = 'C'. +C +C LDDW INTEGER +C LDDW >= MAX(1,PCW), where PCW = M if JOB = 'W', or +C PCW = MW if JOB = 'C'. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = 0, if JOBEW = 'I'; +C LIWORK = NW+N+6, if JOBEW = 'G'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= LW1, if JOBEW = 'I', +C LDWORK >= LW2, if JOBEW = 'G', where +C LW1 = MAX( 1, NW*(NW+5), NW*N + MAX( a, N*MW, P*MW ) ) +C a = 0, if DICO = 'C' or JOB = 'W', +C a = 2*NW, if DICO = 'D' and JOB = 'C'; +C LW2 = MAX( 2*NW*NW + MAX( 11*NW+16, NW*M, MW*NW ), +C NW*N + MAX( NW*N+N*N, MW*N, P*MW ) ). +C For good performance, LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of the pair (AW,EW) to the real +C generalized Schur form failed (JOBEW = 'G'), +C or the reduction of the matrix AW to the real +C Schur form failed (JOBEW = 'I); +C = 2: the solution of the Sylvester equation failed +C because the matrix A and the pencil AW-lambda*EW +C have common eigenvalues (if JOB = 'W'), or the +C pencil -AW-lambda*EW and A have common eigenvalues +C (if JOB = 'C' and DICO = 'C'), or the pencil +C AW-lambda*EW has an eigenvalue which is the +C reciprocal of one of eigenvalues of A +C (if JOB = 'C' and DICO = 'D'); +C = 3: the solution of the Sylvester equation failed +C because the matrices A and AW have common +C eigenvalues (if JOB = 'W'), or the matrices A +C and -AW have common eigenvalues (if JOB = 'C' and +C DICO = 'C'), or the matrix A has an eigenvalue +C which is the reciprocal of one of eigenvalues of AW +C (if JOB = 'C' and DICO = 'D'); +C = 4: JOB = 'W' and the pair (AW,EW) has not completely +C unstable generalized eigenvalues, or JOB = 'C' and +C the pair (AW,EW) has not completely stable +C generalized eigenvalues. +C +C METHOD +C +C If JOB = 'W', the matrices of the stable projection of G*W are +C computed as +C +C BS = B*DW + Y*BW, CS = C, DS = D*DW, +C +C where Y satisfies the generalized Sylvester equation +C +C -A*Y*EW + Y*AW + B*CW = 0. +C +C If JOB = 'C', the matrices of the stable projection of G*conj(W) +C are computed using the following formulas: +C +C - for a continuous-time system, the matrices BS, CS and DS of +C the stable projection are computed as +C +C BS = B*DW' + Y*CW', CS = C, DS = D*DW', +C +C where Y satisfies the generalized Sylvester equation +C +C A*Y*EW' + Y*AW' + B*BW' = 0. +C +C - for a discrete-time system, the matrices BS, CS and DS of +C the stable projection are computed as +C +C BS = B*DW' + A*Y*CW', CS = C, DS = D*DW' + C*Y*CW', +C +C where Y satisfies the generalized Sylvester equation +C +C Y*EW' - A*Y*AW' = B*BW'. +C +C REFERENCES +C +C [1] Varga, A. +C Efficient and numerically reliable implementation of the +C frequency-weighted Hankel-norm approximation model reduction +C approach. +C Proc. 2001 ECC, Porto, Portugal, 2001. +C +C [2] Zhou, K. +C Frequency-weighted H-infinity norm and optimal Hankel norm +C model reduction. +C IEEE Trans. Autom. Control, vol. 40, pp. 1687-1699, 1995. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on numerically stable algorithms. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. +C D. Sima, University of Bucharest, March 2001. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. +C +C REVISIONS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. +C V. Sima, Research Institute for Informatics, Bucharest, June 2001. +C A. Varga, German Aerospace Center, Oberpfaffenhofen, Nov. 2003. +C +C KEYWORDS +C +C Frequency weighting, model reduction, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOB, JOBEW, STBCHK + INTEGER INFO, LDA, LDAW, LDB, LDBW, LDC, LDCW, + $ LDD, LDDW, LDEW, LDWORK, M, MW, N, NW, P +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), AW(LDAW,*), B(LDB,*), BW(LDBW,*), + $ C(LDC,*), CW(LDCW,*), D(LDD,*), DW(LDDW,*), + $ DWORK(*), EW(LDEW,*) +C .. Local Scalars .. + CHARACTER*1 EVTYPE, STDOM + LOGICAL CONJS, DISCR, STABCK, UNITEW + DOUBLE PRECISION ALPHA, DIF, SCALE, TOLINF, WORK + INTEGER I, IA, IERR, KAI, KAR, KB, KC, KE, KF, KQ, KW, + $ KZ, LDW, LDWM, LDWN, LDWP, LW, SDIM +C .. Local Arrays .. + LOGICAL BWORK(1) +C .. External Functions .. + LOGICAL DELCTG, LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DELCTG, DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL AB09JX, DGEMM, DGGES, DLACPY, DLASET, DSWAP, + $ DTGSYL, DTRSYL, SB04PY, TB01WD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, SQRT +C +C .. Executable Statements .. +C + CONJS = LSAME( JOB, 'C' ) + DISCR = LSAME( DICO, 'D' ) + UNITEW = LSAME( JOBEW, 'I' ) + STABCK = LSAME( STBCHK, 'C' ) +C + INFO = 0 + IF( UNITEW ) THEN + IF ( DISCR .AND. CONJS ) THEN + IA = 2*NW + ELSE + IA = 0 + END IF + LW = MAX( 1, NW*( NW + 5 ), NW*N + MAX( IA, N*MW, P*MW ) ) + ELSE + LW = MAX( 2*NW*NW + MAX( 11*NW+16, NW*M, MW*NW ), + $ NW*N + MAX( NW*N + N*N, MW*N, P*MW ) ) + END IF +C +C Test the input scalar arguments. +C + LDW = MAX( 1, NW ) + LDWM = MAX( 1, MW ) + LDWN = MAX( 1, N ) + LDWP = MAX( 1, P ) + IF( .NOT. ( LSAME( JOB, 'W' ) .OR. CONJS ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( JOBEW, 'G' ) .OR. UNITEW ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( LSAME( STBCHK, 'N' ) .OR. STABCK ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( NW.LT.0 ) THEN + INFO = -8 + ELSE IF( MW.LT.0 ) THEN + INFO = -9 + ELSE IF( LDA.LT.LDWN ) THEN + INFO = -11 + ELSE IF( LDB.LT.LDWN ) THEN + INFO = -13 + ELSE IF( LDC.LT.LDWP ) THEN + INFO = -15 + ELSE IF( LDD.LT.LDWP ) THEN + INFO = -17 + ELSE IF( LDAW.LT.LDW ) THEN + INFO = -19 + ELSE IF( LDEW.LT.1 .OR. ( .NOT.UNITEW .AND. LDEW.LT.NW ) ) THEN + INFO = -21 + ELSE IF( LDBW.LT.LDW ) THEN + INFO = -23 + ELSE IF( ( .NOT.CONJS .AND. LDCW.LT.MAX( 1, M ) ) .OR. + $ ( CONJS .AND. LDCW.LT.LDWM ) ) THEN + INFO = -25 + ELSE IF( ( .NOT.CONJS .AND. LDDW.LT.MAX( 1, M ) ) .OR. + $ ( CONJS .AND. LDDW.LT.LDWM ) ) THEN + INFO = -27 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -30 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09JW', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( M.EQ.0 ) THEN + CALL DLASET( 'Full', N, MW, ZERO, ZERO, B, LDB ) + CALL DLASET( 'Full', P, MW, ZERO, ZERO, D, LDD ) + DWORK(1) = ONE + RETURN + END IF +C +C Set options for stability/antistability checking. +C + IF( DISCR ) THEN + ALPHA = ONE + ELSE + ALPHA = ZERO + END IF +C + WORK = ONE + TOLINF = DLAMCH( 'Epsilon' ) +C + IF( UNITEW ) THEN +C +C EW is the identity matrix. +C + IF( NW.GT.0 ) THEN +C +C Reduce AW to the real Schur form using an orthogonal +C similarity transformation AW <- Q'*AW*Q and apply the +C transformation to BW and CW: BW <- Q'*BW and CW <- CW*Q. +C +C Workspace needed: NW*(NW+5); +C prefer larger. +C + KW = NW*( NW + 2 ) + 1 + IF( CONJS ) THEN + STDOM = 'S' + ALPHA = ALPHA + SQRT( TOLINF ) + CALL TB01WD( NW, M, MW, AW, LDAW, BW, LDBW, CW, LDCW, + $ DWORK(2*NW+1), NW, DWORK, DWORK(NW+1), + $ DWORK(KW), LDWORK-KW+1, IERR ) + ELSE + STDOM = 'U' + ALPHA = ALPHA - SQRT( TOLINF ) + CALL TB01WD( NW, MW, M, AW, LDAW, BW, LDBW, CW, LDCW, + $ DWORK(2*NW+1), NW, DWORK, DWORK(NW+1), + $ DWORK(KW), LDWORK-KW+1, IERR ) + END IF + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + IF( STABCK ) THEN +C +C Check stability/antistability of eigenvalues of AV. +C + CALL AB09JX( DICO, STDOM, 'S', NW, ALPHA, DWORK, + $ DWORK(NW+1), DWORK, TOLINF, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + END IF +C + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C + END IF +C + KW = NW*N + 1 + IF( CONJS ) THEN +C +C Compute the projection of G*conj(W). +C +C Total workspace needed: NW*N + MAX( a, N*MW, P*MW ), where +C a = 0, if DICO = 'C', +C a = 2*NW, if DICO = 'D'. +C +C Compute -BW*B'. +C Workspace needed: NW*N. +C + CALL DGEMM( 'N', 'T', NW, N, M, -ONE, BW, LDBW, B, LDB, + $ ZERO, DWORK, LDW ) +C + IF( DISCR ) THEN +C +C Compute Y' and SCALE satisfying +C +C AW*Y'*A' - Y' = -SCALE*BW*B'. +C +C Additional workspace needed: 2*NW. +C + CALL SB04PY( 'N', 'T', -1, NW, N, AW, LDAW, A, LDA, + $ DWORK, LDW, SCALE, DWORK(KW), IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C +C Construct BS = B*DW' + A*Y*CW'/SCALE, +C DS = D*DW' + C*Y*CW'/SCALE. +C +C Additional workspace needed: MAX( N*MW, P*MW ). +C +C B <- B*DW'. +C + CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) +C +C D <- D*DW'. +C + CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), LDWP ) + CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) +C +C B <- B + A*Y*CW'/SCALE. +C + CALL DGEMM( 'T', 'T', N, MW, NW, ONE / SCALE, DWORK, LDW, + $ CW, LDCW, ZERO, DWORK(KW), LDWN ) + CALL DGEMM( 'N', 'N', N, MW, N, ONE, A, LDA, + $ DWORK(KW), LDWN, ONE, B, LDB ) +C +C D <- D + C*Y*CW'/SCALE. +C + CALL DGEMM( 'N', 'N', P, MW, N, ONE, C, LDC, + $ DWORK(KW), LDWN, ONE, D, LDD ) + ELSE +C +C Compute Y' and SCALE satisfying +C +C AW*Y' + Y'*A' + SCALE*BW*B' = 0. +C + IF( N.GT.0 ) THEN + CALL DTRSYL( 'N', 'T', 1, NW, N, AW, LDAW, A, LDA, + $ DWORK, LDW, SCALE, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF + END IF +C +C Construct BS = B*DW' + Y*CW'/SCALE, +C DS = D*DW'. +C +C Additional workspace needed: MAX( N*MW, P*MW ). +C +C Construct B <- B*DW' + Y*CW'/SCALE. +C + CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) + CALL DGEMM( 'T', 'T', N, MW, NW, ONE / SCALE, DWORK, LDW, + $ CW, LDCW, ONE, B, LDB) +C +C D <- D*DW'. +C + CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), LDWP ) + CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) + END IF + ELSE +C +C Compute the projection of G*W. +C +C Total workspace needed: NW*N + MAX( N*MW, P*MW ). +C +C Compute B*CW. +C Workspace needed: N*NW. +C + CALL DGEMM( 'N', 'N', N, NW, M, ONE, B, LDB, CW, LDCW, + $ ZERO, DWORK, LDWN ) +C +C Compute Y and SCALE satisfying +C +C A*Y - Y*AW - SCALE*B*CW = 0. +C + IF( N.GT.0 ) THEN + CALL DTRSYL( 'N', 'N', -1, N, NW, A, LDA, AW, LDAW, + $ DWORK, LDWN, SCALE, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF + END IF +C +C Construct BS = B*DW + Y*BW/SCALE, +C DS = D*DW. +C +C Additional workspace needed: MAX( N*MW, P*MW ). +C Construct B <- B*DW + Y*BW/SCALE. +C + CALL DGEMM( 'N', 'N', N, MW, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) + CALL DGEMM( 'N', 'N', N, MW, NW, ONE / SCALE, DWORK, LDWN, + $ BW, LDBW, ONE, B, LDB) +C +C D <- D*DW. +C + CALL DGEMM( 'N', 'N', P, MW, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), LDWP ) + CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) + END IF + ELSE +C +C EW is a general matrix. +C + IF( NW.GT.0 ) THEN + TOLINF = TOLINF * DLANGE( '1', NW, NW, EW, LDEW, DWORK ) +C +C Reduce (AW,EW), or (AW',EW') or (EW',AW') to a generalized +C real Schur form using an orthogonal equivalence +C transformation and apply the orthogonal transformation +C appropriately to BW and CW, or CW' and BW'. +C +C Workspace needed: 2*NW*NW + MAX( 11*NW+16, NW*M, MW*NW ); +C prefer larger. +C + KQ = 1 + KZ = KQ + NW*NW + KAR = KZ + NW*NW + KAI = KAR + NW + KB = KAI + NW + KW = KB + NW +C + IF( CONJS ) THEN + STDOM = 'S' + ALPHA = ALPHA + SQRT( TOLINF ) +C +C Transpose AW and EW, if non-scalar. +C + DO 10 I = 1, NW - 1 + CALL DSWAP( NW-I, AW(I+1,I), 1, AW(I,I+1), LDAW ) + CALL DSWAP( NW-I, EW(I+1,I), 1, EW(I,I+1), LDEW ) + 10 CONTINUE +C + IF( DISCR ) THEN +C +C Reduce (EW',AW') to a generalized real Schur form +C using orthogonal transformation matrices Q and Z +C such that Q'*EW'*Z results in a quasi-triangular form +C and Q'*AW'*Z results upper triangular. +C Total workspace needed: 2*NW*NW + 11*NW + 16. +C + EVTYPE = 'R' + CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', + $ DELCTG, NW, EW, LDEW, AW, LDAW, SDIM, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ DWORK(KQ), LDW, DWORK(KZ), LDW, + $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) + ELSE +C +C Reduce (AW',EW') to a generalized real Schur form +C using orthogonal transformation matrices Q and Z +C such that Q'*AW'*Z results in a quasi-triangular form +C and Q'*EW'*Z results upper triangular. +C Total workspace needed: 2*NW*NW + 11*NW + 16. +C + EVTYPE = 'G' + CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', + $ DELCTG, NW, AW, LDAW, EW, LDEW, SDIM, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ DWORK(KQ), LDW, DWORK(KZ), LDW, + $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) + END IF + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + IF( STABCK ) THEN +C +C Check stability/antistability of generalized +C eigenvalues of the pair (AV,EV). +C + CALL AB09JX( DICO, STDOM, EVTYPE, NW, ALPHA, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ TOLINF, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C +C Compute Z'*BW and CW*Q. +C Total workspace needed: 2*NW*NW + NW*MAX(M,MW). +C + KW = KAR + CALL DLACPY( 'Full', NW, M, BW, LDBW, DWORK(KW), LDW ) + CALL DGEMM( 'T', 'N', NW, M, NW, ONE, DWORK(KZ), LDW, + $ DWORK(KW), LDW, ZERO, BW, LDBW ) + CALL DLACPY( 'Full', MW, NW, CW, LDCW, DWORK(KW), LDWM ) + CALL DGEMM( 'N', 'N', MW, NW, NW, ONE, DWORK(KW), LDWM, + $ DWORK(KQ), LDW, ZERO, CW, LDCW ) + ELSE +C +C Reduce (AW,EW) to a generalized real Schur form +C using orthogonal transformation matrices Q and Z +C such that Q'*AW*Z results in a quasi-triangular form +C and Q'*EW*Z results upper triangular. +C Total workspace needed: 2*NW*NW + 11*NW + 16. +C + STDOM = 'U' + EVTYPE = 'G' + ALPHA = ALPHA - SQRT( TOLINF ) + CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', + $ DELCTG, NW, AW, LDAW, EW, LDEW, SDIM, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ DWORK(KQ), LDW, DWORK(KZ), LDW, + $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + IF( STABCK ) THEN +C +C Check stability/antistability of generalized +C eigenvalues of the pair (AV,EV). +C + CALL AB09JX( DICO, STDOM, EVTYPE, NW, ALPHA, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ TOLINF, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C +C Compute Q'*BW and CW*Z. +C Total workspace needed: 2*NW*NW + NW*MAX(M,MW). +C + KW = KAR + CALL DLACPY( 'Full', NW, MW, BW, LDBW, DWORK(KW), LDW ) + CALL DGEMM( 'T', 'N', NW, MW, NW, ONE, DWORK(KQ), LDW, + $ DWORK(KW), LDW, ZERO, BW, LDBW ) + CALL DLACPY( 'Full', M, NW, CW, LDCW, DWORK(KW), M ) + CALL DGEMM( 'N', 'N', M, NW, NW, ONE, DWORK(KW), M, + $ DWORK(KZ), LDW, ZERO, CW, LDCW ) + END IF + WORK = MAX( WORK, DBLE( 2*NW*NW + NW*MAX( M, MW ) ) ) +C + END IF +C + KC = 1 + KF = KC + NW*N + KE = KF + NW*N + KW = KE + N*N + CALL DLASET( 'Full', N, NW, ZERO, ZERO, DWORK(KF), LDWN ) +C + IF( CONJS ) THEN +C +C Compute the projection of G*conj(W). +C +C Total workspace needed: NW*N + MAX( NW*N+N*N, MW*N, P*MW ) +C +C Compute B*BW'. +C Workspace needed: N*NW. +C + CALL DGEMM( 'N', 'T', N, NW, M, ONE, B, LDB, BW, LDBW, + $ ZERO, DWORK(KC), LDWN ) +C + IF( DISCR ) THEN +C +C Compute Y and SCALE satisfying +C +C Y*EW' - A*Y*AW' = SCALE*B*BW' by solving equivalently +C +C A*X - Y*EW' = -SCALE*B*BW', +C X - Y*AW' = 0. +C +C Additional workspace needed: +C real N*NW + N*N; +C integer NW+N+6. +C +C + IF( N.GT.0 ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN + $ ) + CALL DTGSYL( 'N', 0, N, NW, A, LDA, EW, LDEW, + $ DWORK(KC), LDWN, DWORK(KE), LDWN, AW, + $ LDAW, DWORK(KF), LDWN, SCALE, DIF, + $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) +C +C Note that the computed solution in DWORK(KC) is -Y. +C + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + END IF +C +C Construct BS = B*DW' + A*Y*CW'/SCALE, +C DS = D*DW' + C*Y*CW'/SCALE. +C +C Additional workspace needed: MAX( N*MW, P*MW ). +C +C B <- B*DW'. +C + CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) +C +C D <- D*DW'. +C + CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), LDWP ) + CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) +C +C B <- B + A*Y*CW'/SCALE. +C + CALL DGEMM( 'N', 'T', N, MW, NW, -ONE / SCALE, + $ DWORK(KF), LDWN, CW, LDCW, ZERO, + $ DWORK(KW), LDWN ) + CALL DGEMM( 'N', 'N', N, MW, N, ONE, A, LDA, + $ DWORK(KW), LDWN, ONE, B, LDB ) +C +C D <- D + C*Y*CW'/SCALE. +C + CALL DGEMM( 'N', 'N', P, MW, N, ONE, C, LDC, + $ DWORK(KW), LDWN, ONE, D, LDD ) + ELSE +C +C Compute Y and SCALE satisfying +C +C A*Y*EW' + Y*AW' + SCALE*B*BW' = 0 by solving equivalently +C +C A*X - Y*AW' = SCALE*B*BW', +C (-I)*X - Y*EW' = 0. +C +C Additional workspace needed: +C real N*NW+N*N; +C integer NW+N+6. +C + IF( N.GT.0 ) THEN + CALL DLASET( 'Full', N, N, ZERO, -ONE, DWORK(KE), LDWN + $ ) + CALL DTGSYL( 'N', 0, N, NW, A, LDA, AW, LDAW, + $ DWORK(KC), LDWN, DWORK(KE), LDWN, EW, + $ LDEW, DWORK(KF), LDWN, SCALE, DIF, + $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + END IF +C +C Construct BS = B*DW' + Y*CW'/SCALE, +C DS = D*DW'. +C +C Additional workspace needed: MAX( N*MW, P*MW ). +C +C Construct B <- B*DW' + Y*CW'/SCALE. +C + CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) + CALL DGEMM( 'N', 'T', N, MW, NW, ONE / SCALE, + $ DWORK(KF), LDWN, CW, LDCW, ONE, B, LDB ) +C +C D <- D*DW'. +C + CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), LDWP ) + CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) + END IF + ELSE +C +C Compute the projection of G*W. +C +C Total workspace needed: NW*N + MAX( NW*N+N*N, MW*N, P*MW ) +C +C Compute B*CW. +C Workspace needed: N*NW. +C + CALL DGEMM( 'N', 'N', N, NW, M, ONE, B, LDB, CW, LDCW, + $ ZERO, DWORK(KC), LDWN ) +C +C Compute Y and SCALE satisfying +C +C -A*Y*EW + Y*AW + B*CW = 0 by solving equivalently +C +C A*X - Y*AW = SCALE*B*CW, +C X - Y*EW = 0. +C +C Additional workspace needed: +C real N*NW + N*N; +C integer NW+N+6. +C + IF( N.GT.0 ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN ) + CALL DTGSYL( 'N', 0, N, NW, A, LDA, AW, LDAW, + $ DWORK(KC), LDWN, DWORK(KE), LDWN, EW, LDEW, + $ DWORK(KF), LDWN, SCALE, DIF, DWORK(KW), + $ LDWORK-KW+1, IWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + END IF +C +C Construct BS = B*DW + Y*BW/SCALE, +C DS = D*DW. +C +C Additional workspace needed: MAX( N*MW, P*MW ). +C Construct B <- B*DW + Y*BW/SCALE. +C + CALL DGEMM( 'N', 'N', N, MW, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) + CALL DGEMM( 'N', 'N', N, MW, NW, ONE / SCALE, + $ DWORK(KF), LDWN, BW, LDBW, ONE, B, LDB) +C +C D <- D*DW. +C + CALL DGEMM( 'N', 'N', P, MW, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), LDWP ) + CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) + END IF + END IF +C + DWORK(1) = MAX( WORK, DBLE( LW ) ) +C + RETURN +C *** Last line of AB09JW *** + END diff --git a/mex/sources/libslicot/AB09JX.f b/mex/sources/libslicot/AB09JX.f new file mode 100644 index 000000000..68e2c60dd --- /dev/null +++ b/mex/sources/libslicot/AB09JX.f @@ -0,0 +1,253 @@ + SUBROUTINE AB09JX( DICO, STDOM, EVTYPE, N, ALPHA, ER, EI, ED, + $ TOLINF, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To check stability/antistability of finite eigenvalues with +C respect to a given stability domain. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the stability domain as follows: +C = 'C': for a continuous-time system; +C = 'D': for a discrete-time system. +C +C STDOM CHARACTER*1 +C Specifies whether the domain of interest is of stability +C type (left part of complex plane or inside of a circle) +C or of instability type (right part of complex plane or +C outside of a circle) as follows: +C = 'S': stability type domain; +C = 'U': instability type domain. +C +C EVTYPE CHARACTER*1 +C Specifies whether the eigenvalues arise from a standard +C or a generalized eigenvalue problem as follows: +C = 'S': standard eigenvalue problem; +C = 'G': generalized eigenvalue problem; +C = 'R': reciprocal generalized eigenvalue problem. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of vectors ER, EI and ED. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the boundary of the domain of interest for the +C eigenvalues. For a continuous-time system +C (DICO = 'C'), ALPHA is the boundary value for the real +C parts of eigenvalues, while for a discrete-time system +C (DICO = 'D'), ALPHA >= 0 represents the boundary value for +C the moduli of eigenvalues. +C +C ER, EI, (input) DOUBLE PRECISION arrays, dimension (N) +C ED If EVTYPE = 'S', ER(j) + EI(j)*i, j = 1,...,N, are +C the eigenvalues of a real matrix. +C ED is not referenced and is implicitly considered as +C a vector having all elements equal to one. +C If EVTYPE = 'G' or EVTYPE = 'R', (ER(j) + EI(j)*i)/ED(j), +C j = 1,...,N, are the generalized eigenvalues of a pair of +C real matrices. If ED(j) is zero, then the j-th generalized +C eigenvalue is infinite. +C Complex conjugate pairs of eigenvalues must appear +C consecutively. +C +C Tolerances +C +C TOLINF DOUBLE PRECISION +C If EVTYPE = 'G' or 'R', TOLINF contains the tolerance for +C detecting infinite generalized eigenvalues. +C 0 <= TOLINF < 1. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit, i.e., all eigenvalues lie within +C the domain of interest defined by DICO, STDOM +C and ALPHA; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: some eigenvalues lie outside the domain of interest +C defined by DICO, STDOM and ALPHA. +C METHOD +C +C The domain of interest for an eigenvalue lambda is defined by the +C parameters ALPHA, DICO and STDOM as follows: +C - for a continuous-time system (DICO = 'C'): +C Real(lambda) < ALPHA if STDOM = 'S'; +C Real(lambda) > ALPHA if STDOM = 'U'; +C - for a discrete-time system (DICO = 'D'): +C Abs(lambda) < ALPHA if STDOM = 'S'; +C Abs(lambda) > ALPHA if STDOM = 'U'. +C If EVTYPE = 'R', the same conditions apply for 1/lambda. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001. +C +C KEYWORDS +C +C Stability. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EVTYPE, STDOM + INTEGER INFO, N + DOUBLE PRECISION ALPHA, TOLINF +C .. Array Arguments .. + DOUBLE PRECISION ED(*), EI(*), ER(*) +C .. Local Scalars + LOGICAL DISCR, RECEVP, STAB, STDEVP + DOUBLE PRECISION ABSEV, RPEV, SCALE + INTEGER I +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + STAB = LSAME( STDOM, 'S' ) + STDEVP = LSAME( EVTYPE, 'S' ) + RECEVP = LSAME( EVTYPE, 'R' ) +C +C Check the scalar input arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( STAB .OR. LSAME( STDOM, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( STDEVP .OR. LSAME( EVTYPE, 'G' ) .OR. + $ RECEVP ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN + INFO = -5 + ELSE IF( TOLINF.LT.ZERO .OR. TOLINF.GE.ONE ) THEN + INFO = -9 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09JX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C + IF( STAB ) THEN +C +C Check the stability of finite eigenvalues. +C + SCALE = ONE + IF( DISCR ) THEN + DO 10 I = 1, N + ABSEV = DLAPY2( ER(I), EI(I) ) + IF( RECEVP ) THEN + SCALE = ABSEV + ABSEV = ABS( ED(I) ) + ELSE IF( .NOT.STDEVP ) THEN + SCALE = ED(I) + END IF + IF( ABS( SCALE ).GT.TOLINF .AND. + $ ABSEV.GE.ALPHA*SCALE ) THEN + INFO = 1 + RETURN + END IF + 10 CONTINUE + ELSE + DO 20 I = 1, N + RPEV = ER(I) + IF( RECEVP ) THEN + SCALE = RPEV + RPEV = ED(I) + ELSE IF( .NOT.STDEVP ) THEN + SCALE = ED(I) + END IF + IF( ABS( SCALE ).GT.TOLINF .AND. + $ RPEV.GE.ALPHA*SCALE ) THEN + INFO = 1 + RETURN + END IF + 20 CONTINUE + END IF + ELSE +C +C Check the anti-stability of finite eigenvalues. +C + IF( DISCR ) THEN + DO 30 I = 1, N + ABSEV = DLAPY2( ER(I), EI(I) ) + IF( RECEVP ) THEN + SCALE = ABSEV + ABSEV = ABS( ED(I) ) + ELSE IF( .NOT.STDEVP ) THEN + SCALE = ED(I) + END IF + IF( ABS( SCALE ).GT.TOLINF .AND. + $ ABSEV.LE.ALPHA*SCALE ) THEN + INFO = 1 + RETURN + END IF + 30 CONTINUE + ELSE + DO 40 I = 1, N + RPEV = ER(I) + IF( RECEVP ) THEN + SCALE = RPEV + RPEV = ED(I) + ELSE IF( .NOT.STDEVP ) THEN + SCALE = ED(I) + END IF + IF( ABS( SCALE ).GT.TOLINF .AND. + $ RPEV.LE.ALPHA*SCALE ) THEN + INFO = 1 + RETURN + END IF + 40 CONTINUE + END IF + END IF +C + RETURN +C *** Last line of AB09JX *** + END diff --git a/mex/sources/libslicot/AB09KD.f b/mex/sources/libslicot/AB09KD.f new file mode 100644 index 000000000..d390cfd6b --- /dev/null +++ b/mex/sources/libslicot/AB09KD.f @@ -0,0 +1,864 @@ + SUBROUTINE AB09KD( JOB, DICO, WEIGHT, EQUIL, ORDSEL, N, NV, NW, M, + $ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD, + $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, + $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, + $ NS, HSV, TOL1, TOL2, IWORK, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C state-space representation (A,B,C,D) by using the frequency +C weighted optimal Hankel-norm approximation method. +C The Hankel norm of the weighted error +C +C V*(G-Gr)*W or conj(V)*(G-Gr)*conj(W) +C +C is minimized, where G and Gr are the transfer-function matrices +C of the original and reduced systems, respectively, and V and W +C are the transfer-function matrices of the left and right frequency +C weights, specified by their state space realizations (AV,BV,CV,DV) +C and (AW,BW,CW,DW), respectively. When minimizing the weighted +C error V*(G-Gr)*W, V and W must be antistable transfer-function +C matrices. When minimizing conj(V)*(G-Gr)*conj(W), V and W must be +C stable transfer-function matrices. +C Additionally, V and W must be invertible transfer-function +C matrices, with the feedthrough matrices DV and DW invertible. +C If the original system is unstable, then the frequency weighted +C Hankel-norm approximation is computed only for the +C ALPHA-stable part of the system. +C +C For a transfer-function matrix G, conj(G) denotes the conjugate +C of G given by G'(-s) for a continuous-time system or G'(1/z) +C for a discrete-time system. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the frequency-weighting problem as follows: +C = 'N': solve min||V*(G-Gr)*W||_H; +C = 'C': solve min||conj(V)*(G-Gr)*conj(W)||_H. +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C WEIGHT CHARACTER*1 +C Specifies the type of frequency weighting, as follows: +C = 'N': no weightings are used (V = I, W = I); +C = 'L': only left weighting V is used (W = I); +C = 'R': only right weighting W is used (V = I); +C = 'B': both left and right weightings V and W are used. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e., the order of the matrix A. N >= 0. +C +C NV (input) INTEGER +C The order of the realization of the left frequency +C weighting V, i.e., the order of the matrix AV. NV >= 0. +C +C NW (input) INTEGER +C The order of the realization of the right frequency +C weighting W, i.e., the order of the matrix AW. NW >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. For a system with NU ALPHA-unstable +C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), +C NR is set as follows: if ORDSEL = 'F', NR is equal to +C NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the +C multiplicity of the Hankel singular value HSV(NR-NU+1), +C NR is the desired order on entry, and NMIN is the order +C of a minimal realization of the ALPHA-stable part of the +C given system; NMIN is determined as the number of Hankel +C singular values greater than NS*EPS*HNORM(As,Bs,Cs), where +C EPS is the machine precision (see LAPACK Library Routine +C DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the +C ALPHA-stable part of the weighted system (computed in +C HSV(1)); +C if ORDSEL = 'A', NR is the sum of NU and the number of +C Hankel singular values greater than +C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix A. For a continuous-time +C system (DICO = 'C'), ALPHA <= 0 is the boundary value for +C the real parts of eigenvalues, while for a discrete-time +C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system in a real Schur form. +C The resulting A has a block-diagonal form with two blocks. +C For a system with NU ALPHA-unstable eigenvalues and +C NS ALPHA-stable eigenvalues (NU+NS = N), the leading +C NU-by-NU block contains the unreduced part of A +C corresponding to ALPHA-unstable eigenvalues. +C The trailing (NR+NS-N)-by-(NR+NS-N) block contains +C the reduced part of A corresponding to ALPHA-stable +C eigenvalues. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) +C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV +C part of this array must contain the state matrix AV of a +C state space realization of the left frequency weighting V. +C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading +C NV-by-NV part of this array contains a real Schur form +C of the state matrix of a state space realization of the +C inverse of V. +C AV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDAV INTEGER +C The leading dimension of the array AV. +C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; +C LDAV >= 1, if WEIGHT = 'R' or 'N'. +C +C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) +C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part +C of this array must contain the input matrix BV of a state +C space realization of the left frequency weighting V. +C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading +C NV-by-P part of this array contains the input matrix of a +C state space realization of the inverse of V. +C BV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDBV INTEGER +C The leading dimension of the array BV. +C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; +C LDBV >= 1, if WEIGHT = 'R' or 'N'. +C +C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) +C On entry, if WEIGHT = 'L' or 'B', the leading P-by-NV part +C of this array must contain the output matrix CV of a state +C space realization of the left frequency weighting V. +C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading +C P-by-NV part of this array contains the output matrix of a +C state space realization of the inverse of V. +C CV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDCV INTEGER +C The leading dimension of the array CV. +C LDCV >= MAX(1,P), if WEIGHT = 'L' or 'B'; +C LDCV >= 1, if WEIGHT = 'R' or 'N'. +C +C DV (input/output) DOUBLE PRECISION array, dimension (LDDV,P) +C On entry, if WEIGHT = 'L' or 'B', the leading P-by-P part +C of this array must contain the feedthrough matrix DV of a +C state space realization of the left frequency weighting V. +C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading +C P-by-P part of this array contains the feedthrough matrix +C of a state space realization of the inverse of V. +C DV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDDV INTEGER +C The leading dimension of the array DV. +C LDDV >= MAX(1,P), if WEIGHT = 'L' or 'B'; +C LDDV >= 1, if WEIGHT = 'R' or 'N'. +C +C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) +C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW +C part of this array must contain the state matrix AW of +C a state space realization of the right frequency +C weighting W. +C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading +C NW-by-NW part of this array contains a real Schur form of +C the state matrix of a state space realization of the +C inverse of W. +C AW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDAW INTEGER +C The leading dimension of the array AW. +C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; +C LDAW >= 1, if WEIGHT = 'L' or 'N'. +C +C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,M) +C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-M part +C of this array must contain the input matrix BW of a state +C space realization of the right frequency weighting W. +C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading +C NW-by-M part of this array contains the input matrix of a +C state space realization of the inverse of W. +C BW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDBW INTEGER +C The leading dimension of the array BW. +C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; +C LDBW >= 1, if WEIGHT = 'L' or 'N'. +C +C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) +C On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part +C of this array must contain the output matrix CW of a state +C space realization of the right frequency weighting W. +C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading +C M-by-NW part of this array contains the output matrix of a +C state space realization of the inverse of W. +C CW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDCW INTEGER +C The leading dimension of the array CW. +C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; +C LDCW >= 1, if WEIGHT = 'L' or 'N'. +C +C DW (input/output) DOUBLE PRECISION array, dimension (LDDW,M) +C On entry, if WEIGHT = 'R' or 'B', the leading M-by-M part +C of this array must contain the feedthrough matrix DW of +C a state space realization of the right frequency +C weighting W. +C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading +C M-by-M part of this array contains the feedthrough matrix +C of a state space realization of the inverse of W. +C DW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDDW INTEGER +C The leading dimension of the array DW. +C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; +C LDDW >= 1, if WEIGHT = 'L' or 'N'. +C +C NS (output) INTEGER +C The dimension of the ALPHA-stable subsystem. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, the leading NS elements of this array contain +C the Hankel singular values, ordered decreasingly, of the +C ALPHA-stable part of the weighted original system. +C HSV(1) is the Hankel norm of the ALPHA-stable weighted +C subsystem. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the +C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the +C Hankel-norm of the ALPHA-stable part of the weighted +C original system (computed in HSV(1)). +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of +C ALPHA-stable eigenvalues of A and EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the ALPHA-stable part of the given system. +C The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs). +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = MAX(1,M,c), if DICO = 'C', +C LIWORK = MAX(1,N,M,c), if DICO = 'D', +C where c = 0, if WEIGHT = 'N', +C c = 2*P, if WEIGHT = 'L', +C c = 2*M, if WEIGHT = 'R', +C c = MAX(2*M,2*P), if WEIGHT = 'B'. +C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of +C the computed minimal realization. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( LDW1, LDW2, LDW3, LDW4 ), where +C LDW1 = 0 if WEIGHT = 'R' or 'N' and +C LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) +C if WEIGHT = 'L' or WEIGHT = 'B', +C LDW2 = 0 if WEIGHT = 'L' or 'N' and +C LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) +C if WEIGHT = 'R' or WEIGHT = 'B', with +C a = 0, b = 0, if DICO = 'C' or JOB = 'N', +C a = 2*NV, b = 2*NW, if DICO = 'D' and JOB = 'C'; +C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, +C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + +C MAX( 3*M+1, MIN(N,M)+P ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than NSMIN, the sum of the order of the +C ALPHA-unstable part and the order of a minimal +C realization of the ALPHA-stable part of the given +C system; in this case, the resulting NR is set equal +C to NSMIN; +C = 2: with ORDSEL = 'F', the selected order NR is less +C than the order of the ALPHA-unstable part of the +C given system; in this case NR is set equal to the +C order of the ALPHA-unstable part. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of the ordered real Schur form of A +C failed; +C = 2: the separation of the ALPHA-stable/unstable +C diagonal blocks failed because of very close +C eigenvalues; +C = 3: the reduction of AV or AV-BV*inv(DV)*CV to a +C real Schur form failed; +C = 4: the reduction of AW or AW-BW*inv(DW)*CW to a +C real Schur form failed; +C = 5: JOB = 'N' and AV is not antistable, or +C JOB = 'C' and AV is not stable; +C = 6: JOB = 'N' and AW is not antistable, or +C JOB = 'C' and AW is not stable; +C = 7: the computation of Hankel singular values failed; +C = 8: the computation of stable projection in the +C Hankel-norm approximation algorithm failed; +C = 9: the order of computed stable projection in the +C Hankel-norm approximation algorithm differs +C from the order of Hankel-norm approximation; +C = 10: DV is singular; +C = 11: DW is singular; +C = 12: the solution of the Sylvester equation failed +C because the zeros of V (if JOB = 'N') or of conj(V) +C (if JOB = 'C') are not distinct from the poles +C of G1sr (see METHOD); +C = 13: the solution of the Sylvester equation failed +C because the zeros of W (if JOB = 'N') or of conj(W) +C (if JOB = 'C') are not distinct from the poles +C of G1sr (see METHOD). +C +C METHOD +C +C Let G be the transfer-function matrix of the original +C linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t), (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09KD determines +C the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t), (2) +C +C such that the corresponding transfer-function matrix Gr minimizes +C the Hankel-norm of the frequency-weighted error +C +C V*(G-Gr)*W, (3) +C or +C conj(V)*(G-Gr)*conj(W). (4) +C +C For minimizing (3), V and W are assumed to be antistable, while +C for minimizing (4), V and W are assumed to be stable transfer- +C function matrices. +C +C Note: conj(G) = G'(-s) for a continuous-time system and +C conj(G) = G'(1/z) for a discrete-time system. +C +C The following procedure is used to reduce G (see [1]): +C +C 1) Decompose additively G as +C +C G = G1 + G2, +C +C such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and +C G2 = (A2,B2,C2,0) has only ALPHA-unstable poles. +C +C 2) Compute G1s, the stable projection of V*G1*W or +C conj(V)*G1*conj(W), using explicit formulas [4]. +C +C 3) Determine G1sr, the optimal Hankel-norm approximation of G1s +C of order r. +C +C 4) Compute G1r, the stable projection of either inv(V)*G1sr*inv(W) +C or conj(inv(V))*G1sr*conj(inv(W)), using explicit formulas [4]. +C +C 5) Assemble the reduced model Gr as +C +C Gr = G1r + G2. +C +C To reduce the weighted ALPHA-stable part G1s at step 3, the +C optimal Hankel-norm approximation method of [2], based on the +C square-root balancing projection formulas of [3], is employed. +C +C The optimal weighted approximation error satisfies +C +C HNORM[V*(G-Gr)*W] = S(r+1), +C or +C HNORM[conj(V)*(G-Gr)*conj(W)] = S(r+1), +C +C where S(r+1) is the (r+1)-th Hankel singular value of G1s, the +C transfer-function matrix computed at step 2 of the above +C procedure, and HNORM(.) denotes the Hankel-norm. +C +C REFERENCES +C +C [1] Latham, G.A. and Anderson, B.D.O. +C Frequency-weighted optimal Hankel-norm approximation of stable +C transfer functions. +C Systems & Control Letters, Vol. 5, pp. 229-236, 1985. +C +C [2] Glover, K. +C All optimal Hankel norm approximation of linear +C multivariable systems and their L-infinity error bounds. +C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. +C +C [3] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [4] Varga A. +C Explicit formulas for an efficient implementation +C of the frequency-weighting model reduction approach. +C Proc. 1993 European Control Conference, Groningen, NL, +C pp. 693-696, 1993. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on an accuracy enhancing square-root +C technique. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, April 2000. +C D. Sima, University of Bucharest, May 2000. +C V. Sima, Research Institute for Informatics, Bucharest, May 2000. +C Based on the RASP routines SFRLW, SFRLW1, SFRRW and SFRRW1, +C by A. Varga, 1992. +C +C REVISIONS +C +C A. Varga, Australian National University, Canberra, November 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000. +C Oct. 2001, March 2005. +C +C KEYWORDS +C +C Frequency weighting, model reduction, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION C100, ONE, ZERO + PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOB, ORDSEL, WEIGHT + INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, + $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, N, + $ NR, NS, NV, NW, P + DOUBLE PRECISION ALPHA, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), + $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), + $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), + $ D(LDD,*), DV(LDDV,*), DW(LDDW,*), DWORK(*), + $ HSV(*) +C .. Local Scalars .. + LOGICAL CONJS, DISCR, FIXORD, FRWGHT, LEFTW, RIGHTW + INTEGER IA, IB, IERR, IWARNL, KI, KL, KU, KW, LW, NMIN, + $ NRA, NU, NU1 + DOUBLE PRECISION ALPWRK, MAXRED, RCOND, WRKOPT +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB07ND, AB09CX, AB09KX, TB01ID, TB01KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + CONJS = LSAME( JOB, 'C' ) + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) + LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) + RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) + FRWGHT = LEFTW .OR. RIGHTW +C + IF ( DISCR .AND. CONJS ) THEN + IA = 2*NV + IB = 2*NW + ELSE + IA = 0 + IB = 0 + END IF + LW = 1 + IF( LEFTW ) + $ LW = MAX( LW, NV*(NV+5), NV*N + MAX( IA, P*N, P*M ) ) + IF( RIGHTW ) + $ LW = MAX( LW, MAX( NW*(NW+5), NW*N + MAX( IB, M*N, P*M ) ) ) + LW = MAX( LW, N*( 2*N + MAX( N, M, P ) + 5 ) + ( N*( N + 1 ) )/2 ) + LW = MAX( LW, N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + + $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) +C +C Check the input scalar arguments. +C + IF( .NOT. ( LSAME( JOB, 'N' ) .OR. CONJS ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -2 + ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( NV.LT.0 ) THEN + INFO = -7 + ELSE IF( NW.LT.0 ) THEN + INFO = -8 + ELSE IF( M.LT.0 ) THEN + INFO = -9 + ELSE IF( P.LT.0 ) THEN + INFO = -10 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -11 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -12 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -18 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -20 + ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN + INFO = -22 + ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN + INFO = -24 + ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.P ) ) THEN + INFO = -26 + ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.P ) ) THEN + INFO = -28 + ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN + INFO = -30 + ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN + INFO = -32 + ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN + INFO = -34 + ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN + INFO = -36 + ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN + INFO = -40 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -43 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09KD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + NS = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C Workspace: N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Correct the value of ALPHA to ensure stability. +C + ALPWRK = ALPHA + IF( DISCR ) THEN + IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) + ELSE + IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) + END IF +C +C Allocate working storage. +C + KU = 1 + KL = KU + N*N + KI = KL + N + KW = KI + N +C +C Reduce A to a block-diagonal real Schur form, with the +C ALPHA-unstable part in the leading diagonal position, using a +C non-orthogonal similarity transformation, A <- inv(T)*A*T, and +C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, + $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), + $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 1 + ELSE + INFO = 2 + END IF + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C +C Compute the stable projection of the weighted ALPHA-stable part. +C +C Workspace: need MAX( 1, LDW1, LDW2 ), +C LDW1 = 0 if WEIGHT = 'R' or 'N' and +C LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) +C if WEIGHT = 'L' or 'B', +C LDW2 = 0 if WEIGHT = 'L' or 'N' and +C LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) +C if WEIGHT = 'R' or 'B', +C where a = 0, b = 0, if DICO = 'C' or JOB = 'N', +C a = 2*NV, b = 2*NW, if DICO = 'D' and JOB = 'C'; +C prefer larger. +C + NS = N - NU +C +C Finish if only unstable part is present. +C + IF( NS.EQ.0 ) THEN + NR = NU + IWORK(1) = 0 + DWORK(1) = WRKOPT + RETURN + END IF +C + NU1 = NU + 1 + IF( FRWGHT ) THEN + CALL AB09KX( JOB, DICO, WEIGHT, NS, NV, NW, M, P, A(NU1,NU1), + $ LDA, B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, + $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, + $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, + $ DWORK, LDWORK, IWARNL, IERR ) +C + IF( IERR.NE.0 ) THEN +C +C Note: Only IERR = 1 or IERR = 2 are possible. +C Set INFO to 3 or 4. +C + INFO = IERR + 2 + RETURN + END IF +C + IF( IWARNL.NE.0 ) THEN +C +C Stability/antistability of V and W are compulsory. +C + IF( IWARNL.EQ.1 .OR. IWARNL.EQ.3 ) THEN + INFO = 5 + ELSE + INFO = 6 + END IF + RETURN + END IF +C + DWORK(1) = MAX( WRKOPT, DWORK(1) ) + END IF +C +C Determine a reduced order approximation of the ALPHA-stable part. +C +C Workspace: need MAX( LDW3, LDW4 ), +C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, +C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + +C MAX( 3*M+1, MIN(N,M)+P ); +C prefer larger. +C + IWARNL = 0 + IF( FIXORD ) THEN + NRA = MAX( 0, NR - NU ) + IF( NRA.EQ.0 ) + $ IWARNL = 2 + ELSE + NRA = 0 + END IF + CALL AB09CX( DICO, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, + $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, TOL1, + $ TOL2, IWORK, DWORK, LDWORK, IWARN, IERR ) +C + IWARN = MAX( IWARN, IWARNL ) + IF( IERR.NE.0 ) THEN +C +C Set INFO = 7, 8 or 9. +C + INFO = IERR + 5 + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(1) ) + NMIN = IWORK(1) +C +C Compute the state space realizations of the inverses of V and W. +C +C Integer workspace: need c, +C Real workspace: need MAX(1,2*c), +C where c = 0, if WEIGHT = 'N', +C c = 2*P, if WEIGHT = 'L', +C c = 2*M, if WEIGHT = 'R', +C c = MAX(2*M,2*P), if WEIGHT = 'B'. +C + IF( LEFTW ) THEN + CALL AB07ND( NV, P, AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, + $ RCOND, IWORK, DWORK, LDWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 10 + RETURN + END IF + END IF + IF( RIGHTW ) THEN + CALL AB07ND( NW, M, AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, + $ RCOND, IWORK, DWORK, LDWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 11 + RETURN + END IF + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(1) ) +C +C Compute the stable projection of weighted reduced ALPHA-stable +C part. +C + IF( FRWGHT ) THEN + CALL AB09KX( JOB, DICO, WEIGHT, NRA, NV, NW, M, P, A(NU1,NU1), + $ LDA, B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, + $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, + $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, + $ DWORK, LDWORK, IWARNL, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.LE.2 ) THEN +C +C Set INFO to 3 or 4. +C + INFO = IERR + 2 + ELSE +C +C Set INFO to 12 or 13. +C + INFO = IERR + 9 + END IF + RETURN + END IF + END IF +C + NR = NRA + NU + IWORK(1) = NMIN + DWORK(1) = MAX( WRKOPT, DWORK(1) ) +C + RETURN +C *** Last line of AB09KD *** + END diff --git a/mex/sources/libslicot/AB09KX.f b/mex/sources/libslicot/AB09KX.f new file mode 100644 index 000000000..5ac044c76 --- /dev/null +++ b/mex/sources/libslicot/AB09KX.f @@ -0,0 +1,869 @@ + SUBROUTINE AB09KX( JOB, DICO, WEIGHT, N, NV, NW, M, P, + $ A, LDA, B, LDB, C, LDC, D, LDD, + $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, + $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, + $ DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct a state-space representation (A,BS,CS,DS) of the +C stable projection of V*G*W or conj(V)*G*conj(W) from the +C state-space representations (A,B,C,D), (AV,BV,CV,DV), and +C (AW,BW,CW,DW) of the transfer-function matrices G, V and W, +C respectively. G is assumed to be a stable transfer-function +C matrix and the state matrix A must be in a real Schur form. +C When computing the stable projection of V*G*W, V and W are assumed +C to be completely unstable transfer-function matrices. +C When computing the stable projection of conj(V)*G*conj(W), +C V and W are assumed to be stable transfer-function matrices. +C +C For a transfer-function matrix G, conj(G) denotes the conjugate +C of G given by G'(-s) for a continuous-time system or G'(1/z) +C for a discrete-time system. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies which projection to be computed as follows: +C = 'N': compute the stable projection of V*G*W; +C = 'C': compute the stable projection of +C conj(V)*G*conj(W). +C +C DICO CHARACTER*1 +C Specifies the type of the systems as follows: +C = 'C': G, V and W are continuous-time systems; +C = 'D': G, V and W are discrete-time systems. +C +C WEIGHT CHARACTER*1 +C Specifies the type of frequency weighting, as follows: +C = 'N': no weightings are used (V = I, W = I); +C = 'L': only left weighting V is used (W = I); +C = 'R': only right weighting W is used (V = I); +C = 'B': both left and right weightings V and W are used. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. Also the number of rows of +C the matrix B and the number of columns of the matrix C. +C N represents the dimension of the state vector of the +C system with the transfer-function matrix G. N >= 0. +C +C NV (input) INTEGER +C The order of the matrix AV. Also the number of rows of +C the matrix BV and the number of columns of the matrix CV. +C NV represents the dimension of the state vector of the +C system with the transfer-function matrix V. NV >= 0. +C +C NW (input) INTEGER +C The order of the matrix AW. Also the number of rows of +C the matrix BW and the number of columns of the matrix CW. +C NW represents the dimension of the state vector of the +C system with the transfer-function matrix W. NW >= 0. +C +C M (input) INTEGER +C The number of columns of the matrices B, D, BW and DW +C and number of rows of the matrices CW and DW. M >= 0. +C M represents the dimension of input vectors of the +C systems with the transfer-function matrices G and W and +C also the dimension of the output vector of the system +C with the transfer-function matrix W. +C +C P (input) INTEGER +C The number of rows of the matrices C, D, CV and DV and the +C number of columns of the matrices BV and DV. P >= 0. +C P represents the dimension of output vectors of the +C systems with the transfer-function matrices G and V and +C also the dimension of the input vector of the system +C with the transfer-function matrix V. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must +C contain the state matrix A of the system with the +C transfer-function matrix G in a real Schur form. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B of the system with the +C transfer-function matrix G. +C On exit, if INFO = 0, the leading N-by-M part of this +C array contains the input matrix BS of the stable +C projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W) +C if JOB = 'C'. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C of the system with the +C transfer-function matrix G. +C On exit, if INFO = 0, the leading P-by-N part of this +C array contains the output matrix CS of the stable +C projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W) +C if JOB = 'C'. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the feedthrough matrix D of the system with the +C transfer-function matrix G. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the feedthrough matrix DS of the stable +C projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W) +C if JOB = 'C'. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= MAX(1,P). +C +C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) +C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV +C part of this array must contain the state matrix AV of +C the system with the transfer-function matrix V. +C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading +C NV-by-NV part of this array contains a real Schur form +C of AV. +C AV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDAV INTEGER +C The leading dimension of the array AV. +C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; +C LDAV >= 1, if WEIGHT = 'R' or 'N'. +C +C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) +C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part +C of this array must contain the input matrix BV of the +C system with the transfer-function matrix V. +C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading +C NV-by-P part of this array contains the transformed input +C matrix BV. +C BV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDBV INTEGER +C The leading dimension of the array BV. +C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; +C LDBV >= 1, if WEIGHT = 'R' or 'N'. +C +C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) +C On entry, if WEIGHT = 'L' or 'B', the leading P-by-NV part +C of this array must contain the output matrix CV of the +C system with the transfer-function matrix V. +C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading +C P-by-NV part of this array contains the transformed output +C matrix CV. +C CV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDCV INTEGER +C The leading dimension of the array CV. +C LDCV >= MAX(1,P), if WEIGHT = 'L' or 'B'; +C LDCV >= 1, if WEIGHT = 'R' or 'N'. +C +C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) +C If WEIGHT = 'L' or 'B', the leading P-by-P part of this +C array must contain the feedthrough matrix DV of the system +C with the transfer-function matrix V. +C DV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDDV INTEGER +C The leading dimension of the array DV. +C LDDV >= MAX(1,P), if WEIGHT = 'L' or 'B'; +C LDDV >= 1, if WEIGHT = 'R' or 'N'. +C +C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) +C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW +C part of this array must contain the state matrix AW of +C the system with the transfer-function matrix W. +C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading +C NW-by-NW part of this array contains a real Schur form +C of AW. +C AW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDAW INTEGER +C The leading dimension of the array AW. +C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; +C LDAW >= 1, if WEIGHT = 'L' or 'N'. +C +C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,M) +C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-M part +C of this array must contain the input matrix BW of the +C system with the transfer-function matrix W. +C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading +C NW-by-M part of this array contains the transformed input +C matrix BW. +C BW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDBW INTEGER +C The leading dimension of the array BW. +C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; +C LDBW >= 1, if WEIGHT = 'L' or 'N'. +C +C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) +C On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part +C of this array must contain the output matrix CW of the +C system with the transfer-function matrix W. +C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading +C M-by-NW part of this array contains the transformed output +C matrix CW. +C CW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDCW INTEGER +C The leading dimension of the array CW. +C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; +C LDCW >= 1, if WEIGHT = 'L' or 'N'. +C +C DW (input) DOUBLE PRECISION array, dimension (LDDW,M) +C If WEIGHT = 'R' or 'B', the leading M-by-M part of this +C array must contain the feedthrough matrix DW of the system +C with the transfer-function matrix W. +C DW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDDW INTEGER +C The leading dimension of the array DW. +C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; +C LDDW >= 1, if WEIGHT = 'L' or 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, LDW1, LDW2 ), where +C LDW1 = 0 if WEIGHT = 'R' or 'N' and +C LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) +C if WEIGHT = 'L' or WEIGHT = 'B', +C LDW2 = 0 if WEIGHT = 'L' or 'N' and +C LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) +C if WEIGHT = 'R' or WEIGHT = 'B', +C a = 0, b = 0, if DICO = 'C' or JOB = 'N', +C a = 2*NV, b = 2*NW, if DICO = 'D' and JOB = 'C'. +C For good performance, LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: JOB = 'N' and AV is not completely unstable, or +C JOB = 'C' and AV is not stable; +C = 2: JOB = 'N' and AW is not completely unstable, or +C JOB = 'C' and AW is not stable; +C = 3: both above conditions appear. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of AV to a real Schur form failed; +C = 2: the reduction of AW to a real Schur form failed; +C = 3: the solution of the Sylvester equation failed +C because the matrices A and AV have common +C eigenvalues (if JOB = 'N'), or -AV and A have +C common eigenvalues (if JOB = 'C' and DICO = 'C'), +C or AV has an eigenvalue which is the reciprocal of +C one of the eigenvalues of A (if JOB = 'C' and +C DICO = 'D'); +C = 4: the solution of the Sylvester equation failed +C because the matrices A and AW have common +C eigenvalues (if JOB = 'N'), or -AW and A have +C common eigenvalues (if JOB = 'C' and DICO = 'C'), +C or AW has an eigenvalue which is the reciprocal of +C one of the eigenvalues of A (if JOB = 'C' and +C DICO = 'D'). +C +C METHOD +C +C The matrices of the stable projection of V*G*W are computed as +C +C BS = B*DW + Y*BW, CS = CV*X + DV*C, DS = DV*D*DW, +C +C where X and Y satisfy the continuous-time Sylvester equations +C +C AV*X - X*A + BV*C = 0, +C -A*Y + Y*AW + B*CW = 0. +C +C The matrices of the stable projection of conj(V)*G*conj(W) are +C computed using the explicit formulas established in [1]. +C +C For a continuous-time system, the matrices BS, CS and DS of +C the stable projection are computed as +C +C BS = B*DW' + Y*CW', CS = BV'*X + DV'*C, DS = DV'*D*DW', +C +C where X and Y satisfy the continuous-time Sylvester equations +C +C AV'*X + X*A + CV'*C = 0, +C A*Y + Y*AW' + B*BW' = 0. +C +C For a discrete-time system, the matrices BS, CS and DS of +C the stable projection are computed as +C +C BS = B*DW' + A*Y*CW', CS = BV'*X*A + DV'*C, +C DS = DV'*D*DW' + BV'*X*B*DW' + DV'*C*Y*CW' + BV'*X*A*Y*CW', +C +C where X and Y satisfy the discrete-time Sylvester equations +C +C AV'*X*A + CV'*C = X, +C A*Y*AW' + B*BW' = Y. +C +C REFERENCES +C +C [1] Varga A. +C Explicit formulas for an efficient implementation +C of the frequency-weighting model reduction approach. +C Proc. 1993 European Control Conference, Groningen, NL, +C pp. 693-696, 1993. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on numerically stable algorithms. +C +C FURTHER COMMENTS +C +C The matrix A must be stable, but its stability is not checked by +C this routine. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, April 2000. +C D. Sima, University of Bucharest, May 2000. +C V. Sima, Research Institute for Informatics, Bucharest, May 2000. +C Based on the RASP routines SFRLW, SFRLW1, SFRRW and SFRRW1, +C by A. Varga, 1992. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Frequency weighting, model reduction, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOB, WEIGHT + INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, + $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, N, + $ NV, NW, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ AV(LDAV,*), BV(LDBV,*), CV(LDCV,*), DV(LDDV,*), + $ AW(LDAW,*), BW(LDBW,*), CW(LDCW,*), DW(LDDW,*), + $ DWORK(*) +C .. Local Scalars + LOGICAL CONJS, DISCR, FRWGHT, LEFTW, RIGHTW + DOUBLE PRECISION SCALE, WORK + INTEGER I, IA, IB, IERR, KW, LDW, LDWN, LW +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DTRSYL, SB04PY, TB01WD, XERBLA +C .. Executable Statements .. +C + CONJS = LSAME( JOB, 'C' ) + DISCR = LSAME( DICO, 'D' ) + LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) + RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) + FRWGHT = LEFTW .OR. RIGHTW +C + IWARN = 0 + INFO = 0 + IF ( DISCR .AND. CONJS ) THEN + IA = 2*NV + IB = 2*NW + ELSE + IA = 0 + IB = 0 + END IF + LW = 1 + IF( LEFTW ) + $ LW = MAX( LW, NV*( NV + 5 ), NV*N + MAX( IA, P*N, P*M ) ) + IF( RIGHTW ) + $ LW = MAX( LW, NW*( NW + 5 ), NW*N + MAX( IB, M*N, P*M ) ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( JOB, 'N' ) .OR. CONJS ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -2 + ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( NV.LT.0 ) THEN + INFO = -5 + ELSE IF( NW.LT.0 ) THEN + INFO = -6 + ELSE IF( M.LT.0 ) THEN + INFO = -7 + ELSE IF( P.LT.0 ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -14 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN + INFO = -18 + ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN + INFO = -20 + ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.P ) ) THEN + INFO = -22 + ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.P ) ) THEN + INFO = -24 + ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN + INFO = -26 + ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN + INFO = -28 + ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN + INFO = -30 + ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN + INFO = -32 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -34 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09KX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( .NOT.FRWGHT .OR. MIN( M, P ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + WORK = ONE + IF( LEFTW .AND. NV.GT.0 ) THEN +C +C Reduce AV to a real Schur form using an orthogonal similarity +C transformation AV <- Q'*AV*Q and apply the transformation to +C BV and CV: BV <- Q'*BV and CV <- CV*Q. +C +C Workspace needed: NV*(NV+5); +C prefer larger. +C + KW = NV*( NV + 2 ) + 1 + CALL TB01WD( NV, P, P, AV, LDAV, BV, LDBV, CV, LDCV, + $ DWORK(2*NV+1), NV, DWORK, DWORK(NV+1), DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C + IF( CONJS ) THEN +C +C Check the stability of the eigenvalues of AV. +C + IF ( DISCR ) THEN + DO 10 I = 1, NV + IF( DLAPY2( DWORK(I), DWORK(NV+I) ).GE.ONE) THEN + IWARN = 1 + GO TO 50 + END IF + 10 CONTINUE + ELSE + DO 20 I = 1, NV + IF( DWORK(I).GE.ZERO ) THEN + IWARN = 1 + GO TO 50 + END IF + 20 CONTINUE + END IF + ELSE +C +C Check the anti-stability of the eigenvalues of AV. +C + IF ( DISCR ) THEN + DO 30 I = 1, NV + IF( DLAPY2( DWORK(I), DWORK(NV+I) ).LE.ONE) THEN + IWARN = 1 + GO TO 50 + END IF + 30 CONTINUE + ELSE + DO 40 I = 1, NV + IF( DWORK(I).LE.ZERO ) THEN + IWARN = 1 + GO TO 50 + END IF + 40 CONTINUE + END IF + END IF + 50 CONTINUE +C + END IF +C + IF( RIGHTW .AND. NW.GT.0 ) THEN +C +C Reduce AW to a real Schur form using an orthogonal similarity +C transformation AW <- T'*AW*T and apply the transformation to +C BW and CW: BW <- T'*BW and CW <- CW*T. +C +C Workspace needed: NW*(NW+5); +C prefer larger. +C + KW = NW*( NW + 2 ) + 1 + CALL TB01WD( NW, M, M, AW, LDAW, BW, LDBW, CW, LDCW, + $ DWORK(2*NW+1), NW, DWORK, DWORK(NW+1), DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C + IF( CONJS ) THEN +C +C Check the stability of the eigenvalues of AW. +C + IF ( DISCR ) THEN + DO 60 I = 1, NW + IF( DLAPY2( DWORK(I), DWORK(NW+I) ).GE.ONE) THEN + IWARN = IWARN + 2 + GO TO 100 + END IF + 60 CONTINUE + ELSE + DO 70 I = 1, NW + IF( DWORK(I).GE.ZERO ) THEN + IWARN = IWARN + 2 + GO TO 100 + END IF + 70 CONTINUE + END IF + ELSE +C +C Check the anti-stability of the eigenvalues of AW. +C + IF ( DISCR ) THEN + DO 80 I = 1, NW + IF( DLAPY2( DWORK(I), DWORK(NW+I) ).LE.ONE) THEN + IWARN = IWARN + 2 + GO TO 100 + END IF + 80 CONTINUE + ELSE + DO 90 I = 1, NW + IF( DWORK(I).LE.ZERO ) THEN + IWARN = IWARN + 2 + GO TO 100 + END IF + 90 CONTINUE + END IF + END IF + 100 CONTINUE + END IF +C + IF( LEFTW ) THEN + LDW = MAX( NV, 1 ) + KW = NV*N + 1 + IF( CONJS ) THEN +C +C Compute the projection of conj(V)*G. +C +C Total workspace needed: NV*N + MAX( a, P*N, P*M ), where +C a = 0, if DICO = 'C', +C a = 2*NV, if DICO = 'D'. +C +C Compute -CV'*C. +C Workspace needed: NV*N. +C + CALL DGEMM( 'T', 'N', NV, N, P, -ONE, CV, LDCV, C, LDC, + $ ZERO, DWORK, LDW ) +C + IF( DISCR ) THEN +C +C Compute X and SCALE satisfying +C +C AV'*X*A - X = -SCALE*CV'*C. +C +C Additional workspace needed: 2*NV. +C + CALL SB04PY( 'T', 'N', -1, NV, N, AV, LDAV, A, LDA, + $ DWORK, LDW, SCALE, DWORK(KW), IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C +C Construct C <- DV'*C + BV'*X*A/SCALE, +C D <- DV'*D + BV'*X*B/SCALE. +C +C Additional workspace needed: MAX( P*N, P*M ). +C +C C <- DV'*C. +C + CALL DGEMM( 'T', 'N', P, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC ) +C +C D <- DV'*D. +C + CALL DGEMM( 'T', 'N', P, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) +C +C C <- C + BV'*X*A/SCALE. +C + CALL DGEMM( 'T', 'N', P, N, NV, ONE / SCALE, BV, LDBV, + $ DWORK, LDW, ZERO, DWORK(KW), P ) + CALL DGEMM( 'N', 'N', P, N, N, ONE, DWORK(KW), P, A, LDA, + $ ONE, C, LDC ) +C +C D <- D + BV'*X*B/SCALE. +C + CALL DGEMM( 'N', 'N', P, M, N, ONE, DWORK(KW), P, B, LDB, + $ ONE, D, LDD ) + ELSE +C +C Compute X and SCALE satisfying +C +C AV'*X + X*A + SCALE*CV'*C = 0. +C + CALL DTRSYL( 'T', 'N', 1, NV, N, AV, LDAV, A, LDA, + $ DWORK, LDW, SCALE, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C +C Construct C and D. +C Additional workspace needed: MAX( P*N, P*M ). +C +C Construct C <- BV'*X/SCALE + DV'*C. +C + CALL DGEMM( 'T', 'N', P, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC ) + CALL DGEMM( 'T', 'N', P, N, NV, ONE / SCALE, BV, LDBV, + $ DWORK, LDW, ONE, C, LDC ) +C +C Construct D <- DV'*D. +C + CALL DGEMM( 'T', 'N', P, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) + END IF + ELSE +C +C Compute the projection of V*G. +C +C Total workspace needed: NV*N + MAX( P*N, P*M ). +C +C Compute -BV*C. +C Workspace needed: NV*N. +C + CALL DGEMM( 'N', 'N', NV, N, P, -ONE, BV, LDBV, C, LDC, + $ ZERO, DWORK, LDW ) +C +C Compute X and SCALE satisfying +C +C AV*X - X*A + SCALE*BV*C = 0. +C + CALL DTRSYL( 'N', 'N', -1, NV, N, AV, LDAV, A, LDA, + $ DWORK, LDW, SCALE, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C +C Construct C <- CV*X/SCALE + DV*C. +C + CALL DGEMM( 'N', 'N', P, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC ) + CALL DGEMM( 'N', 'N', P, N, NV, ONE / SCALE, CV, LDCV, + $ DWORK, LDW, ONE, C, LDC ) +C +C Construct D <- DV*D. +C + CALL DGEMM( 'N', 'N', P, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) + END IF + END IF +C + IF( RIGHTW ) THEN + LDWN = MAX( N, 1 ) + KW = N*NW + 1 + IF( CONJS ) THEN +C +C Compute the projection of G*conj(W) or of conj(V)*G*conj(W). +C +C Total workspace needed: NW*N + MAX( b, M*N, P*M ), where +C b = 0, if DICO = 'C', +C b = 2*NW, if DICO = 'D'. +C +C Compute -BW*B'. +C Workspace needed: N*NW. +C + LDW = MAX( NW, 1 ) + CALL DGEMM( 'N', 'T', NW, N, M, -ONE, BW, LDBW, B, LDB, + $ ZERO, DWORK, LDW ) +C + IF( DISCR ) THEN +C +C Compute Y' and SCALE satisfying +C +C AW*Y'*A' - Y' = -SCALE*BW*B'. +C +C Additional workspace needed: 2*NW. +C + CALL SB04PY( 'N', 'T', -1, NW, N, AW, LDAW, A, LDA, + $ DWORK, LDW, SCALE, DWORK(KW), IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF +C +C Construct B <- B*DW' + A*Y*CW'/SCALE, +C D <- D*DW' + C*Y*CW'/SCALE. +C +C Additional workspace needed: MAX( N*M, P*M ). +C +C B <- B*DW'. +C + CALL DGEMM( 'N', 'T', N, M, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB ) +C +C D <- D*DW'. +C + CALL DGEMM( 'N', 'T', P, M, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) +C +C B <- B + A*Y*CW'/SCALE. +C + CALL DGEMM( 'T', 'T', N, M, NW, ONE / SCALE, DWORK, LDW, + $ CW, LDCW, ZERO, DWORK(KW), LDWN ) + CALL DGEMM( 'N', 'N', N, M, N, ONE, A, LDA, + $ DWORK(KW), LDWN, ONE, B, LDB ) +C +C D <- D + C*Y*CW'/SCALE. +C + CALL DGEMM( 'N', 'N', P, M, N, ONE, C, LDC, + $ DWORK(KW), LDWN, ONE, D, LDD ) + ELSE +C +C Compute Y' and SCALE satisfying +C +C AW*Y' + Y'*A' + SCALE*BW*B' = 0. +C + CALL DTRSYL( 'N', 'T', 1, NW, N, AW, LDAW, A, LDA, + $ DWORK, LDW, SCALE, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF +C +C Construct B and D. +C Additional workspace needed: MAX( N*M, P*M ). +C +C Construct B <- B*DW' + Y*CW'/SCALE. +C + CALL DGEMM( 'N', 'T', N, M, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB ) + CALL DGEMM( 'T', 'T', N, M, NW, ONE / SCALE, DWORK, LDW, + $ CW, LDCW, ONE, B, LDB) +C +C D <- D*DW'. +C + CALL DGEMM( 'N', 'T', P, M, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) + END IF + ELSE +C +C Compute the projection of G*W or of V*G*W. +C +C Total workspace needed: NW*N + MAX( M*N, P*M ). +C +C Compute B*CW. +C Workspace needed: N*NW. +C + CALL DGEMM( 'N', 'N', N, NW, M, ONE, B, LDB, CW, LDCW, + $ ZERO, DWORK, LDWN ) +C +C Compute Y and SCALE satisfying +C +C A*Y - Y*AW - SCALE*B*CW = 0. +C + CALL DTRSYL( 'N', 'N', -1, N, NW, A, LDA, AW, LDAW, + $ DWORK, LDWN, SCALE, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF +C +C Construct B and D. +C Additional workspace needed: MAX( N*M, P*M ). +C Construct B <- B*DW + Y*BW/SCALE. +C + CALL DGEMM( 'N', 'N', N, M, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB ) + CALL DGEMM( 'N', 'N', N, M, NW, ONE / SCALE, DWORK, LDWN, + $ BW, LDBW, ONE, B, LDB) +C +C D <- D*DW. +C + CALL DGEMM( 'N', 'N', P, M, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) + END IF + END IF +C + DWORK(1) = MAX( WORK, DBLE( LW ) ) +C + RETURN +C *** Last line of AB09KX *** + END diff --git a/mex/sources/libslicot/AB09MD.f b/mex/sources/libslicot/AB09MD.f new file mode 100644 index 000000000..aaa808bfe --- /dev/null +++ b/mex/sources/libslicot/AB09MD.f @@ -0,0 +1,474 @@ + SUBROUTINE AB09MD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA, + $ A, LDA, B, LDB, C, LDC, NS, HSV, TOL, IWORK, + $ DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr) for an original +C state-space representation (A,B,C) by using either the square-root +C or the balancing-free square-root Balance & Truncate (B & T) +C model reduction method for the ALPHA-stable part of the system. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root Balance & Truncate method; +C = 'N': use the balancing-free square-root +C Balance & Truncate method. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of the +C resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. For a system with NU ALPHA-unstable +C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), +C NR is set as follows: if ORDSEL = 'F', NR is equal to +C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order +C on entry, and NMIN is the order of a minimal realization +C of the ALPHA-stable part of the given system; NMIN is +C determined as the number of Hankel singular values greater +C than NS*EPS*HNORM(As,Bs,Cs), where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH) and +C HNORM(As,Bs,Cs) is the Hankel norm of the ALPHA-stable +C part of the given system (computed in HSV(1)); +C if ORDSEL = 'A', NR is the sum of NU and the number of +C Hankel singular values greater than +C MAX(TOL,NS*EPS*HNORM(As,Bs,Cs)). +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix A. For a continuous-time +C system (DICO = 'C'), ALPHA <= 0 is the boundary value for +C the real parts of eigenvalues, while for a discrete-time +C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the reduced +C order system. +C The resulting A has a block-diagonal form with two blocks. +C For a system with NU ALPHA-unstable eigenvalues and +C NS ALPHA-stable eigenvalues (NU+NS = N), the leading +C NU-by-NU block contains the unreduced part of A +C corresponding to ALPHA-unstable eigenvalues in an +C upper real Schur form. +C The trailing (NR+NS-N)-by-(NR+NS-N) block contains +C the reduced part of A corresponding to ALPHA-stable +C eigenvalues. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C NS (output) INTEGER +C The dimension of the ALPHA-stable subsystem. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, the leading NS elements of HSV contain the +C Hankel singular values of the ALPHA-stable part of the +C original system ordered decreasingly. +C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If ORDSEL = 'A', TOL contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL = c*HNORM(As,Bs,Cs), where c is a constant in the +C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the +C Hankel-norm of the ALPHA-stable part of the given system +C (computed in HSV(1)). +C If TOL <= 0 on entry, the used default value is +C TOL = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of +C ALPHA-stable eigenvalues of A and EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C This value is appropriate to compute a minimal realization +C of the ALPHA-stable part. +C If ORDSEL = 'F', the value of TOL is ignored. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = 0, if JOB = 'B'; +C LIWORK = N, if JOB = 'N'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than NSMIN, the sum of the order of the +C ALPHA-unstable part and the order of a minimal +C realization of the ALPHA-stable part of the given +C system. In this case, the resulting NR is set equal +C to NSMIN. +C = 2: with ORDSEL = 'F', the selected order NR is less +C than the order of the ALPHA-unstable part of the +C given system. In this case NR is set equal to the +C order of the ALPHA-unstable part. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of the ordered real Schur form of A +C failed; +C = 2: the separation of the ALPHA-stable/unstable diagonal +C blocks failed because of very close eigenvalues; +C = 3: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the following linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09MD determines for +C the given system (1), the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) (2) +C +C such that +C +C HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C The following procedure is used to reduce a given G: +C +C 1) Decompose additively G as +C +C G = G1 + G2 +C +C such that G1 = (As,Bs,Cs) has only ALPHA-stable poles and +C G2 = (Au,Bu,Cu) has only ALPHA-unstable poles. +C +C 2) Determine G1r, a reduced order approximation of the +C ALPHA-stable part G1. +C +C 3) Assemble the reduced model Gr as +C +C Gr = G1r + G2. +C +C To reduce the ALPHA-stable part G1, if JOB = 'B', the square-root +C Balance & Truncate method of [1] is used, and for an ALPHA-stable +C continuous-time system (DICO = 'C'), the resulting reduced model +C is balanced. For ALPHA-stable systems, setting TOL < 0, the +C routine can be used to compute balanced minimal state-space +C realizations. +C +C If JOB = 'N', the balancing-free square-root version of the +C Balance & Truncate method [2] is used to reduce the ALPHA-stable +C part G1. +C +C REFERENCES +C +C [1] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [2] Varga A. +C Efficient minimal realization procedure based on balancing. +C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, +C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), +C Vol. 2, pp. 42-46. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara, University "Politehnica" Bucharest. +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C February 1999. Based on the RASP routines SADSDC, SRBT and SRBFT. +C +C REVISIONS +C +C Mar. 1999, V. Sima, Research Institute for Informatics, Bucharest. +C Nov. 2000, A. Varga, DLR Oberpfaffenhofen. +C +C KEYWORDS +C +C Balancing, minimal realization, model reduction, multivariable +C system, state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, C100 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDWORK, M, N, NR, + $ NS, P + DOUBLE PRECISION ALPHA, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL DISCR, FIXORD + INTEGER IERR, IWARNL, KT, KTI, KU, KW, KWI, KWR, LWR, + $ NN, NRA, NU, NU1, WRKOPT + DOUBLE PRECISION ALPWRK, MAXRED +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB09AX, TB01ID, TB01KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -8 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2 ) ) THEN + INFO = -21 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C Workspace: N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Correct the value of ALPHA to ensure stability. +C + ALPWRK = ALPHA + IF( DISCR ) THEN + IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) + ELSE + IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) + END IF +C +C Allocate working storage. +C + NN = N*N + KU = 1 + KWR = KU + NN + KWI = KWR + N + KW = KWI + N + LWR = LDWORK - KW + 1 +C +C Reduce A to a block-diagonal real Schur form, with the +C ALPHA-unstable part in the leading diagonal position, using a +C non-orthogonal similarity transformation A <- inv(T)*A*T and +C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, + $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KWR), + $ DWORK(KWI), DWORK(KW), LWR, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 1 + ELSE + INFO = 2 + END IF + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C + IWARNL = 0 + NS = N - NU + IF( FIXORD ) THEN + NRA = MAX( 0, NR-NU ) + IF( NR.LT.NU ) + $ IWARNL = 2 + ELSE + NRA = 0 + END IF +C +C Finish if only unstable part is present. +C + IF( NS.EQ.0 ) THEN + NR = NU + DWORK(1) = WRKOPT + RETURN + END IF +C + NU1 = NU + 1 +C +C Allocate working storage. +C + KT = 1 + KTI = KT + NN + KW = KTI + NN +C +C Compute a B & T approximation of the stable part. +C Workspace: need N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2; +C prefer larger. +C + CALL AB09AX( DICO, JOB, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, + $ B(NU1,1), LDB, C(1,NU1), LDC, HSV, DWORK(KT), N, + $ DWORK(KTI), N, TOL, IWORK, DWORK(KW), LDWORK-KW+1, + $ IWARN, IERR ) + IWARN = MAX( IWARN, IWARNL ) +C + IF( IERR.NE.0 ) THEN + INFO = IERR + 1 + RETURN + END IF +C + NR = NRA + NU +C + DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C + RETURN +C *** Last line of AB09MD *** + END diff --git a/mex/sources/libslicot/AB09ND.f b/mex/sources/libslicot/AB09ND.f new file mode 100644 index 000000000..49ea0c0cd --- /dev/null +++ b/mex/sources/libslicot/AB09ND.f @@ -0,0 +1,497 @@ + SUBROUTINE AB09ND( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA, + $ A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV, TOL1, + $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C state-space representation (A,B,C,D) by using either the +C square-root or the balancing-free square-root Singular +C Perturbation Approximation (SPA) model reduction method for the +C ALPHA-stable part of the system. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root SPA method; +C = 'N': use the balancing-free square-root SPA method. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of the +C resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. For a system with NU ALPHA-unstable +C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), +C NR is set as follows: if ORDSEL = 'F', NR is equal to +C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order +C on entry, and NMIN is the order of a minimal realization +C of the ALPHA-stable part of the given system; NMIN is +C determined as the number of Hankel singular values greater +C than NS*EPS*HNORM(As,Bs,Cs), where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH) and +C HNORM(As,Bs,Cs) is the Hankel norm of the ALPHA-stable +C part of the given system (computed in HSV(1)); +C if ORDSEL = 'A', NR is the sum of NU and the number of +C Hankel singular values greater than +C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix A. For a continuous-time +C system (DICO = 'C'), ALPHA <= 0 is the boundary value for +C the real parts of eigenvalues, while for a discrete-time +C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the reduced +C order system. +C The resulting A has a block-diagonal form with two blocks. +C For a system with NU ALPHA-unstable eigenvalues and +C NS ALPHA-stable eigenvalues (NU+NS = N), the leading +C NU-by-NU block contains the unreduced part of A +C corresponding to ALPHA-unstable eigenvalues in an +C upper real Schur form. +C The trailing (NR+NS-N)-by-(NR+NS-N) block contains +C the reduced part of A corresponding to ALPHA-stable +C eigenvalues. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NS (output) INTEGER +C The dimension of the ALPHA-stable subsystem. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, the leading NS elements of HSV contain the +C Hankel singular values of the ALPHA-stable part of the +C original system ordered decreasingly. +C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the +C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the +C Hankel-norm of the ALPHA-stable part of the given system +C (computed in HSV(1)). +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of +C ALPHA-stable eigenvalues of A and EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C This value is appropriate to compute a minimal realization +C of the ALPHA-stable part. +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the ALPHA-stable part of the given system. +C The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs). +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0, then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension MAX(1,2*N) +C On exit, if INFO = 0, IWORK(1) contains the order of the +C minimal realization of the ALPHA-stable part of the +C system. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than NSMIN, the sum of the order of the +C ALPHA-unstable part and the order of a minimal +C realization of the ALPHA-stable part of the given +C system. In this case, the resulting NR is set equal +C to NSMIN. +C = 2: with ORDSEL = 'F', the selected order NR is less +C than the order of the ALPHA-unstable part of the +C given system. In this case NR is set equal to the +C order of the ALPHA-unstable part. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of the ordered real Schur form of A +C failed; +C = 2: the separation of the ALPHA-stable/unstable diagonal +C blocks failed because of very close eigenvalues; +C = 3: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the following linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09ND determines for +C the given system (1), the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t) (2) +C +C such that +C +C HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C The following procedure is used to reduce a given G: +C +C 1) Decompose additively G as +C +C G = G1 + G2 +C +C such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and +C G2 = (Au,Bu,Cu,0) has only ALPHA-unstable poles. +C +C 2) Determine G1r, a reduced order approximation of the +C ALPHA-stable part G1. +C +C 3) Assemble the reduced model Gr as +C +C Gr = G1r + G2. +C +C To reduce the ALPHA-stable part G1, if JOB = 'B', the square-root +C balancing-based SPA method of [1] is used, and for an ALPHA-stable +C system, the resulting reduced model is balanced. +C +C If JOB = 'N', the balancing-free square-root SPA method of [2] +C is used to reduce the ALPHA-stable part G1. +C By setting TOL1 = TOL2, the routine can be used to compute +C Balance & Truncate approximations as well. +C +C REFERENCES +C +C [1] Liu Y. and Anderson B.D.O. +C Singular Perturbation Approximation of Balanced Systems, +C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. +C +C [2] Varga A. +C Balancing-free square-root algorithm for computing +C singular perturbation approximations. +C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, +C Vol. 2, pp. 1062-1065. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara, University "Politehnica" Bucharest. +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C February 1999. Based on the RASP routines SADSDC and SRBFSP. +C +C REVISIONS +C +C Mar. 1999, V. Sima, Research Institute for Informatics, Bucharest. +C Nov. 2000, A. Varga, DLR Oberpfaffenhofen. +C +C KEYWORDS +C +C Balancing, minimal realization, model reduction, multivariable +C system, singular perturbation approximation, state-space model, +C state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, C100 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, + $ M, N, NR, NS, P + DOUBLE PRECISION ALPHA, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL DISCR, FIXORD + INTEGER IERR, IWARNL, KT, KTI, KU, KW, KWI, KWR, LWR, + $ NN, NRA, NU, NU1, WRKOPT + DOUBLE PRECISION ALPWRK, MAXRED +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB09BX, TB01ID, TB01KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -8 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -17 + ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN + INFO = -21 + ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2 ) ) THEN + INFO = -24 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C Workspace: N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Correct the value of ALPHA to ensure stability. +C + ALPWRK = ALPHA + IF( DISCR ) THEN + IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) + ELSE + IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) + END IF +C +C Allocate working storage. +C + NN = N*N + KU = 1 + KWR = KU + NN + KWI = KWR + N + KW = KWI + N + LWR = LDWORK - KW + 1 +C +C Reduce A to a block-diagonal real Schur form, with the +C ALPHA-unstable part in the leading diagonal position, using a +C non-orthogonal similarity transformation A <- inv(T)*A*T and +C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, + $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KWR), + $ DWORK(KWI), DWORK(KW), LWR, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 1 + ELSE + INFO = 2 + END IF + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C + IWARNL = 0 + NS = N - NU + IF( FIXORD ) THEN + NRA = MAX( 0, NR-NU ) + IF( NR.LT.NU ) + $ IWARNL = 2 + ELSE + NRA = 0 + END IF +C +C Finish if only unstable part is present. +C + IF( NS.EQ.0 ) THEN + NR = NU + IWORK(1) = 0 + DWORK(1) = WRKOPT + RETURN + END IF +C + NU1 = NU + 1 +C +C Allocate working storage. +C + KT = 1 + KTI = KT + NN + KW = KTI + NN +C +C Compute a SPA of the stable part. +C Workspace: need N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2; +C prefer larger. +C + CALL AB09BX( DICO, JOB, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, + $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, + $ DWORK(KT), N, DWORK(KTI), N, TOL1, TOL2, IWORK, + $ DWORK(KW), LDWORK-KW+1, IWARN, IERR ) + IWARN = MAX( IWARN, IWARNL ) +C + IF( IERR.NE.0 ) THEN + INFO = IERR + 1 + RETURN + END IF +C + NR = NRA + NU +C + DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C + RETURN +C *** Last line of AB09ND *** + END diff --git a/mex/sources/libslicot/AB13AD.f b/mex/sources/libslicot/AB13AD.f new file mode 100644 index 000000000..fb2b2018e --- /dev/null +++ b/mex/sources/libslicot/AB13AD.f @@ -0,0 +1,349 @@ + DOUBLE PRECISION FUNCTION AB13AD( DICO, EQUIL, N, M, P, ALPHA, A, + $ LDA, B, LDB, C, LDC, NS, HSV, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Hankel-norm of the ALPHA-stable projection of the +C transfer-function matrix G of the state-space system (A,B,C). +C +C FUNCTION VALUE +C +C AB13AD DOUBLE PRECISION +C The Hankel-norm of the ALPHA-stable projection of G +C (if INFO = 0). +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation, i.e. the +C order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix A. For a continuous-time +C system (DICO = 'C'), ALPHA <= 0 is the boundary value for +C the real parts of eigenvalues, while for a discrete-time +C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary +C (see the Note below). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading N-by-N part of this +C array contains the state dynamics matrix A in a block +C diagonal real Schur form with its eigenvalues reordered +C and separated. The resulting A has two diagonal blocks. +C The leading NS-by-NS part of A has eigenvalues in the +C ALPHA-stability domain and the trailing (N-NS) x (N-NS) +C part has eigenvalues outside the ALPHA-stability domain. +C Note: The ALPHA-stability domain is defined either +C as the open half complex plane left to ALPHA, +C for a continous-time system (DICO = 'C'), or the +C interior of the ALPHA-radius circle centered in the +C origin, for a discrete-time system (DICO = 'D'). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading N-by-M part of this +C array contains the input/state matrix B of the transformed +C system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-N part of this +C array contains the state/output matrix C of the +C transformed system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C NS (output) INTEGER +C The dimension of the ALPHA-stable subsystem. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, the leading NS elements of HSV contain the +C Hankel singular values of the ALPHA-stable part of the +C original system ordered decreasingly. +C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*(MAX(N,M,P)+5)+N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of the ordered real Schur form of A +C failed; +C = 2: the separation of the ALPHA-stable/unstable diagonal +C blocks failed because of very close eigenvalues; +C = 3: the computed ALPHA-stable part is just stable, +C having stable eigenvalues very near to the imaginary +C axis (if DICO = 'C') or to the unit circle +C (if DICO = 'D'); +C = 4: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the following linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system, and let G be the corresponding +C transfer-function matrix. The following procedure is used to +C compute the Hankel-norm of the ALPHA-stable projection of G: +C +C 1) Decompose additively G as +C +C G = G1 + G2 +C +C such that G1 = (As,Bs,Cs) has only ALPHA-stable poles and +C G2 = (Au,Bu,Cu) has only ALPHA-unstable poles. +C For the computation of the additive decomposition, the +C algorithm presented in [1] is used. +C +C 2) Compute the Hankel-norm of ALPHA-stable projection G1 as the +C the maximum Hankel singular value of the system (As,Bs,Cs). +C The computation of the Hankel singular values is performed +C by using the square-root method of [2]. +C +C REFERENCES +C +C [1] Safonov, M.G., Jonckheere, E.A., Verma, M. and Limebeer, D.J. +C Synthesis of positive real multivariable feedback systems, +C Int. J. Control, Vol. 45, pp. 817-842, 1987. +C +C [2] Tombs, M.S. and Postlethwaite, I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C NUMERICAL ASPECTS +C +C The implemented method relies on a square-root technique. +C 3 +C The algorithms require about 17N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine SHANRM. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C Additive spectral decomposition, model reduction, +C multivariable system, state-space model, system norms. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION C100, ONE, ZERO + PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL + INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N, NS, P + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL DISCR + INTEGER IERR, KT, KW, KW1, KW2 + DOUBLE PRECISION ALPWRK, MAXRED, WRKOPT +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION AB13AX, DLAMCH + EXTERNAL AB13AX, DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL TB01ID, TB01KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2 ) ) THEN + INFO = -16 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB13AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NS = 0 + AB13AD = ZERO + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C Workspace: N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Correct the value of ALPHA to ensure stability. +C + ALPWRK = ALPHA + IF( DISCR ) THEN + IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) + ELSE + IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) + END IF +C +C Allocate working storage. +C + KT = 1 + KW1 = N*N + 1 + KW2 = KW1 + N + KW = KW2 + N +C +C Reduce A to a block diagonal real Schur form, with the +C ALPHA-stable part in the leading diagonal position, using a +C non-orthogonal similarity transformation A <- inv(T)*A*T and +C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01KD( DICO, 'Stable', 'General', N, M, P, ALPWRK, A, LDA, + $ B, LDB, C, LDC, NS, DWORK(KT), N, DWORK(KW1), + $ DWORK(KW2), DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 1 + ELSE + INFO = 2 + END IF + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C + IF( NS.EQ.0 ) THEN + AB13AD = ZERO + ELSE +C +C Workspace: need N*(MAX(N,M,P)+5)+N*(N+1)/2; +C prefer larger. +C + AB13AD = AB13AX( DICO, NS, M, P, A, LDA, B, LDB, C, LDC, HSV, + $ DWORK, LDWORK, IERR ) +C + IF( IERR.NE.0 ) THEN + INFO = IERR + 2 + RETURN + END IF +C + DWORK(1) = MAX( WRKOPT, DWORK(1) ) + END IF +C + RETURN +C *** Last line of AB13AD *** + END diff --git a/mex/sources/libslicot/AB13AX.f b/mex/sources/libslicot/AB13AX.f new file mode 100644 index 000000000..4053e2a7e --- /dev/null +++ b/mex/sources/libslicot/AB13AX.f @@ -0,0 +1,308 @@ + DOUBLE PRECISION FUNCTION AB13AX( DICO, N, M, P, A, LDA, B, LDB, + $ C, LDC, HSV, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Hankel-norm of the transfer-function matrix G of +C a stable state-space system (A,B,C). The state dynamics matrix A +C of the given system is an upper quasi-triangular matrix in +C real Schur form. +C +C FUNCTION VALUE +C +C AB13AX DOUBLE PRECISION +C The Hankel-norm of G (if INFO = 0). +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation, i.e. the +C order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state dynamics matrix A in a real Schur canonical form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, this array contains the Hankel singular +C values of the given system ordered decreasingly. +C HSV(1) is the Hankel norm of the given system. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*(MAX(N,M,P)+5)+N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the state matrix A is not stable (if DICO = 'C') +C or not convergent (if DICO = 'D'); +C = 2: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system, and let G be the corresponding +C transfer-function matrix. The Hankel-norm of G is computed as the +C the maximum Hankel singular value of the system (A,B,C). +C The computation of the Hankel singular values is performed +C by using the square-root method of [1]. +C +C REFERENCES +C +C [1] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C NUMERICAL ASPECTS +C +C The implemented method relies on a square-root technique. +C 3 +C The algorithms require about 17N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine SHANRM. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Feb. 2000, V. Sima, Research Institute for Informatics, Bucharest. +C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C Multivariable system, state-space model, system norms. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO + INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL DISCR + INTEGER I, IERR, J, KR, KS, KTAU, KU, KW, MNMP + DOUBLE PRECISION SCALEC, SCALEO, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DSCAL, DTPMV, MA02DD, MB03UD, SB03OU, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2 ) ) THEN + INFO = -13 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB13AX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + AB13AX = ZERO + DWORK(1) = ONE + RETURN + END IF +C +C Allocate N*MAX(N,M,P), N, and N*(N+1)/2 working storage for the +C matrices S, TAU, and R, respectively. S shares the storage with U. +C + KU = 1 + KS = 1 + MNMP = MAX( N, M, P ) + KTAU = KS + N*MNMP + KR = KTAU + N + KW = KR +C +C Copy C in U. +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), MNMP ) +C +C If DISCR = .FALSE., solve for R the Lyapunov equation +C 2 +C A'*(R'*R) + (R'*R)*A + scaleo * C'*C = 0 . +C +C If DISCR = .TRUE., solve for R the Lyapunov equation +C 2 +C A'*(R'*R)*A + scaleo * C'*C = R'*R . +C +C Workspace needed: N*(MAX(N,M,P)+1); +C Additional workspace: need 4*N; +C prefer larger. +C + CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), MNMP, + $ DWORK(KTAU), DWORK(KU), N, SCALEO, DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + ENDIF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C +C Pack the upper triangle of R in DWORK(KR). +C Workspace needed: N*(MAX(N,M,P) + 1) + N*(N+1)/2. +C + CALL MA02DD( 'Pack', 'Upper', N, DWORK(KU), N, DWORK(KR) ) +C + KW = KR + ( N*( N + 1 ) )/2 +C +C Copy B in S (over U). +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KS), N ) +C +C If DISCR = .FALSE., solve for S the Lyapunov equation +C 2 +C A*(S*S') + (S*S')*A' + scalec *B*B' = 0 . +C +C If DISCR = .TRUE., solve for S the Lyapunov equation +C 2 +C A*(S*S')*A' + scalec *B*B' = S*S' . +C +C Workspace needed: N*(MAX(N,M,P) + 1) + N*(N+1)/2; +C Additional workspace: need 4*N; +C prefer larger. +C + CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KS), N, + $ DWORK(KTAU), DWORK(KS), N, SCALEC, DWORK(KW), + $ LDWORK-KW+1, IERR ) +C + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) +C +C | x x | +C Compute R*S in the form | 0 x | in S. Note that R is packed. +C + J = KS + DO 10 I = 1, N + CALL DTPMV( 'Upper', 'NoTranspose', 'NonUnit', I, DWORK(KR), + $ DWORK(J), 1 ) + J = J + N + 10 CONTINUE +C +C Compute the singular values of the upper triangular matrix R*S. +C +C Workspace needed: N*MAX(N,M,P); +C Additional workspace: need MAX(1,5*N); +C prefer larger. +C + KW = KTAU + CALL MB03UD( 'NoVectors', 'NoVectors', N, DWORK(KS), N, DWORK, 1, + $ HSV, DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + ENDIF +C +C Scale singular values. +C + CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) + AB13AX = HSV(1) +C + DWORK(1) = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) +C + RETURN +C *** Last line of AB13AX *** + END diff --git a/mex/sources/libslicot/AB13BD.f b/mex/sources/libslicot/AB13BD.f new file mode 100644 index 000000000..ac69fd7b6 --- /dev/null +++ b/mex/sources/libslicot/AB13BD.f @@ -0,0 +1,390 @@ + DOUBLE PRECISION FUNCTION AB13BD( DICO, JOBN, N, M, P, A, LDA, + $ B, LDB, C, LDC, D, LDD, NQ, TOL, + $ DWORK, LDWORK, IWARN, INFO) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the H2 or L2 norm of the transfer-function matrix G +C of the system (A,B,C,D). G must not have poles on the imaginary +C axis, for a continuous-time system, or on the unit circle, for +C a discrete-time system. If the H2-norm is computed, the system +C must be stable. +C +C FUNCTION VALUE +C +C AB13BD DOUBLE PRECISION +C The H2-norm of G, if JOBN = 'H', or the L2-norm of G, +C if JOBN = 'L' (if INFO = 0). +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBN CHARACTER*1 +C Specifies the norm to be computed as follows: +C = 'H': the H2-norm; +C = 'L': the L2-norm. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A, the number of rows of the +C matrix B, and the number of columns of the matrix C. +C N represents the dimension of the state vector. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrices B and D. +C M represents the dimension of input vector. M >= 0. +C +C P (input) INTEGER +C The number of rows of the matrices C and D. +C P represents the dimension of output vector. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix of the system. +C On exit, the leading NQ-by-NQ part of this array contains +C the state dynamics matrix (in a real Schur form) of the +C numerator factor Q of the right coprime factorization with +C inner denominator of G (see METHOD). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix of the system. +C On exit, the leading NQ-by-M part of this array contains +C the input/state matrix of the numerator factor Q of the +C right coprime factorization with inner denominator of G +C (see METHOD). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix of the system. +C On exit, the leading P-by-NQ part of this array contains +C the state/output matrix of the numerator factor Q of the +C right coprime factorization with inner denominator of G +C (see METHOD). +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the input/output matrix of the system. +C If DICO = 'C', D must be a null matrix. +C On exit, the leading P-by-M part of this array contains +C the input/output matrix of the numerator factor Q of +C the right coprime factorization with inner denominator +C of G (see METHOD). +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NQ (output) INTEGER +C The order of the resulting numerator Q of the right +C coprime factorization with inner denominator of G (see +C METHOD). +C Generally, NQ = N - NS, where NS is the number of +C uncontrollable unstable eigenvalues. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The absolute tolerance level below which the elements of +C B are considered zero (used for controllability tests). +C If the user sets TOL <= 0, then an implicitly computed, +C default tolerance, defined by TOLDEF = N*EPS*NORM(B), +C is used instead, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH) and NORM(B) denotes +C the 1-norm of B. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LDWORK >= MAX( 1, M*(N+M) + MAX( N*(N+5), M*(M+2), 4*P ), +C N*( MAX( N, P ) + 4 ) + MIN( N, P ) ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = K: K violations of the numerical stability condition +C occured during the assignment of eigenvalues in +C computing the right coprime factorization with inner +C denominator of G (see the SLICOT subroutine SB08DD). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the reordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + B*F)*Z +C along the diagonal (see SLICOT routine SB08DD); +C = 3: if DICO = 'C' and the matrix A has a controllable +C eigenvalue on the imaginary axis, or DICO = 'D' +C and A has a controllable eigenvalue on the unit +C circle; +C = 4: the solution of Lyapunov equation failed because +C the equation is singular; +C = 5: if DICO = 'C' and D is a nonzero matrix; +C = 6: if JOBN = 'H' and the system is unstable. +C +C METHOD +C +C The subroutine is based on the algorithms proposed in [1] and [2]. +C +C If the given transfer-function matrix G is unstable, then a right +C coprime factorization with inner denominator of G is first +C computed +C -1 +C G = Q*R , +C +C where Q and R are stable transfer-function matrices and R is +C inner. If G is stable, then Q = G and R = I. +C Let (AQ,BQ,CQ,DQ) be the state-space representation of Q. +C +C If DICO = 'C', then the L2-norm of G is computed as +C +C NORM2(G) = NORM2(Q) = SQRT(TRACE(BQ'*X*BQ)), +C +C where X satisfies the continuous-time Lyapunov equation +C +C AQ'*X + X*AQ + CQ'*CQ = 0. +C +C If DICO = 'D', then the l2-norm of G is computed as +C +C NORM2(G) = NORM2(Q) = SQRT(TRACE(BQ'*X*BQ+DQ'*DQ)), +C +C where X satisfies the discrete-time Lyapunov equation +C +C AQ'*X*AQ - X + CQ'*CQ = 0. +C +C REFERENCES +C +C [1] Varga A. +C On computing 2-norms of transfer-function matrices. +C Proc. 1992 ACC, Chicago, June 1992. +C +C [2] Varga A. +C A Schur method for computing coprime factorizations with +C inner denominators and applications in model reduction. +C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires no more than 14N floating point +C operations. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine SL2NRM. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. +C Jan. 2003, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C Coprime factorization, Lyapunov equation, multivariable system, +C state-space model, system norms. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBN + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, M, + $ N, NQ, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) +C .. Local Scalars .. + LOGICAL DISCR + INTEGER KCR, KDR, KRW, KTAU, KU, MXNP, NR + DOUBLE PRECISION S2NORM, SCALE, WRKOPT +C .. External functions .. + LOGICAL LSAME + DOUBLE PRECISION DLANGE, DLAPY2 + EXTERNAL DLANGE, DLAPY2, LSAME +C .. External subroutines .. + EXTERNAL DLACPY, DTRMM, SB03OU, SB08DD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + INFO = 0 + IWARN = 0 +C +C Check the scalar input parameters. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( JOBN, 'H' ) .OR. LSAME( JOBN, 'L' ) ) ) + $ THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDWORK.LT.MAX( 1, M*( N + M ) + + $ MAX( N*( N + 5 ), M*( M + 2 ), 4*P ), + $ N*( MAX( N, P ) + 4 ) + MIN( N, P ) ) ) + $ THEN + INFO = -17 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'AB13BD', -INFO ) + RETURN + END IF +C +C Compute the Frobenius norm of D. +C + S2NORM = DLANGE( 'Frobenius', P, M, D, LDD, DWORK ) + IF( .NOT.DISCR .AND. S2NORM.NE.ZERO ) THEN + INFO = 5 + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NQ = 0 + AB13BD = ZERO + DWORK(1) = ONE + RETURN + END IF +C + KCR = 1 + KDR = KCR + M*N + KRW = KDR + M*M +C +C Compute the right coprime factorization with inner denominator +C of G. +C +C Workspace needed: M*(N+M); +C Additional workspace: need MAX( N*(N+5), M*(M+2), 4*M, 4*P ); +C prefer larger. +C + CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, NQ, + $ NR, DWORK(KCR), M, DWORK(KDR), M, TOL, DWORK(KRW), + $ LDWORK-KRW+1, IWARN, INFO ) + IF( INFO.NE.0 ) + $ RETURN +C + WRKOPT = DWORK(KRW) + DBLE( KRW-1 ) +C +C Check stability. +C + IF( LSAME( JOBN, 'H' ) .AND. NR.GT.0 ) THEN + INFO = 6 + RETURN + END IF +C + IF( NQ.GT.0 ) THEN + KU = 1 + MXNP = MAX( NQ, P ) + KTAU = NQ*MXNP + 1 + KRW = KTAU + MIN( NQ, P ) +C +C Find X, the solution of Lyapunov equation. +C +C Workspace needed: N*MAX(N,P) + MIN(N,P); +C Additional workspace: 4*N; +C prefer larger. +C + CALL DLACPY( 'Full', P, NQ, C, LDC, DWORK(KU), MXNP ) + CALL SB03OU( DISCR, .FALSE., NQ, P, A, LDA, DWORK(KU), MXNP, + $ DWORK(KTAU), DWORK(KU), NQ, SCALE, DWORK(KRW), + $ LDWORK-KRW+1, INFO ) + IF( INFO.NE.0 ) THEN + IF( INFO.EQ.1 ) THEN + INFO = 4 + ELSE IF( INFO.EQ.2 ) THEN + INFO = 3 + END IF + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(KRW) + DBLE( KRW-1 ) ) +C +C Add the contribution of BQ'*X*BQ. +C +C Workspace needed: N*(N+M). +C + KTAU = NQ*NQ + 1 + CALL DLACPY( 'Full', NQ, M, B, LDB, DWORK(KTAU), NQ ) + CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', NQ, M, + $ ONE, DWORK(KU), NQ, DWORK(KTAU), NQ ) + IF( NR.GT.0 ) + $ S2NORM = DLANGE( 'Frobenius', P, M, D, LDD, DWORK ) + S2NORM = DLAPY2( S2NORM, DLANGE( 'Frobenius', NQ, M, + $ DWORK(KTAU), NQ, DWORK ) + $ / SCALE ) + END IF +C + AB13BD = S2NORM +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB13BD *** + END diff --git a/mex/sources/libslicot/AB13CD.f b/mex/sources/libslicot/AB13CD.f new file mode 100644 index 000000000..ec9fa2559 --- /dev/null +++ b/mex/sources/libslicot/AB13CD.f @@ -0,0 +1,601 @@ + DOUBLE PRECISION FUNCTION AB13CD( N, M, NP, A, LDA, B, LDB, C, + $ LDC, D, LDD, TOL, IWORK, DWORK, + $ LDWORK, CWORK, LCWORK, BWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the H-infinity norm of the continuous-time stable +C system +C +C | A | B | +C G(s) = |---|---| . +C | C | D | +C +C FUNCTION VALUE +C +C AB13CD DOUBLE PRECISION +C If INFO = 0, the H-infinity norm of the system, HNORM, +C i.e., the peak gain of the frequency response (as measured +C by the largest singular value in the MIMO case). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used to set the accuracy in determining the +C norm. +C +C Workspace +C +C IWORK INTEGER array, dimension N +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK, and DWORK(2) contains the frequency where the +C gain of the frequency response achieves its peak value +C HNORM. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= max(2,4*N*N+2*M*M+3*M*N+M*NP+2*(N+NP)*NP+10*N+ +C 6*max(M,NP)). +C For good performance, LDWORK must generally be larger. +C +C CWORK COMPLEX*16 array, dimension (LCWORK) +C On exit, if INFO = 0, CWORK(1) contains the optimal value +C of LCWORK. +C +C LCWORK INTEGER +C The dimension of the array CWORK. +C LCWORK >= max(1,(N+M)*(N+NP)+3*max(M,NP)). +C For good performance, LCWORK must generally be larger. +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the system is unstable; +C = 2: the tolerance is too small (the algorithm for +C computing the H-infinity norm did not converge); +C = 3: errors in computing the eigenvalues of A or of the +C Hamiltonian matrix (the QR algorithm did not +C converge); +C = 4: errors in computing singular values. +C +C METHOD +C +C The routine implements the method presented in [1]. +C +C REFERENCES +C +C [1] Bruinsma, N.A. and Steinbuch, M. +C A fast algorithm to compute the Hinfinity-norm of a transfer +C function matrix. +C Systems & Control Letters, vol. 14, pp. 287-293, 1990. +C +C NUMERICAL ASPECTS +C +C If the algorithm does not converge (INFO = 2), the tolerance must +C be increased. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, May 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999, +C Oct. 2000. +C P.Hr. Petkov, October 2000. +C A. Varga, October 2000. +C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C H-infinity optimal control, robust control, system norm. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 10 ) + COMPLEX*16 CONE, JIMAG + PARAMETER ( CONE = ( 1.0D0, 0.0D0 ), + $ JIMAG = ( 0.0D0, 1.0D0 ) ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) + DOUBLE PRECISION HUGE + PARAMETER ( HUGE = 10.0D+0**30 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LCWORK, LDD, LDWORK, M, N, + $ NP + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + COMPLEX*16 CWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), DWORK( * ) + LOGICAL BWORK( * ) +C .. +C .. Local Scalars .. + INTEGER I, ICW2, ICW3, ICW4, ICWRK, INFO2, ITER, IW10, + $ IW11, IW12, IW2, IW3, IW4, IW5, IW6, IW7, IW8, + $ IW9, IWRK, J, K, L, LCWAMX, LWAMAX, MINCWR, + $ MINWRK, SDIM + DOUBLE PRECISION DEN, FPEAK, GAMMA, GAMMAL, GAMMAU, OMEGA, RAT, + $ RATMAX, TEMP, WIMAX, WRMIN + LOGICAL COMPLX +C +C .. External Functions .. + DOUBLE PRECISION DLAPY2 + LOGICAL SB02MV, SB02CX + EXTERNAL DLAPY2, SB02MV, SB02CX +C .. +C .. External Subroutines .. + EXTERNAL DGEES, DGEMM, DGESV, DGESVD, DLACPY, DPOSV, + $ DPOTRF, DPOTRS, DSYRK, MA02ED, MB01RX, XERBLA, + $ ZGEMM, ZGESV, ZGESVD +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar parameters. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -11 + END IF +C +C Compute workspace. +C + MINWRK = MAX( 2, 4*N*N + 2*M*M + 3*M*N + M*NP + 2*( N + NP )*NP + + $ 10*N + 6*MAX( M, NP ) ) + IF( LDWORK.LT.MINWRK ) THEN + INFO = -15 + END IF + MINCWR = MAX( 1, ( N + M )*( N + NP ) + 3*MAX( M, NP ) ) + IF( LCWORK.LT.MINCWR ) THEN + INFO = -17 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'AB13CD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( M.EQ.0 .OR. NP.EQ.0 ) RETURN +C +C Workspace usage. +C + IW2 = N + IW3 = IW2 + N + IW4 = IW3 + N*N + IW5 = IW4 + N*M + IW6 = IW5 + NP*M + IWRK = IW6 + MIN( NP, M ) +C +C Determine the maximum singular value of G(infinity) = D . +C + CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IW5+1 ), NP ) + CALL DGESVD( 'N', 'N', NP, M, DWORK( IW5+1 ), NP, DWORK( IW6+1 ), + $ DWORK, NP, DWORK, M, DWORK( IWRK+1 ), LDWORK-IWRK, + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 4 + RETURN + END IF + GAMMAL = DWORK( IW6+1 ) + FPEAK = HUGE + LWAMAX = INT( DWORK( IWRK+1 ) ) + IWRK +C +C Quick return if N = 0 . +C + IF( N.EQ.0 ) THEN + AB13CD = GAMMAL + DWORK(1) = TWO + DWORK(2) = ZERO + CWORK(1) = ONE + RETURN + END IF +C +C Stability check. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IW3+1 ), N ) + CALL DGEES( 'N', 'S', SB02MV, N, DWORK( IW3+1 ), N, SDIM, DWORK, + $ DWORK( IW2+1 ), DWORK, N, DWORK( IWRK+1 ), + $ LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 3 + RETURN + END IF + IF( SDIM.LT.N ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK+1 ) ) + IWRK, LWAMAX ) +C +C Determine the maximum singular value of G(0) = -C*inv(A)*B + D . +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IW3+1 ), N ) + CALL DLACPY( 'Full', N, M, B, LDB, DWORK( IW4+1 ), N ) + CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IW5+1 ), NP ) + CALL DGESV( N, M, DWORK( IW3+1 ), N, IWORK, DWORK( IW4+1 ), N, + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + CALL DGEMM( 'N', 'N', NP, M, N, -ONE, C, LDC, DWORK( IW4+1 ), N, + $ ONE, DWORK( IW5+1 ), NP ) + CALL DGESVD( 'N', 'N', NP, M, DWORK( IW5+1 ), NP, DWORK( IW6+1 ), + $ DWORK, NP, DWORK, M, DWORK( IWRK+1 ), LDWORK-IWRK, + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 4 + RETURN + END IF + IF( GAMMAL.LT.DWORK( IW6+1 ) ) THEN + GAMMAL = DWORK( IW6+1 ) + FPEAK = ZERO + END IF + LWAMAX = MAX( INT( DWORK( IWRK+1 ) ) + IWRK, LWAMAX ) +C +C Find a frequency which is close to the peak frequency. +C + COMPLX = .FALSE. + DO 10 I = 1, N + IF( DWORK( IW2+I ).NE.ZERO ) COMPLX = .TRUE. + 10 CONTINUE + IF( .NOT.COMPLX ) THEN + WRMIN = ABS( DWORK( 1 ) ) + DO 20 I = 2, N + IF( WRMIN.GT.ABS( DWORK( I ) ) ) WRMIN = ABS( DWORK( I ) ) + 20 CONTINUE + OMEGA = WRMIN + ELSE + RATMAX = ZERO + DO 30 I = 1, N + DEN = DLAPY2( DWORK( I ), DWORK( IW2+I ) ) + RAT = ABS( ( DWORK( IW2+I )/DWORK( I ) )/DEN ) + IF( RATMAX.LT.RAT ) THEN + RATMAX = RAT + WIMAX = DEN + END IF + 30 CONTINUE + OMEGA = WIMAX + END IF +C +C Workspace usage. +C + ICW2 = N*N + ICW3 = ICW2 + N*M + ICW4 = ICW3 + NP*N + ICWRK = ICW4 + NP*M +C +C Determine the maximum singular value of +C G(omega) = C*inv(j*omega*In - A)*B + D . +C + DO 50 J = 1, N + DO 40 I = 1, N + CWORK( I+(J-1)*N ) = -A( I, J ) + 40 CONTINUE + CWORK( J+(J-1)*N ) = JIMAG*OMEGA - A( J, J ) + 50 CONTINUE + DO 70 J = 1, M + DO 60 I = 1, N + CWORK( ICW2+I+(J-1)*N ) = B( I, J ) + 60 CONTINUE + 70 CONTINUE + DO 90 J = 1, N + DO 80 I = 1, NP + CWORK( ICW3+I+(J-1)*NP ) = C( I, J ) + 80 CONTINUE + 90 CONTINUE + DO 110 J = 1, M + DO 100 I = 1, NP + CWORK( ICW4+I+(J-1)*NP ) = D( I, J ) + 100 CONTINUE + 110 CONTINUE + CALL ZGESV( N, M, CWORK, N, IWORK, CWORK( ICW2+1 ), N, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + CALL ZGEMM( 'N', 'N', NP, M, N, CONE, CWORK( ICW3+1 ), NP, + $ CWORK( ICW2+1 ), N, CONE, CWORK( ICW4+1 ), NP ) + CALL ZGESVD( 'N', 'N', NP, M, CWORK( ICW4+1 ), NP, DWORK( IW6+1 ), + $ CWORK, NP, CWORK, M, CWORK( ICWRK+1 ), LCWORK-ICWRK, + $ DWORK( IWRK+1 ), INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 4 + RETURN + END IF + IF( GAMMAL.LT.DWORK( IW6+1 ) ) THEN + GAMMAL = DWORK( IW6+1 ) + FPEAK = OMEGA + END IF + LCWAMX = INT( CWORK( ICWRK+1 ) ) + ICWRK +C +C Workspace usage. +C + IW2 = M*N + IW3 = IW2 + M*M + IW4 = IW3 + NP*NP + IW5 = IW4 + M*M + IW6 = IW5 + M*N + IW7 = IW6 + M*N + IW8 = IW7 + NP*NP + IW9 = IW8 + NP*N + IW10 = IW9 + 4*N*N + IW11 = IW10 + 2*N + IW12 = IW11 + 2*N + IWRK = IW12 + MIN( NP, M ) +C +C Compute D'*C . +C + CALL DGEMM( 'T', 'N', M, N, NP, ONE, D, LDD, C, LDC, ZERO, + $ DWORK, M ) +C +C Compute D'*D . +C + CALL DSYRK( 'U', 'T', M, NP, ONE, D, LDD, ZERO, DWORK( IW2+1 ), + $ M ) +C +C Compute D*D' . +C + CALL DSYRK( 'U', 'N', NP, M, ONE, D, LDD, ZERO, DWORK( IW3+1 ), + $ NP ) +C +C Main iteration loop for gamma. +C + ITER = 0 + 120 ITER = ITER + 1 + IF( ITER.GT.MAXIT ) THEN + INFO = 2 + RETURN + END IF + GAMMA = ( ONE + TWO*TOL )*GAMMAL +C +C Compute R = GAMMA^2*Im - D'*D . +C + DO 140 J = 1, M + DO 130 I = 1, J + DWORK( IW4+I+(J-1)*M ) = -DWORK( IW2+I+(J-1)*M ) + 130 CONTINUE + DWORK( IW4+J+(J-1)*M ) = GAMMA**2 - DWORK( IW2+J+(J-1)*M ) + 140 CONTINUE +C +C Compute inv(R)*D'*C . +C + CALL DLACPY( 'Full', M, N, DWORK, M, DWORK( IW5+1 ), M ) + CALL DPOTRF( 'U', M, DWORK( IW4+1 ), M, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF + CALL DPOTRS( 'U', M, N, DWORK( IW4+1 ), M, DWORK( IW5+1 ), M, + $ INFO2 ) +C +C Compute inv(R)*B' . +C + DO 160 J = 1, N + DO 150 I = 1, M + DWORK( IW6+I+(J-1)*M ) = B( J, I ) + 150 CONTINUE + 160 CONTINUE + CALL DPOTRS( 'U', M, N, DWORK( IW4+1 ), M, DWORK( IW6+1 ), M, + $ INFO2 ) +C +C Compute S = GAMMA^2*Ip - D*D' . +C + DO 180 J = 1, NP + DO 170 I = 1, J + DWORK( IW7+I+(J-1)*NP ) = -DWORK( IW3+I+(J-1)*NP ) + 170 CONTINUE + DWORK( IW7+J+(J-1)*NP ) = GAMMA**2 - DWORK( IW3+J+(J-1)*NP ) + 180 CONTINUE +C +C Compute inv(S)*C . +C + CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IW8+1 ), NP ) + CALL DPOSV( 'U', NP, N, DWORK( IW7+1 ), NP, DWORK( IW8+1 ), NP, + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF +C +C Construct the Hamiltonian matrix . +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IW9+1 ), 2*N ) + CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, DWORK( IW5+1 ), M, + $ ONE, DWORK( IW9+1 ), 2*N ) + CALL MB01RX( 'Left', 'Upper', 'Transpose', N, NP, ZERO, -GAMMA, + $ DWORK( IW9+N+1 ), 2*N, C, LDC, DWORK( IW8+1 ), NP, + $ INFO2 ) + CALL MA02ED( 'Upper', N, DWORK( IW9+N+1 ), 2*N ) + CALL MB01RX( 'Left', 'Upper', 'NoTranspose', N, M, ZERO, GAMMA, + $ DWORK( IW9+2*N*N+1 ), 2*N, B, LDB, DWORK( IW6+1 ), M, + $ INFO2 ) + CALL MA02ED( 'Upper', N, DWORK( IW9+2*N*N+1 ), 2*N ) + DO 200 J = 1, N + DO 190 I = 1, N + DWORK( IW9+2*N*N+N+I+(J-1)*2*N ) = -DWORK( IW9+J+(I-1)*2*N ) + 190 CONTINUE + 200 CONTINUE +C +C Compute the eigenvalues of the Hamiltonian matrix. +C + CALL DGEES( 'N', 'S', SB02CX, 2*N, DWORK( IW9+1 ), 2*N, SDIM, + $ DWORK( IW10+1 ), DWORK( IW11+1 ), DWORK, 2*N, + $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK+1 ) ) + IWRK, LWAMAX ) +C + IF( SDIM.EQ.0 ) THEN + GAMMAU = GAMMA + GO TO 330 + END IF +C +C Store the positive imaginary parts. +C + J = 0 + DO 210 I = 1, SDIM-1, 2 + J = J + 1 + DWORK( IW10+J ) = DWORK( IW11+I ) + 210 CONTINUE + K = J +C + IF( K.GE.2 ) THEN +C +C Reorder the imaginary parts. +C + DO 230 J = 1, K-1 + DO 220 L = J+1, K + IF( DWORK( IW10+J ).LE. DWORK( IW10+L ) ) GO TO 220 + TEMP = DWORK( IW10+J ) + DWORK( IW10+J ) = DWORK( IW10+L ) + DWORK( IW10+L ) = TEMP + 220 CONTINUE + 230 CONTINUE +C +C Determine the next frequency. +C + DO 320 L = 1, K - 1 + OMEGA = ( DWORK( IW10+L ) + DWORK( IW10+L+1 ) )/TWO + DO 250 J = 1, N + DO 240 I = 1, N + CWORK( I+(J-1)*N ) = -A( I, J ) + 240 CONTINUE + CWORK( J+(J-1)*N ) = JIMAG*OMEGA - A( J, J ) + 250 CONTINUE + DO 270 J = 1, M + DO 260 I = 1, N + CWORK( ICW2+I+(J-1)*N ) = B( I, J ) + 260 CONTINUE + 270 CONTINUE + DO 290 J = 1, N + DO 280 I = 1, NP + CWORK( ICW3+I+(J-1)*NP ) = C( I, J ) + 280 CONTINUE + 290 CONTINUE + DO 310 J = 1, M + DO 300 I = 1, NP + CWORK( ICW4+I+(J-1)*NP ) = D( I, J ) + 300 CONTINUE + 310 CONTINUE + CALL ZGESV( N, M, CWORK, N, IWORK, CWORK( ICW2+1 ), N, + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + CALL ZGEMM( 'N', 'N', NP, M, N, CONE, CWORK( ICW3+1 ), NP, + $ CWORK( ICW2+1 ), N, CONE, CWORK( ICW4+1 ), NP ) + CALL ZGESVD( 'N', 'N', NP, M, CWORK( ICW4+1 ), NP, + $ DWORK( IW6+1 ), CWORK, NP, CWORK, M, + $ CWORK( ICWRK+1 ), LCWORK-ICWRK, + $ DWORK( IWRK+1 ), INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 4 + RETURN + END IF + IF( GAMMAL.LT.DWORK( IW6+1 ) ) THEN + GAMMAL = DWORK( IW6+1 ) + FPEAK = OMEGA + END IF + LCWAMX = MAX( INT( CWORK( ICWRK+1 ) ) + ICWRK, LCWAMX ) + 320 CONTINUE + END IF + GO TO 120 + 330 AB13CD = ( GAMMAL + GAMMAU )/TWO +C + DWORK( 1 ) = LWAMAX + DWORK( 2 ) = FPEAK + CWORK( 1 ) = LCWAMX + RETURN +C *** End of AB13CD *** + END diff --git a/mex/sources/libslicot/AB13DD.f b/mex/sources/libslicot/AB13DD.f new file mode 100644 index 000000000..e9df19f47 --- /dev/null +++ b/mex/sources/libslicot/AB13DD.f @@ -0,0 +1,1870 @@ + SUBROUTINE AB13DD( DICO, JOBE, EQUIL, JOBD, N, M, P, FPEAK, + $ A, LDA, E, LDE, B, LDB, C, LDC, D, LDD, GPEAK, + $ TOL, IWORK, DWORK, LDWORK, CWORK, LCWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the L-infinity norm of a continuous-time or +C discrete-time system, either standard or in the descriptor form, +C +C -1 +C G(lambda) = C*( lambda*E - A ) *B + D . +C +C The norm is finite if and only if the matrix pair (A,E) has no +C eigenvalue on the boundary of the stability domain, i.e., the +C imaginary axis, or the unit circle, respectively. It is assumed +C that the matrix E is nonsingular. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system, as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBE CHARACTER*1 +C Specifies whether E is a general square or an identity +C matrix, as follows: +C = 'G': E is a general square matrix; +C = 'I': E is the identity matrix. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the system (A,E,B,C) or (A,B,C), as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears in +C the given state space model: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C P (input) INTEGER +C The row size of the matrix C. P >= 0. +C +C FPEAK (input/output) DOUBLE PRECISION array, dimension (2) +C On entry, this parameter must contain an estimate of the +C frequency where the gain of the frequency response would +C achieve its peak value. Setting FPEAK(2) = 0 indicates an +C infinite frequency. An accurate estimate could reduce the +C number of iterations of the iterative algorithm. If no +C estimate is available, set FPEAK(1) = 0, and FPEAK(2) = 1. +C FPEAK(1) >= 0, FPEAK(2) >= 0. +C On exit, if INFO = 0, this array contains the frequency +C OMEGA, where the gain of the frequency response achieves +C its peak value GPEAK, i.e., +C +C || G ( j*OMEGA ) || = GPEAK , if DICO = 'C', or +C +C j*OMEGA +C || G ( e ) || = GPEAK , if DICO = 'D', +C +C where OMEGA = FPEAK(1), if FPEAK(2) > 0, and OMEGA is +C infinite, if FPEAK(2) = 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state dynamics matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C If JOBE = 'G', the leading N-by-N part of this array must +C contain the descriptor matrix E of the system. +C If JOBE = 'I', then E is assumed to be the identity +C matrix and is not referenced. +C +C LDE INTEGER +C The leading dimension of the array E. +C LDE >= MAX(1,N), if JOBE = 'G'; +C LDE >= 1, if JOBE = 'I'. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C If JOBD = 'D', the leading P-by-M part of this array must +C contain the direct transmission matrix D. +C The array D is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P), if JOBD = 'D'; +C LDD >= 1, if JOBD = 'Z'. +C +C GPEAK (output) DOUBLE PRECISION array, dimension (2) +C The L-infinity norm of the system, i.e., the peak gain +C of the frequency response (as measured by the largest +C singular value in the MIMO case), coded in the same way +C as FPEAK. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used to set the accuracy in determining the +C norm. 0 <= TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= K, where K can be computed using the following +C pseudo-code (or the Fortran code included in the routine) +C +C d = 6*MIN(P,M); +C c = MAX( 4*MIN(P,M) + MAX(P,M), d ); +C if ( MIN(P,M) = 0 ) then +C K = 1; +C else if( N = 0 or B = 0 or C = 0 ) then +C if( JOBD = 'D' ) then +C K = P*M + c; +C else +C K = 1; +C end +C else +C if ( DICO = 'D' ) then +C b = 0; e = d; +C else +C b = N*(N+M); e = c; +C if ( JOBD = Z' ) then b = b + P*M; end +C end +C if ( JOBD = 'D' ) then +C r = P*M; +C if ( JOBE = 'I', DICO = 'C', +C N > 0, B <> 0, C <> 0 ) then +C K = P*P + M*M; +C r = r + N*(P+M); +C else +C K = 0; +C end +C K = K + r + c; r = r + MIN(P,M); +C else +C r = 0; K = 0; +C end +C r = r + N*(N+P+M); +C if ( JOBE = 'G' ) then +C r = r + N*N; +C if ( EQUIL = 'S' ) then +C K = MAX( K, r + 9*N ); +C end +C K = MAX( K, r + 4*N + MAX( M, 2*N*N, N+b+e ) ); +C else +C K = MAX( K, r + N + +C MAX( M, P, N*N+2*N, 3*N+b+e ) ); +C end +C w = 0; +C if ( JOBE = 'I', DICO = 'C' ) then +C w = r + 4*N*N + 11*N; +C if ( JOBD = 'D' ) then +C w = w + MAX(M,P) + N*(P+M); +C end +C end +C if ( JOBE = 'E' or DICO = 'D' or JOBD = 'D' ) then +C w = MAX( w, r + 6*N + (2*N+P+M)*(2*N+P+M) + +C MAX( 2*(N+P+M), 8*N*N + 16*N ) ); +C end +C K = MAX( 1, K, w, r + 2*N + e ); +C end +C +C For good performance, LDWORK must generally be larger. +C +C An easily computable upper bound is +C +C K = MAX( 1, 15*N*N + P*P + M*M + (6*N+3)*(P+M) + 4*P*M + +C N*M + 22*N + 7*MIN(P,M) ). +C +C The smallest workspace is obtained for DICO = 'C', +C JOBE = 'I', and JOBD = 'Z', namely +C +C K = MAX( 1, N*N + N*P + N*M + N + +C MAX( N*N + N*M + P*M + 3*N + c, +C 4*N*N + 10*N ) ). +C +C for which an upper bound is +C +C K = MAX( 1, 6*N*N + N*P + 2*N*M + P*M + 11*N + MAX(P,M) + +C 6*MIN(P,M) ). +C +C CWORK COMPLEX*16 array, dimension (LCWORK) +C On exit, if INFO = 0, CWORK(1) contains the optimal +C LCWORK. +C +C LCWORK INTEGER +C The dimension of the array CWORK. +C LCWORK >= 1, if N = 0, or B = 0, or C = 0; +C LCWORK >= MAX(1, (N+M)*(N+P) + 2*MIN(P,M) + MAX(P,M)), +C otherwise. +C For good performance, LCWORK must generally be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the matrix E is (numerically) singular; +C = 2: the (periodic) QR (or QZ) algorithm for computing +C eigenvalues did not converge; +C = 3: the SVD algorithm for computing singular values did +C not converge; +C = 4: the tolerance is too small and the algorithm did +C not converge. +C +C METHOD +C +C The routine implements the method presented in [1], with +C extensions and refinements for improving numerical robustness and +C efficiency. Structure-exploiting eigenvalue computations for +C Hamiltonian matrices are used if JOBE = 'I', DICO = 'C', and the +C symmetric matrices to be implicitly inverted are not too ill- +C conditioned. Otherwise, generalized eigenvalue computations are +C used in the iterative algorithm of [1]. +C +C REFERENCES +C +C [1] Bruinsma, N.A. and Steinbuch, M. +C A fast algorithm to compute the Hinfinity-norm of a transfer +C function matrix. +C Systems & Control Letters, vol. 14, pp. 287-293, 1990. +C +C NUMERICAL ASPECTS +C +C If the algorithm does not converge in MAXIT = 30 iterations +C (INFO = 4), the tolerance must be increased. +C +C FURTHER COMMENTS +C +C If the matrix E is singular, other SLICOT Library routines +C could be used before calling AB13DD, for removing the singular +C part of the system. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2001. +C V. Sima, Research Institute for Informatics, Bucharest, May 2001. +C Partly based on SLICOT Library routine AB13CD by P.Hr. Petkov, +C D.W. Gu and M.M. Konstantinov. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001, +C May 2003, Aug. 2005, March 2008, May 2009, Sep. 2009. +C +C KEYWORDS +C +C H-infinity optimal control, robust control, system norm. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 30 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) + DOUBLE PRECISION ZERO, ONE, TWO, FOUR, P25 + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+0, P25 = 0.25D+0 ) + DOUBLE PRECISION TEN, HUNDRD, THOUSD + PARAMETER ( TEN = 1.0D+1, HUNDRD = 1.0D+2, + $ THOUSD = 1.0D+3 ) +C .. +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOBD, JOBE + INTEGER INFO, LCWORK, LDA, LDB, LDC, LDD, LDE, LDWORK, + $ M, N, P + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + COMPLEX*16 CWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), DWORK( * ), E( LDE, * ), + $ FPEAK( 2 ), GPEAK( 2 ) + INTEGER IWORK( * ) +C .. +C .. Local Scalars .. + CHARACTER VECT + LOGICAL DISCR, FULLE, ILASCL, ILESCL, LEQUIL, NODYN, + $ USEPEN, WITHD + INTEGER I, IA, IAR, IAS, IB, IBS, IBT, IBV, IC, ICU, + $ ID, IE, IERR, IES, IH, IH12, IHI, II, ILO, IM, + $ IMIN, IPA, IPE, IR, IS, ISB, ISC, ISL, ITAU, + $ ITER, IU, IV, IWRK, J, K, LW, MAXCWK, MAXWRK, + $ MINCWR, MINPM, MINWRK, N2, N2PM, NEI, NN, NWS, + $ NY, PM + DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNORM, BOUND, CNORM, + $ ENRM, ENRMTO, EPS, FPEAKI, FPEAKS, GAMMA, + $ GAMMAL, GAMMAS, MAXRED, OMEGA, PI, RAT, RCOND, + $ RTOL, SAFMAX, SAFMIN, SMLNUM, TM, TOLER, WMAX, + $ WRMIN +C .. +C .. Local Arrays .. + DOUBLE PRECISION TEMP( 1 ) +C .. +C .. External Functions .. + DOUBLE PRECISION AB13DX, DLAMCH, DLANGE, DLAPY2 + LOGICAL LSAME + EXTERNAL AB13DX, DLAMCH, DLANGE, DLAPY2, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DGEBAL, DGEHRD, DGEMM, DGEQRF, DGESVD, + $ DGGBAL, DGGEV, DHGEQZ, DHSEQR, DLABAD, DLACPY, + $ DLASCL, DLASRT, DORGQR, DORMHR, DSWAP, DSYRK, + $ DTRCON, MA02AD, MB01SD, MB03XD, TB01ID, TG01AD, + $ TG01BD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, ATAN, ATAN2, COS, DBLE, INT, LOG, MAX, + $ MIN, SIN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar parameters. +C + N2 = 2*N + NN = N*N + PM = P + M + N2PM = N2 + PM + MINPM = MIN( P, M ) + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + FULLE = LSAME( JOBE, 'G' ) + LEQUIL = LSAME( EQUIL, 'S' ) + WITHD = LSAME( JOBD, 'D' ) +C + IF( .NOT. ( DISCR .OR. LSAME( DICO, 'C' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( FULLE .OR. LSAME( JOBE, 'I' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LEQUIL .OR. LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( MIN( FPEAK( 1 ), FPEAK( 2 ) ).LT.ZERO ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDE.LT.1 .OR. ( FULLE .AND. LDE.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN + INFO = -18 + ELSE IF( TOL.LT.ZERO .OR. TOL.GE.ONE ) THEN + INFO = -20 + ELSE + BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) + CNORM = DLANGE( '1-norm', P, N, C, LDC, DWORK ) + NODYN = N.EQ.0 .OR. MIN( BNORM, CNORM ).EQ.ZERO + USEPEN = FULLE .OR. DISCR +C +C Compute workspace. +C + ID = 6*MINPM + IC = MAX( 4*MINPM + MAX( P, M ), ID ) + IF( MINPM.EQ.0 ) THEN + MINWRK = 1 + ELSE IF( NODYN ) THEN + IF( WITHD ) THEN + MINWRK = P*M + IC + ELSE + MINWRK = 1 + END IF + ELSE + IF ( DISCR ) THEN + IB = 0 + IE = ID + ELSE + IB = N*( N + M ) + IF ( .NOT.WITHD ) + $ IB = IB + P*M + IE = IC + END IF + IF ( WITHD ) THEN + IR = P*M + IF ( .NOT.USEPEN ) THEN + MINWRK = P*P + M*M + IR = IR + N*PM + ELSE + MINWRK = 0 + END IF + MINWRK = MINWRK + IR + IC + IR = IR + MINPM + ELSE + IR = 0 + MINWRK = 0 + END IF + IR = IR + N*( N + PM ) + IF ( FULLE ) THEN + IR = IR + NN + IF ( LEQUIL ) + $ MINWRK = MAX( MINWRK, IR + 9*N ) + MINWRK = MAX( MINWRK, IR + 4*N + MAX( M, 2*NN, + $ N + IB + IE ) ) + ELSE + MINWRK = MAX( MINWRK, IR + N + MAX( M, P, NN + N2, + $ 3*N + IB + IE ) ) + END IF + LW = 0 + IF ( .NOT.USEPEN ) THEN + LW = IR + 4*NN + 11*N + IF ( WITHD ) + $ LW = LW + MAX( M, P ) + N*PM + END IF + IF ( USEPEN .OR. WITHD ) + $ LW = MAX( LW, IR + 6*N + N2PM*N2PM + + $ MAX( N2PM + PM, 8*( NN + N2 ) ) ) + MINWRK = MAX( 1, MINWRK, LW, IR + N2 + IE ) + END IF +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -23 + ELSE + IF ( NODYN ) THEN + MINCWR = 1 + ELSE + MINCWR = MAX( 1, ( N + M )*( N + P ) + + $ 2*MINPM + MAX( P, M ) ) + END IF + IF( LCWORK.LT.MINCWR ) + $ INFO = -25 + END IF + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'AB13DD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( M.EQ.0 .OR. P.EQ.0 ) THEN + GPEAK( 1 ) = ZERO + FPEAK( 1 ) = ZERO + GPEAK( 2 ) = ONE + FPEAK( 2 ) = ONE + DWORK( 1 ) = ONE + CWORK( 1 ) = ONE + RETURN + END IF +C +C Determine the maximum singular value of G(infinity) = D . +C If JOBE = 'I' and DICO = 'C', the full SVD of D, D = U*S*V', is +C computed and saved for later use. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + ID = 1 + IF ( WITHD ) THEN + IS = ID + P*M + IF ( USEPEN .OR. NODYN ) THEN + IU = IS + MINPM + IV = IU + IWRK = IV + VECT = 'N' + ELSE + IBV = IS + MINPM + ICU = IBV + N*M + IU = ICU + P*N + IV = IU + P*P + IWRK = IV + M*M + VECT = 'A' + END IF +C +C Workspace: need P*M + MIN(P,M) + V + +C MAX( 3*MIN(P,M) + MAX(P,M), 5*MIN(P,M) ), +C where V = N*(M+P) + P*P + M*M, +C if JOBE = 'I' and DICO = 'C', +C and N > 0, B <> 0, C <> 0, +C V = 0, otherwise; +C prefer larger. +C + CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P ) + CALL DGESVD( VECT, VECT, P, M, DWORK( ID ), P, DWORK( IS ), + $ DWORK( IU ), P, DWORK( IV ), M, DWORK( IWRK ), + $ LDWORK-IWRK+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 3 + RETURN + END IF + GAMMAL = DWORK( IS ) + MAXWRK = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Restore D for later calculations. +C + CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P ) + ELSE + IWRK = 1 + GAMMAL = ZERO + MAXWRK = 1 + END IF +C +C Quick return if possible. +C + IF( NODYN ) THEN + GPEAK( 1 ) = GAMMAL + FPEAK( 1 ) = ZERO + GPEAK( 2 ) = ONE + FPEAK( 2 ) = ONE + DWORK( 1 ) = MAXWRK + CWORK( 1 ) = ONE + RETURN + END IF +C + IF ( .NOT.USEPEN .AND. WITHD ) THEN +C +C Standard continuous-time case, D <> 0: Compute B*V and C'*U . +C + CALL DGEMM( 'No Transpose', 'Transpose', N, M, M, ONE, B, LDB, + $ DWORK( IV ), M, ZERO, DWORK( IBV ), N ) + CALL DGEMM( 'Transpose', 'No Transpose', N, P, P, ONE, C, + $ LDC, DWORK( IU ), P, ZERO, DWORK( ICU ), N ) +C +C U and V are no longer needed: free their memory space. +C Total workspace here: need P*M + MIN(P,M) + N*(M+P) +C (JOBE = 'I', DICO = 'C', JOBD = 'D'). +C + IWRK = IU + END IF +C +C Get machine constants. +C + EPS = DLAMCH( 'Epsilon' ) + SAFMIN = DLAMCH( 'Safe minimum' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + SMLNUM = SQRT( SAFMIN ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + TOLER = SQRT( EPS ) +C +C Initiate the transformation of the system to an equivalent one, +C to be used for eigenvalue computations. +C +C Additional workspace: need N*N + N*M + P*N + 2*N, if JOBE = 'I'; +C 2*N*N + N*M + P*N + 2*N, if JOBE = 'G'. +C + IA = IWRK + IE = IA + NN + IF ( FULLE ) THEN + IB = IE + NN + ELSE + IB = IE + END IF + IC = IB + N*M + IR = IC + P*N + II = IR + N + IBT = II + N +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IA ), N ) + CALL DLACPY( 'Full', N, M, B, LDB, DWORK( IB ), N ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK( IC ), P ) +C +C Scale A if maximum element is outside the range [SMLNUM,BIGNUM]. +C + ANRM = DLANGE( 'Max', N, N, DWORK( IA ), N, DWORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF + IF( ILASCL ) + $ CALL DLASCL( 'General', 0, 0, ANRM, ANRMTO, N, N, DWORK( IA ), + $ N, IERR ) +C + IF ( FULLE ) THEN +C +C Descriptor system. +C +C Additional workspace: need N. +C + IWRK = IBT + N + CALL DLACPY( 'Full', N, N, E, LDE, DWORK( IE ), N ) +C +C Scale E if maximum element is outside the range +C [SMLNUM,BIGNUM]. +C + ENRM = DLANGE( 'Max', N, N, DWORK( IE ), N, DWORK ) + ILESCL = .FALSE. + IF( ENRM.GT.ZERO .AND. ENRM.LT.SMLNUM ) THEN + ENRMTO = SMLNUM + ILESCL = .TRUE. + ELSE IF( ENRM.GT.BIGNUM ) THEN + ENRMTO = BIGNUM + ILESCL = .TRUE. + ELSE IF( ENRM.EQ.ZERO ) THEN +C +C Error return: Matrix E is 0. +C + INFO = 1 + RETURN + END IF + IF( ILESCL ) + $ CALL DLASCL( 'General', 0, 0, ENRM, ENRMTO, N, N, + $ DWORK( IE ), N, IERR ) +C +C Equilibrate the system, if required. +C +C Additional workspace: need 6*N. +C + IF( LEQUIL ) + $ CALL TG01AD( 'All', N, N, M, P, ZERO, DWORK( IA ), N, + $ DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ), P, + $ DWORK( II ), DWORK( IR ), DWORK( IWRK ), + $ IERR ) +C +C For efficiency of later calculations, the system (A,E,B,C) is +C reduced to an equivalent one with the state matrix A in +C Hessenberg form, and E upper triangular. +C First, permute (A,E) to make it more nearly triangular. +C + CALL DGGBAL( 'Permute', N, DWORK( IA ), N, DWORK( IE ), N, ILO, + $ IHI, DWORK( II ), DWORK( IR ), DWORK( IWRK ), + $ IERR ) +C +C Apply the permutations to (the copies of) B and C. +C + DO 10 I = N, IHI + 1, -1 + K = DWORK( II+I-1 ) + IF( K.NE.I ) + $ CALL DSWAP( M, DWORK( IB+I-1 ), N, + $ DWORK( IB+K-1 ), N ) + K = DWORK( IR+I-1 ) + IF( K.NE.I ) + $ CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, + $ DWORK( IC+(K-1)*P ), 1 ) + 10 CONTINUE +C + DO 20 I = 1, ILO - 1 + K = DWORK( II+I-1 ) + IF( K.NE.I ) + $ CALL DSWAP( M, DWORK( IB+I-1 ), N, + $ DWORK( IB+K-1 ), N ) + K = DWORK( IR+I-1 ) + IF( K.NE.I ) + $ CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, + $ DWORK( IC+(K-1)*P ), 1 ) + 20 CONTINUE +C +C Reduce (A,E) to generalized Hessenberg form and apply the +C transformations to B and C. +C Additional workspace: need N + MAX(N,M); +C prefer N + MAX(N,M)*NB. +C + CALL TG01BD( 'General', 'No Q', 'No Z', N, M, P, ILO, IHI, + $ DWORK( IA ), N, DWORK( IE ), N, DWORK( IB ), N, + $ DWORK( IC ), P, DWORK, 1, DWORK, 1, DWORK( IWRK ), + $ LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Check whether matrix E is nonsingular. +C Additional workspace: need 3*N. +C + CALL DTRCON( '1-norm', 'Upper', 'Non Unit', N, DWORK( IE ), N, + $ RCOND, DWORK( IWRK ), IWORK, IERR ) + IF( RCOND.LE.TEN*DBLE( N )*EPS ) THEN +C +C Error return: Matrix E is numerically singular. +C + INFO = 1 + RETURN + END IF +C +C Perform QZ algorithm, computing eigenvalues. The generalized +C Hessenberg form is saved for later use. +C Additional workspace: need 2*N*N + N; +C prefer larger. +C + IAS = IWRK + IES = IAS + NN + IWRK = IES + NN + CALL DLACPY( 'Full', N, N, DWORK( IA ), N, DWORK( IAS ), N ) + CALL DLACPY( 'Full', N, N, DWORK( IE ), N, DWORK( IES ), N ) + CALL DHGEQZ( 'Eigenvalues', 'No Vectors', 'No Vectors', N, ILO, + $ IHI, DWORK( IAS ), N, DWORK( IES ), N, + $ DWORK( IR ), DWORK( II ), DWORK( IBT ), DWORK, N, + $ DWORK, N, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Check if unscaling would cause over/underflow; if so, rescale +C eigenvalues (DWORK( IR+I-1 ),DWORK( II+I-1 ),DWORK( IBT+I-1 )) +C so DWORK( IBT+I-1 ) is on the order of E(I,I) and +C DWORK( IR+I-1 ) and DWORK( II+I-1 ) are on the order of A(I,I). +C + IF( ILASCL ) THEN +C + DO 30 I = 1, N + IF( DWORK( II+I-1 ).NE.ZERO ) THEN + IF( ( DWORK( IR+I-1 ) / SAFMAX ).GT.( ANRMTO / ANRM ) + $ .OR. + $ ( SAFMIN / DWORK( IR+I-1 ) ).GT.( ANRM / ANRMTO ) + $ ) THEN + TM = ABS( DWORK( IA+(I-1)*N+I ) / DWORK( IR+I-1 ) ) + DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM + DWORK( IR+I-1 ) = DWORK( IR+I-1 )*TM + DWORK( II+I-1 ) = DWORK( II+I-1 )*TM + ELSE IF( ( DWORK( II+I-1 ) / SAFMAX ).GT. + $ ( ANRMTO / ANRM ) .OR. + $ ( SAFMIN / DWORK( II+I-1 ) ).GT.( ANRM / ANRMTO ) ) + $ THEN + TM = ABS( DWORK( IA+I*N+I ) / DWORK( II+I-1 ) ) + DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM + DWORK( IR+I-1 ) = DWORK( IR+I-1 )*TM + DWORK( II+I-1 ) = DWORK( II+I-1 )*TM + END IF + END IF + 30 CONTINUE +C + END IF +C + IF( ILESCL ) THEN +C + DO 40 I = 1, N + IF( DWORK( II+I-1 ).NE.ZERO ) THEN + IF( ( DWORK( IBT+I-1 ) / SAFMAX ).GT.( ENRMTO / ENRM ) + $ .OR. + $ ( SAFMIN / DWORK( IBT+I-1 ) ).GT.( ENRM / ENRMTO ) + $ ) THEN + TM = ABS( DWORK( IE+(I-1)*N+I ) / DWORK( IBT+I-1 )) + DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM + DWORK( IR+I-1 ) = DWORK( IR+I-1 )*TM + DWORK( II+I-1 ) = DWORK( II+I-1 )*TM + END IF + END IF + 40 CONTINUE +C + END IF +C +C Undo scaling. +C + IF( ILASCL ) THEN + CALL DLASCL( 'Hessenberg', 0, 0, ANRMTO, ANRM, N, N, + $ DWORK( IA ), N, IERR ) + CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, + $ DWORK( IR ), N, IERR ) + CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, + $ DWORK( II ), N, IERR ) + END IF +C + IF( ILESCL ) THEN + CALL DLASCL( 'Upper', 0, 0, ENRMTO, ENRM, N, N, + $ DWORK( IE ), N, IERR ) + CALL DLASCL( 'General', 0, 0, ENRMTO, ENRM, N, 1, + $ DWORK( IBT ), N, IERR ) + END IF +C + ELSE +C +C Standard state-space system. +C + IF( LEQUIL ) THEN +C +C Equilibrate the system. +C + MAXRED = HUNDRD + CALL TB01ID( 'All', N, M, P, MAXRED, DWORK( IA ), N, + $ DWORK( IB ), N, DWORK( IC ), P, DWORK( II ), + $ IERR ) + END IF +C +C For efficiency of later calculations, the system (A,B,C) is +C reduced to a similar one with the state matrix in Hessenberg +C form. +C +C First, permute the matrix A to make it more nearly triangular +C and apply the permutations to B and C. +C + CALL DGEBAL( 'Permute', N, DWORK( IA ), N, ILO, IHI, + $ DWORK( IR ), IERR ) +C + DO 50 I = N, IHI + 1, -1 + K = DWORK( IR+I-1 ) + IF( K.NE.I ) THEN + CALL DSWAP( M, DWORK( IB+I-1 ), N, + $ DWORK( IB+K-1 ), N ) + CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, + $ DWORK( IC+(K-1)*P ), 1 ) + END IF + 50 CONTINUE +C + DO 60 I = 1, ILO - 1 + K = DWORK( IR+I-1 ) + IF( K.NE.I ) THEN + CALL DSWAP( M, DWORK( IB+I-1 ), N, + $ DWORK( IB+K-1 ), N ) + CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, + $ DWORK( IC+(K-1)*P ), 1 ) + END IF + 60 CONTINUE +C +C Reduce A to upper Hessenberg form and apply the transformations +C to B and C. +C Additional workspace: need N; (from II) +C prefer N*NB. +C + ITAU = IR + IWRK = ITAU + N + CALL DGEHRD( N, ILO, IHI, DWORK( IA ), N, DWORK( ITAU ), + $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Additional workspace: need M; +C prefer M*NB. +C + CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, DWORK( IA ), + $ N, DWORK( ITAU ), DWORK( IB ), N, DWORK( IWRK ), + $ LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Additional workspace: need P; +C prefer P*NB. +C + CALL DORMHR( 'Right', 'NoTranspose', P, N, ILO, IHI, + $ DWORK( IA ), N, DWORK( ITAU ), DWORK( IC ), P, + $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Compute the eigenvalues. The Hessenberg form is saved for +C later use. +C Additional workspace: need N*N + N; (from IBT) +C prefer larger. +C + IAS = IBT + IWRK = IAS + NN + CALL DLACPY( 'Full', N, N, DWORK( IA ), N, DWORK( IAS ), N ) + CALL DHSEQR( 'Eigenvalues', 'No Vectors', N, ILO, IHI, + $ DWORK( IAS ), N, DWORK( IR ), DWORK( II ), DWORK, + $ N, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C + IF( ILASCL ) THEN +C +C Undo scaling for the Hessenberg form of A and eigenvalues. +C + CALL DLASCL( 'Hessenberg', 0, 0, ANRMTO, ANRM, N, N, + $ DWORK( IA ), N, IERR ) + CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, + $ DWORK( IR ), N, IERR ) + CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, + $ DWORK( II ), N, IERR ) + END IF +C + END IF +C +C Look for (generalized) eigenvalues on the boundary of the +C stability domain. (Their existence implies an infinite norm.) +C Additional workspace: need 2*N. (from IAS) +C + IM = IAS + IAR = IM + N + IMIN = II + WRMIN = SAFMAX + BOUND = EPS*THOUSD +C + IF ( DISCR ) THEN + GAMMAL = ZERO +C +C For discrete-time case, compute the logarithm of the non-zero +C eigenvalues and save their moduli and absolute real parts. +C (The logarithms are overwritten on the eigenvalues.) +C Also, find the minimum distance to the unit circle. +C + IF ( FULLE ) THEN +C + DO 70 I = 0, N - 1 + TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. + $ ( DWORK( IBT+I ).LT.ONE .AND. + $ TM.LT.SAFMAX*DWORK( IBT+I ) ) ) THEN + TM = TM / DWORK( IBT+I ) + ELSE +C +C The pencil has too large eigenvalues. SAFMAX is used. +C + TM = SAFMAX + END IF + IF ( TM.NE.ZERO ) THEN + DWORK( II+I ) = ATAN2( DWORK( II+I ), DWORK( IR+I ) ) + DWORK( IR+I ) = LOG( TM ) + END IF + DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + TM = ABS( ONE - TM ) + IF( TM.LT.WRMIN ) THEN + IMIN = II + I + WRMIN = TM + END IF + IM = IM + 1 + DWORK( IAR+I ) = ABS( DWORK( IR+I ) ) + 70 CONTINUE +C + ELSE +C + DO 80 I = 0, N - 1 + TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + IF ( TM.NE.ZERO ) THEN + DWORK( II+I ) = ATAN2( DWORK( II+I ), DWORK( IR+I ) ) + DWORK( IR+I ) = LOG( TM ) + END IF + DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + TM = ABS( ONE - TM ) + IF( TM.LT.WRMIN ) THEN + IMIN = II + I + WRMIN = TM + END IF + IM = IM + 1 + DWORK( IAR+I ) = ABS( DWORK( IR+I ) ) + 80 CONTINUE +C + END IF +C + ELSE +C +C For continuous-time case, save moduli of eigenvalues and +C absolute real parts and find the maximum modulus and minimum +C absolute real part. +C + WMAX = ZERO +C + IF ( FULLE ) THEN +C + DO 90 I = 0, N - 1 + TM = ABS( DWORK( IR+I ) ) + DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. + $ ( DWORK( IBT+I ).LT.ONE .AND. + $ DWORK( IM ).LT.SAFMAX*DWORK( IBT+I ) ) ) + $ THEN + TM = TM / DWORK( IBT+I ) + DWORK( IM ) = DWORK( IM ) / DWORK( IBT+I ) + ELSE + IF ( TM.LT.SAFMAX*DWORK( IBT+I ) ) THEN + TM = TM / DWORK( IBT+I ) + ELSE +C +C The pencil has too large eigenvalues. +C SAFMAX is used. +C + TM = SAFMAX + END IF + DWORK( IM ) = SAFMAX + END IF + IF( TM.LT.WRMIN ) THEN + IMIN = II + I + WRMIN = TM + END IF + DWORK( IAR+I ) = TM + IF( DWORK( IM ).GT.WMAX ) + $ WMAX = DWORK( IM ) + IM = IM + 1 + 90 CONTINUE +C + ELSE +C + DO 100 I = 0, N - 1 + TM = ABS( DWORK( IR+I ) ) + IF( TM.LT.WRMIN ) THEN + IMIN = II + I + WRMIN = TM + END IF + DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + IF( DWORK( IM ).GT.WMAX ) + $ WMAX = DWORK( IM ) + IM = IM + 1 + DWORK( IAR+I ) = TM + 100 CONTINUE +C + END IF +C + BOUND = BOUND + EPS*WMAX +C + END IF +C + IM = IM - N +C + IF( WRMIN.LT.BOUND ) THEN +C +C The L-infinity norm was found as infinite. +C + GPEAK( 1 ) = ONE + GPEAK( 2 ) = ZERO + TM = ABS( DWORK( IMIN ) ) + IF ( DISCR ) + $ TM = ABS( ATAN2( SIN( TM ), COS( TM ) ) ) + FPEAK( 1 ) = TM + IF ( TM.LT.SAFMAX ) THEN + FPEAK( 2 ) = ONE + ELSE + FPEAK( 2 ) = ZERO + END IF +C + DWORK( 1 ) = MAXWRK + CWORK( 1 ) = ONE + RETURN + END IF +C +C Determine the maximum singular value of +C G(lambda) = C*inv(lambda*E - A)*B + D, +C over a selected set of frequencies. Besides the frequencies w = 0, +C w = pi (if DICO = 'D'), and the given value FPEAK, this test set +C contains the peak frequency for each mode (or an approximation +C of it). The (generalized) Hessenberg form of the system is used. +C +C First, determine the maximum singular value of G(0) and set FPEAK +C accordingly. +C Additional workspace: +C complex: need 1, if DICO = 'C'; +C (N+M)*(N+P)+2*MIN(P,M)+MAX(P,M)), otherwise; +C prefer larger; +C real: need LDW0+LDW1+LDW2, where +C LDW0 = N*N+N*M, if DICO = 'C'; +C LDW0 = 0, if DICO = 'D'; +C LDW1 = P*M, if DICO = 'C', JOBD = 'Z'; +C LDW1 = 0, otherwise; +C LDW2 = MIN(P,M)+MAX(3*MIN(P,M)+MAX(P,M), +C 5*MIN(P,M)), +C if DICO = 'C'; +C LDW2 = 6*MIN(P,M), otherwise. +C prefer larger. +C + IF ( DISCR ) THEN + IAS = IA + IBS = IB + IWRK = IAR + N + ELSE + IAS = IAR + N + IBS = IAS + NN + IWRK = IBS + N*M + CALL DLACPY( 'Upper', N, N, DWORK( IA ), N, DWORK( IAS ), N ) + CALL DCOPY( N-1, DWORK( IA+1 ), N+1, DWORK( IAS+1 ), N+1 ) + CALL DLACPY( 'Full', N, M, DWORK( IB ), N, DWORK( IBS ), N ) + END IF + GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, ZERO, DWORK( IAS ), N, + $ DWORK( IE ), N, DWORK( IBS ), N, DWORK( IC ), P, + $ DWORK( ID ), P, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, CWORK, LCWORK, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + IF( IERR.GE.1 .AND. IERR.LE.N ) THEN + GPEAK( 1 ) = ONE + FPEAK( 1 ) = ZERO + GPEAK( 2 ) = ZERO + FPEAK( 2 ) = ONE + GO TO 340 + ELSE IF( IERR.EQ.N+1 ) THEN + INFO = 3 + RETURN + END IF +C + FPEAKS = FPEAK( 1 ) + FPEAKI = FPEAK( 2 ) + IF( GAMMAL.LT.GAMMA ) THEN + GAMMAL = GAMMA + FPEAK( 1 ) = ZERO + FPEAK( 2 ) = ONE + ELSE IF( .NOT.DISCR ) THEN + FPEAK( 1 ) = ONE + FPEAK( 2 ) = ZERO + END IF +C + MAXCWK = INT( CWORK( 1 ) ) +C + IF( DISCR ) THEN +C +C Try the frequency w = pi. +C + PI = FOUR*ATAN( ONE ) + GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, PI, DWORK( IA ), + $ N, DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ), + $ P, DWORK( ID ), P, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, CWORK, LCWORK, IERR ) + MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + IF( IERR.GE.1 .AND. IERR.LE.N ) THEN + GPEAK( 1 ) = ONE + FPEAK( 1 ) = PI + GPEAK( 2 ) = ZERO + FPEAK( 2 ) = ONE + GO TO 340 + ELSE IF( IERR.EQ.N+1 ) THEN + INFO = 3 + RETURN + END IF +C + IF( GAMMAL.LT.GAMMA ) THEN + GAMMAL = GAMMA + FPEAK( 1 ) = PI + FPEAK( 2 ) = ONE + END IF +C + ELSE + IWRK = IAS +C +C Restore D, if needed. +C + IF ( WITHD ) + $ CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P ) + END IF +C +C Build the remaining set of frequencies. +C Complex workspace: need (N+M)*(N+P)+2*MIN(P,M)+MAX(P,M)); +C prefer larger. +C Real workspace: need LDW2, see above; +C prefer larger. +C + IF ( MIN( FPEAKS, FPEAKI ).NE.ZERO ) THEN +C +C Compute also the norm at the given (finite) frequency. +C + GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, FPEAKS, DWORK( IA ), + $ N, DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ), + $ P, DWORK( ID ), P, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, CWORK, LCWORK, IERR ) + MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + IF ( DISCR ) THEN + TM = ABS( ATAN2( SIN( FPEAKS ), COS( FPEAKS ) ) ) + ELSE + TM = FPEAKS + END IF + IF( IERR.GE.1 .AND. IERR.LE.N ) THEN + GPEAK( 1 ) = ONE + FPEAK( 1 ) = TM + GPEAK( 2 ) = ZERO + FPEAK( 2 ) = ONE + GO TO 340 + ELSE IF( IERR.EQ.N+1 ) THEN + INFO = 3 + RETURN + END IF +C + IF( GAMMAL.LT.GAMMA ) THEN + GAMMAL = GAMMA + FPEAK( 1 ) = TM + FPEAK( 2 ) = ONE + END IF +C + END IF +C + DO 110 I = 0, N - 1 + IF( DWORK( II+I ).GE.ZERO .AND. DWORK( IM+I ).GT.ZERO ) THEN + IF ( ( DWORK( IM+I ).GE.ONE ) .OR. ( DWORK( IM+I ).LT.ONE + $ .AND. DWORK( IAR+I ).LT.SAFMAX*DWORK( IM+I ) ) ) THEN + RAT = DWORK( IAR+I ) / DWORK( IM+I ) + ELSE + RAT = ONE + END IF + OMEGA = DWORK( IM+I )*SQRT( MAX( P25, ONE - TWO*RAT**2 ) ) +C + GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, OMEGA, + $ DWORK( IA ), N, DWORK( IE ), N, DWORK( IB ), + $ N, DWORK( IC ), P, DWORK( ID ), P, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, CWORK, LCWORK, + $ IERR ) + MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + IF ( DISCR ) THEN + TM = ABS( ATAN2( SIN( OMEGA ), COS( OMEGA ) ) ) + ELSE + TM = OMEGA + END IF + IF( IERR.GE.1 .AND. IERR.LE.N ) THEN + GPEAK( 1 ) = ONE + FPEAK( 1 ) = TM + GPEAK( 2 ) = ZERO + FPEAK( 2 ) = ONE + GO TO 340 + ELSE IF( IERR.EQ.N+1 ) THEN + INFO = 3 + RETURN + END IF +C + IF( GAMMAL.LT.GAMMA ) THEN + GAMMAL = GAMMA + FPEAK( 1 ) = TM + FPEAK( 2 ) = ONE + END IF +C + END IF + 110 CONTINUE +C +C Return if the lower bound is zero. +C + IF( GAMMAL.EQ.ZERO ) THEN + GPEAK( 1 ) = ZERO + FPEAK( 1 ) = ZERO + GPEAK( 2 ) = ONE + FPEAK( 2 ) = ONE + GO TO 340 + END IF +C +C Start the modified gamma iteration for the Bruinsma-Steinbuch +C algorithm. +C + IF ( .NOT.DISCR ) + $ RTOL = HUNDRD*TOLER + ITER = 0 +C +C WHILE ( Iteration may continue ) DO +C + 120 CONTINUE +C + ITER = ITER + 1 + GAMMA = ( ONE + TOL )*GAMMAL + USEPEN = FULLE .OR. DISCR + IF ( .NOT.USEPEN .AND. WITHD ) THEN +C +C Check whether one can use an explicit Hamiltonian matrix: +C compute +C min(rcond(GAMMA**2*Im - S'*S), rcond(GAMMA**2*Ip - S*S')). +C If P = M = 1, then GAMMA**2 - S(1)**2 is used instead. +C + IF ( M.NE.P ) THEN + RCOND = ONE - ( DWORK( IS ) / GAMMA )**2 + ELSE IF ( MINPM.GT.1 ) THEN + RCOND = ( GAMMA**2 - DWORK( IS )**2 ) / + $ ( GAMMA**2 - DWORK( IS+P-1 )**2 ) + ELSE + RCOND = GAMMA**2 - DWORK( IS )**2 + END IF +C + USEPEN = RCOND.LT.RTOL + END IF +C + IF ( USEPEN ) THEN +C +C Use the QZ algorithm on a pencil. +C Additional workspace here: need 6*N. (from IR) +C + II = IR + N2 + IBT = II + N2 + IH12 = IBT + N2 + IM = IH12 +C +C Set up the needed parts of the Hamiltonian pencil (H,J), +C +C ( H11 H12 ) +C H = ( ) , +C ( H21 H22 ) +C +C with +C +C ( A 0 ) ( 0 B ) ( E 0 ) +C H11 = ( ), H12 = ( )/nB, J11 = ( ), +C ( 0 -A' ) ( C' 0 ) ( 0 E' ) +C +C ( C 0 ) ( Ip D/g ) +C H21 = ( )*nB, H22 = ( ), +C ( 0 -B' ) ( D'/g Im ) +C +C if DICO = 'C', and +C +C ( A 0 ) ( B 0 ) ( E 0 ) +C H11 = ( ), H12 = ( )/nB, J11 = ( ), +C ( 0 E' ) ( 0 C' ) ( 0 A') +C +C ( 0 0 ) ( Im D'/g ) ( 0 B') +C H21 = ( )*nB, H22 = ( ), J21 = ( )*nB, +C ( C 0 ) ( D/g Ip ) ( 0 0 ) +C +C if DICO = 'D', where g = GAMMA, and nB = norm(B,1). +C First build [H12; H22]. +C + TEMP( 1 ) = ZERO + IH = IH12 +C + IF ( DISCR ) THEN +C + DO 150 J = 1, M +C + DO 130 I = 1, N + DWORK( IH ) = B( I, J ) / BNORM + IH = IH + 1 + 130 CONTINUE +C + CALL DCOPY( N+M, TEMP, 0, DWORK( IH ), 1 ) + DWORK( IH+N+J-1 ) = ONE + IH = IH + N + M +C + DO 140 I = 1, P + DWORK( IH ) = D( I, J ) / GAMMA + IH = IH + 1 + 140 CONTINUE +C + 150 CONTINUE +C + DO 180 J = 1, P + CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 ) + IH = IH + N +C + DO 160 I = 1, N + DWORK( IH ) = C( J, I ) / BNORM + IH = IH + 1 + 160 CONTINUE +C + DO 170 I = 1, M + DWORK( IH ) = D( J, I ) / GAMMA + IH = IH + 1 + 170 CONTINUE +C + CALL DCOPY( P, TEMP, 0, DWORK( IH ), 1 ) + DWORK( IH+J-1 ) = ONE + IH = IH + P + 180 CONTINUE +C + ELSE +C + DO 210 J = 1, P + CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 ) + IH = IH + N +C + DO 190 I = 1, N + DWORK( IH ) = C( J, I ) / BNORM + IH = IH + 1 + 190 CONTINUE +C + CALL DCOPY( P, TEMP, 0, DWORK( IH ), 1 ) + DWORK( IH+J-1 ) = ONE + IH = IH + P +C + DO 200 I = 1, M + DWORK( IH ) = D( J, I ) / GAMMA + IH = IH + 1 + 200 CONTINUE +C + 210 CONTINUE +C + DO 240 J = 1, M +C + DO 220 I = 1, N + DWORK( IH ) = B( I, J ) / BNORM + IH = IH + 1 + 220 CONTINUE +C + CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 ) + IH = IH + N +C + DO 230 I = 1, P + DWORK( IH ) = D( I, J ) / GAMMA + IH = IH + 1 + 230 CONTINUE +C + CALL DCOPY( M, TEMP, 0, DWORK( IH ), 1 ) + DWORK( IH+J-1 ) = ONE + IH = IH + M + 240 CONTINUE +C + END IF +C +C Compute the QR factorization of [H12; H22]. +C For large P and M, it could be more efficient to exploit the +C structure of [H12; H22] and use the factored form of Q. +C Additional workspace: need (2*N+P+M)*(2*N+P+M)+2*(P+M); +C prefer (2*N+P+M)*(2*N+P+M)+P+M+ +C (P+M)*NB. +C + ITAU = IH12 + N2PM*N2PM + IWRK = ITAU + PM + CALL DGEQRF( N2PM, PM, DWORK( IH12 ), N2PM, DWORK( ITAU ), + $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Apply part of the orthogonal transformation: +C Q1 = Q(:,P+M+(1:2*N))' to the matrix [H11; H21/GAMMA]. +C If DICO = 'C', apply Q(1:2*N,P+M+(1:2*N))' to the +C matrix J11. +C If DICO = 'D', apply Q1 to the matrix [J11; J21/GAMMA]. +C H11, H21, J11, and J21 are not fully built. +C First, build the (2*N+P+M)-by-(2*N+P+M) matrix Q. +C Using Q will often provide better efficiency than the direct +C use of the factored form of Q, especially when P+M < N. +C Additional workspace: need P+M+2*N+P+M; +C prefer P+M+(2*N+P+M)*NB. +C + CALL DORGQR( N2PM, N2PM, PM, DWORK( IH12 ), N2PM, + $ DWORK( ITAU ), DWORK( IWRK ), LDWORK-IWRK+1, + $ IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Additional workspace: need 8*N*N. +C + IPA = ITAU + IPE = IPA + 4*NN + IWRK = IPE + 4*NN + CALL DGEMM( 'Transpose', 'No Transpose', N2, N, N, ONE, + $ DWORK( IH12+PM*N2PM ), N2PM, A, LDA, ZERO, + $ DWORK( IPA ), N2 ) + IF ( DISCR ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', N2, N, P, + $ BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2+M), N2PM, + $ C, LDC, ONE, DWORK( IPA ), N2 ) + IF ( FULLE ) THEN + CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE, + $ DWORK( IH12+PM*N2PM+N ), N2PM, E, LDE, + $ ZERO, DWORK( IPA+2*NN ), N2 ) + ELSE + CALL MA02AD( 'Full', N, N2, DWORK( IH12+PM*N2PM+N ), + $ N2PM, DWORK( IPA+2*NN ), N2 ) + NY = N + END IF + ELSE + CALL DGEMM( 'Transpose', 'No Transpose', N2, N, P, + $ BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2), N2PM, + $ C, LDC, ONE, DWORK( IPA ), N2 ) + CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, -ONE, + $ DWORK( IH12+PM*N2PM+N ), N2PM, A, LDA, ZERO, + $ DWORK( IPA+2*NN ), N2 ) + CALL DGEMM( 'Transpose', 'Transpose', N2, N, M, + $ -BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2+P), + $ N2PM, B, LDB, ONE, DWORK( IPA+2*NN ), N2 ) + NY = N2 + END IF +C + IF ( FULLE ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', N2, N, N, ONE, + $ DWORK( IH12+PM*N2PM ), N2PM, E, LDE, ZERO, + $ DWORK( IPE ), N2 ) + ELSE + CALL MA02AD( 'Full', NY, N2, DWORK( IH12+PM*N2PM ), + $ N2PM, DWORK( IPE ), N2 ) + END IF + IF ( DISCR ) THEN + CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE, + $ DWORK( IH12+PM*N2PM+N ), N2PM, A, LDA, + $ ZERO, DWORK( IPE+2*NN ), N2 ) + CALL DGEMM( 'Transpose', 'Transpose', N2, N, M, + $ BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2 ), N2PM, + $ B, LDB, ONE, DWORK( IPE+2*NN ), N2 ) + ELSE + IF ( FULLE ) + $ CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE, + $ DWORK( IH12+PM*N2PM+N ), N2PM, E, LDE, + $ ZERO, DWORK( IPE+2*NN ), N2 ) + END IF +C +C Compute the eigenvalues of the Hamiltonian pencil. +C Additional workspace: need 16*N; +C prefer larger. +C + CALL DGGEV( 'No Vectors', 'No Vectors', N2, DWORK( IPA ), + $ N2, DWORK( IPE ), N2, DWORK( IR ), DWORK( II ), + $ DWORK( IBT ), DWORK, N2, DWORK, N2, + $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C + ELSE IF ( .NOT.WITHD ) THEN +C +C Standard continuous-time case with D = 0. +C Form the needed part of the Hamiltonian matrix explicitly: +C H = H11 - H12*inv(H22)*H21/g. +C Additional workspace: need 2*N*N+N. (from IBT) +C + IH = IBT + IH12 = IH + NN + ISL = IH12 + NN + N + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IH ), N ) +C +C Compute triangles of -C'*C/GAMMA and B*B'/GAMMA. +C + CALL DSYRK( 'Lower', 'Transpose', N, P, -ONE/GAMMA, C, LDC, + $ ZERO, DWORK( IH12 ), N ) + CALL DSYRK( 'Upper', 'No Transpose', N, M, ONE/GAMMA, B, + $ LDB, ZERO, DWORK( IH12+N ), N ) +C + ELSE +C +C Standard continuous-time case with D <> 0 and the SVD of D +C can be used. Compute explicitly the needed part of the +C Hamiltonian matrix: +C +C (A+B1*S'*inv(g^2*Ip-S*S')*C1' g*B1*inv(g^2*Im-S'*S)*B1') +C H = ( ) +C ( -g*C1*inv(g^2*Ip-S*S')*C1' -H11' ) +C +C where g = GAMMA, B1 = B*V, C1 = C'*U, and H11 is the first +C block of H. +C Primary additional workspace: need 2*N*N+N (from IBT) +C (for building the relevant part of the Hamiltonian matrix). +C +C Compute C1*sqrt(inv(g^2*Ip-S*S')) . +C Additional workspace: need MAX(M,P)+N*P. +C + IH = IBT + IH12 = IH + NN + ISL = IH12 + NN + N +C + DO 250 I = 0, MINPM - 1 + DWORK( ISL+I ) = ONE/SQRT( GAMMA**2 - DWORK( IS+I )**2 ) + 250 CONTINUE +C + IF ( M.LT.P ) THEN + DWORK( ISL+M ) = ONE / GAMMA + CALL DCOPY( P-M-1, DWORK( ISL+M ), 0, DWORK( ISL+M+1 ), + $ 1 ) + END IF + ISC = ISL + MAX( M, P ) + CALL DLACPY( 'Full', N, P, DWORK( ICU ), N, DWORK( ISC ), + $ N ) + CALL MB01SD( 'Column', N, P, DWORK( ISC ), N, DWORK, + $ DWORK( ISL ) ) +C +C Compute B1*S' . +C Additional workspace: need N*M. +C + ISB = ISC + P*N + CALL DLACPY( 'Full', N, M, DWORK( IBV ), N, DWORK( ISB ), + $ N ) + CALL MB01SD( 'Column', N, MINPM, DWORK( ISB ), N, DWORK, + $ DWORK( IS ) ) +C +C Compute B1*S'*sqrt(inv(g^2*Ip-S*S')) . +C + CALL MB01SD( 'Column', N, MINPM, DWORK( ISB ), N, DWORK, + $ DWORK( ISL ) ) +C +C Compute H11 . +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IH ), N ) + CALL DGEMM( 'No Transpose', 'Transpose', N, N, MINPM, ONE, + $ DWORK( ISB ), N, DWORK( ISC ), N, ONE, + $ DWORK( IH ), N ) +C +C Compute B1*sqrt(inv(g^2*Im-S'*S)) . +C + IF ( P.LT.M ) THEN + DWORK( ISL+P ) = ONE / GAMMA + CALL DCOPY( M-P-1, DWORK( ISL+P ), 0, DWORK( ISL+P+1 ), + $ 1 ) + END IF + CALL DLACPY( 'Full', N, M, DWORK( IBV ), N, DWORK( ISB ), + $ N ) + CALL MB01SD( 'Column', N, M, DWORK( ISB ), N, DWORK, + $ DWORK( ISL ) ) +C +C Compute the lower triangle of H21 and the upper triangle +C of H12. +C + CALL DSYRK( 'Lower', 'No Transpose', N, P, -GAMMA, + $ DWORK( ISC ), N, ZERO, DWORK( IH12 ), N ) + CALL DSYRK( 'Upper', 'No Transpose', N, M, GAMMA, + $ DWORK( ISB ), N, ZERO, DWORK( IH12+N ), N ) + END IF +C + IF ( .NOT.USEPEN ) THEN +C +C Compute the eigenvalues of the Hamiltonian matrix by the +C symplectic URV and the periodic Schur decompositions. +C Additional workspace: need (2*N+8)*N; +C prefer larger. +C + IWRK = ISL + NN + CALL MB03XD( 'Both', 'Eigenvalues', 'No vectors', + $ 'No vectors', N, DWORK( IH ), N, DWORK( IH12 ), + $ N, DWORK( ISL ), N, TEMP, 1, TEMP, 1, TEMP, 1, + $ TEMP, 1, DWORK( IR ), DWORK( II ), ILO, + $ DWORK( IWRK ), DWORK( IWRK+N ), + $ LDWORK-IWRK-N+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK + N - 1, MAXWRK ) + END IF +C +C Detect eigenvalues on the boundary of the stability domain, +C if any. The test is based on a round-off level of eps*rho(H) +C (after balancing) resulting in worst-case perturbations of +C order sqrt(eps*rho(H)), for continuous-time systems, on the +C real part of poles of multiplicity two (typical as GAMMA +C approaches the infinity norm). Similarly, in the discrete-time +C case. Above, rho(H) is the maximum modulus of eigenvalues +C (continuous-time case). +C +C Compute maximum eigenvalue modulus and check the absolute real +C parts (if DICO = 'C'), or moduli (if DICO = 'D'). +C + WMAX = ZERO +C + IF ( USEPEN ) THEN +C +C Additional workspace: need 2*N, if DICO = 'D'; (from IM) +C 0, if DICO = 'C'. +C + DO 260 I = 0, N2 - 1 + TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. + $ ( DWORK( IBT+I ).LT.ONE .AND. + $ TM.LT.SAFMAX*DWORK( IBT+I ) ) ) THEN + TM = TM / DWORK( IBT+I ) + ELSE +C +C The pencil has too large eigenvalues. SAFMAX is used. +C + TM = SAFMAX + END IF + WMAX = MAX( WMAX, TM ) + IF ( DISCR ) + $ DWORK( IM+I ) = TM + 260 CONTINUE +C + ELSE +C + DO 270 I = 0, N - 1 + TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + WMAX = MAX( WMAX, TM ) + 270 CONTINUE +C + END IF +C + NEI = 0 +C + IF ( USEPEN ) THEN +C + DO 280 I = 0, N2 - 1 + IF ( DISCR ) THEN + TM = ABS( ONE - DWORK( IM+I ) ) + ELSE + TM = ABS( DWORK( IR+I ) ) + IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. + $ ( DWORK( IBT+I ).LT.ONE .AND. + $ TM.LT.SAFMAX*DWORK( IBT+I ) ) ) THEN + TM = TM / DWORK( IBT+I ) + ELSE +C +C The pencil has too large eigenvalues. +C SAFMAX is used. +C + TM = SAFMAX + END IF + END IF + IF ( TM.LE.TOLER*SQRT( HUNDRD + WMAX ) ) THEN + DWORK( IR+NEI ) = DWORK( IR+I ) / DWORK( IBT+I ) + DWORK( II+NEI ) = DWORK( II+I ) / DWORK( IBT+I ) + NEI = NEI + 1 + END IF + 280 CONTINUE +C + ELSE +C + DO 290 I = 0, N - 1 + TM = ABS( DWORK( IR+I ) ) + IF ( TM.LE.TOLER*SQRT( HUNDRD + WMAX ) ) THEN + DWORK( IR+NEI ) = DWORK( IR+I ) + DWORK( II+NEI ) = DWORK( II+I ) + NEI = NEI + 1 + END IF + 290 CONTINUE +C + END IF +C + IF( NEI.EQ.0 ) THEN +C +C There is no eigenvalue on the boundary of the stability +C domain for G = ( ONE + TOL )*GAMMAL. The norm was found. +C + GPEAK( 1 ) = GAMMAL + GPEAK( 2 ) = ONE + GO TO 340 + END IF +C +C Compute the frequencies where the gain G is attained and +C generate new test frequencies. +C + NWS = 0 +C + IF ( DISCR ) THEN +C + DO 300 I = 0, NEI - 1 + TM = ATAN2( DWORK( II+I ), DWORK( IR+I ) ) + DWORK( IR+I ) = MAX( EPS, TM ) + NWS = NWS + 1 + 300 CONTINUE +C + ELSE +C + J = 0 +C + DO 310 I = 0, NEI - 1 + IF ( DWORK( II+I ).GT.EPS ) THEN + DWORK( IR+NWS ) = DWORK( II+I ) + NWS = NWS + 1 + ELSE IF ( DWORK( II+I ).EQ.EPS ) THEN + J = J + 1 + IF ( J.EQ.1 ) THEN + DWORK( IR+NWS ) = EPS + NWS = NWS + 1 + END IF + END IF + 310 CONTINUE +C + END IF +C + CALL DLASRT( 'Increasing', NWS, DWORK( IR ), IERR ) + LW = 1 +C + DO 320 I = 0, NWS - 1 + IF ( DWORK( IR+LW-1 ).NE.DWORK( IR+I ) ) THEN + DWORK( IR+LW ) = DWORK( IR+I ) + LW = LW + 1 + END IF + 320 CONTINUE +C + IF ( LW.EQ.1 ) THEN + IF ( ITER.EQ.1 .AND. NWS.GE.1 ) THEN +C +C Duplicate the frequency trying to force iteration. +C + DWORK( IR+1 ) = DWORK( IR ) + LW = LW + 1 + ELSE +C +C The norm was found. +C + GPEAK( 1 ) = GAMMAL + GPEAK( 2 ) = ONE + GO TO 340 + END IF + END IF +C +C Form the vector of mid-points and compute the gain at new test +C frequencies. Save the current lower bound. +C + IWRK = IR + LW + GAMMAS = GAMMAL +C + DO 330 I = 0, LW - 2 + IF ( DISCR ) THEN + OMEGA = ( DWORK( IR+I ) + DWORK( IR+I+1 ) ) / TWO + ELSE + OMEGA = SQRT( DWORK( IR+I )*DWORK( IR+I+1 ) ) + END IF +C +C Additional workspace: need LDW2, see above; +C prefer larger. +C + GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, OMEGA, + $ DWORK( IA ), N, DWORK( IE ), N, DWORK( IB ), + $ N, DWORK( IC ), P, DWORK( ID ), P, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, CWORK, LCWORK, + $ IERR ) + MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + IF ( DISCR ) THEN + TM = ABS( ATAN2( SIN( OMEGA ), COS( OMEGA ) ) ) + ELSE + TM = OMEGA + END IF + IF( IERR.GE.1 .AND. IERR.LE.N ) THEN + GPEAK( 1 ) = ONE + FPEAK( 1 ) = TM + GPEAK( 2 ) = ZERO + FPEAK( 2 ) = ONE + GO TO 340 + ELSE IF( IERR.EQ.N+1 ) THEN + INFO = 3 + RETURN + END IF +C + IF( GAMMAL.LT.GAMMA ) THEN + GAMMAL = GAMMA + FPEAK( 1 ) = TM + FPEAK( 2 ) = ONE + END IF + 330 CONTINUE +C +C If the lower bound has not been improved, return. (This is a +C safeguard against undetected modes of Hamiltonian matrix on the +C boundary of the stability domain.) +C + IF ( GAMMAL.LT.GAMMAS*( ONE + TOL/TEN ) ) THEN + GPEAK( 1 ) = GAMMAL + GPEAK( 2 ) = ONE + GO TO 340 + END IF +C +C END WHILE +C + IF ( ITER.LE.MAXIT ) THEN + GO TO 120 + ELSE + INFO = 4 + RETURN + END IF +C + 340 CONTINUE + DWORK( 1 ) = MAXWRK + CWORK( 1 ) = MAXCWK + RETURN +C *** Last line of AB13DD *** + END diff --git a/mex/sources/libslicot/AB13DX.f b/mex/sources/libslicot/AB13DX.f new file mode 100644 index 000000000..09362b7c6 --- /dev/null +++ b/mex/sources/libslicot/AB13DX.f @@ -0,0 +1,544 @@ + DOUBLE PRECISION FUNCTION AB13DX( DICO, JOBE, JOBD, N, M, P, + $ OMEGA, A, LDA, E, LDE, B, LDB, + $ C, LDC, D, LDD, IWORK, DWORK, + $ LDWORK, CWORK, LCWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the maximum singular value of a given continuous-time +C or discrete-time transfer-function matrix, either standard or in +C the descriptor form, +C +C -1 +C G(lambda) = C*( lambda*E - A ) *B + D , +C +C for a given complex value lambda, where lambda = j*omega, in the +C continuous-time case, and lambda = exp(j*omega), in the +C discrete-time case. The matrices A, E, B, C, and D are real +C matrices of appropriate dimensions. Matrix A must be in an upper +C Hessenberg form, and if JOBE ='G', the matrix E must be upper +C triangular. The matrices B and C must correspond to the system +C in (generalized) Hessenberg form. +C +C FUNCTION VALUE +C +C AB13DX DOUBLE PRECISION +C The maximum singular value of G(lambda). +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system, as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBE CHARACTER*1 +C Specifies whether E is an upper triangular or an identity +C matrix, as follows: +C = 'G': E is a general upper triangular matrix; +C = 'I': E is the identity matrix. +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears in +C the given state space model: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C P (input) INTEGER +C The row size of the matrix C. P >= 0. +C +C OMEGA (input) DOUBLE PRECISION +C The frequency value for which the calculations should be +C done. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N upper Hessenberg part of this +C array must contain the state dynamics matrix A in upper +C Hessenberg form. The elements below the subdiagonal are +C not referenced. +C On exit, if M > 0, P > 0, OMEGA = 0, DICO = 'C', B <> 0, +C and C <> 0, the leading N-by-N upper Hessenberg part of +C this array contains the factors L and U from the LU +C factorization of A (A = P*L*U); the unit diagonal elements +C of L are not stored, L is lower bidiagonal, and P is +C stored in IWORK (see SLICOT Library routine MB02SD). +C Otherwise, this array is unchanged on exit. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C If JOBE = 'G', the leading N-by-N upper triangular part of +C this array must contain the upper triangular descriptor +C matrix E of the system. The elements of the strict lower +C triangular part of this array are not referenced. +C If JOBE = 'I', then E is assumed to be the identity +C matrix and is not referenced. +C +C LDE INTEGER +C The leading dimension of the array E. +C LDE >= MAX(1,N), if JOBE = 'G'; +C LDE >= 1, if JOBE = 'I'. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the system input matrix B. +C On exit, if M > 0, P > 0, OMEGA = 0, DICO = 'C', B <> 0, +C C <> 0, and INFO = 0 or N+1, the leading N-by-M part of +C this array contains the solution of the system A*X = B. +C Otherwise, this array is unchanged on exit. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, if JOBD = 'D', the leading P-by-M part of this +C array must contain the direct transmission matrix D. +C On exit, if (N = 0, or B = 0, or C = 0) and JOBD = 'D', +C or (OMEGA = 0, DICO = 'C', JOBD = 'D', and INFO = 0 or +C N+1), the contents of this array is destroyed. +C Otherwise, this array is unchanged on exit. +C This array is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P), if JOBD = 'D'; +C LDD >= 1, if JOBD = 'Z'. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), where +C LIWORK = N, if N > 0, M > 0, P > 0, B <> 0, and C <> 0; +C LIWORK = 0, otherwise. +C This array contains the pivot indices in the LU +C factorization of the matrix lambda*E - A; for 1 <= i <= N, +C row i of the matrix was interchanged with row IWORK(i). +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK, and DWORK(2), ..., DWORK(MIN(P,M)) contain the +C singular values of G(lambda), except for the first one, +C which is returned in the function value AB13DX. +C If (N = 0, or B = 0, or C = 0) and JOBD = 'Z', the last +C MIN(P,M)-1 zero singular values of G(lambda) are not +C stored in DWORK(2), ..., DWORK(MIN(P,M)). +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= MAX(1, LDW1 + LDW2 ), +C LDW1 = P*M, if N > 0, B <> 0, C <> 0, OMEGA = 0, +C DICO = 'C', and JOBD = 'Z'; +C LDW1 = 0, otherwise; +C LDW2 = MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), 5*MIN(P,M)), +C if (N = 0, or B = 0, or C = 0) and JOBD = 'D', +C or (N > 0, B <> 0, C <> 0, OMEGA = 0, and +C DICO = 'C'); +C LDW2 = 0, if (N = 0, or B = 0, or C = 0) and JOBD = 'Z', +C or MIN(P,M) = 0; +C LDW2 = 6*MIN(P,M), otherwise. +C For good performance, LDWORK must generally be larger. +C +C CWORK COMPLEX*16 array, dimension (LCWORK) +C On exit, if INFO = 0, CWORK(1) contains the optimal +C LCWORK. +C +C LCWORK INTEGER +C The dimension of the array CWORK. +C LCWORK >= 1, if N = 0, or B = 0, or C = 0, or (OMEGA = 0 +C and DICO = 'C') or MIN(P,M) = 0; +C LCWORK >= MAX(1, (N+M)*(N+P) + 2*MIN(P,M) + MAX(P,M)), +C otherwise. +C For good performance, LCWORK must generally be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, U(i,i) is exactly zero; the LU +C factorization of the matrix lambda*E - A has been +C completed, but the factor U is exactly singular, +C i.e., the matrix lambda*E - A is exactly singular; +C = N+1: the SVD algorithm for computing singular values +C did not converge. +C +C METHOD +C +C The routine implements standard linear algebra calculations, +C taking problem structure into account. LAPACK Library routines +C DGESVD and ZGESVD are used for finding the singular values. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2001. +C V. Sima, Research Institute for Informatics, Bucharest, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Sep. 2005. +C +C KEYWORDS +C +C H-infinity optimal control, robust control, system norm. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER DICO, JOBD, JOBE + INTEGER INFO, LCWORK, LDA, LDB, LDC, LDD, LDE, LDWORK, + $ M, N, P + DOUBLE PRECISION OMEGA +C .. +C .. Array Arguments .. + COMPLEX*16 CWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), DWORK( * ), E( LDE, * ) + INTEGER IWORK( * ) +C .. +C .. Local Scalars .. + LOGICAL DISCR, FULLE, NODYN, SPECL, WITHD + INTEGER I, ICB, ICC, ICD, ICWK, ID, IERR, IS, IWRK, J, + $ MAXWRK, MINCWR, MINPM, MINWRK + DOUBLE PRECISION BNORM, CNORM, LAMBDI, LAMBDR, UPD +C +C .. External Functions .. + DOUBLE PRECISION DLANGE + LOGICAL LSAME + EXTERNAL DLANGE, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DGESVD, MB02RD, MB02RZ, MB02SD, MB02SZ, + $ XERBLA, ZGEMM, ZGESVD, ZLACP2 +C .. +C .. Intrinsic Functions .. + INTRINSIC COS, DCMPLX, INT, MAX, MIN, SIN +C .. +C .. Executable Statements .. +C +C Test the input scalar parameters. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + FULLE = LSAME( JOBE, 'G' ) + WITHD = LSAME( JOBD, 'D' ) +C + IF( .NOT. ( DISCR .OR. LSAME( DICO, 'C' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( FULLE .OR. LSAME( JOBE, 'I' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDE.LT.1 .OR. ( FULLE .AND. LDE.LT.N ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN + INFO = -17 + ELSE + BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) + CNORM = DLANGE( '1-norm', P, N, C, LDC, DWORK ) + NODYN = N.EQ.0 .OR. MIN( BNORM, CNORM ).EQ.ZERO + SPECL = .NOT.NODYN .AND. OMEGA.EQ.ZERO .AND. .NOT.DISCR + MINPM = MIN( P, M ) +C +C Compute workspace. +C + IF( MINPM.EQ.0 ) THEN + MINWRK = 0 + ELSE IF( SPECL .OR. ( NODYN .AND. WITHD ) ) THEN + MINWRK = MINPM + MAX( 3*MINPM + MAX( P, M ), 5*MINPM ) + IF ( SPECL .AND. .NOT.WITHD ) + $ MINWRK = MINWRK + P*M + ELSE IF ( NODYN .AND. .NOT.WITHD ) THEN + MINWRK = 0 + ELSE + MINWRK = 6*MINPM + END IF + MINWRK = MAX( 1, MINWRK ) +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -20 + ELSE + IF ( NODYN .OR. ( OMEGA.EQ.ZERO .AND. .NOT.DISCR ) .OR. + $ MINPM.EQ.0 ) THEN + MINCWR = 1 + ELSE + MINCWR = MAX( 1, ( N + M )*( N + P ) + + $ 2*MINPM + MAX( P, M ) ) + END IF + IF( LCWORK.LT.MINCWR ) + $ INFO = -22 + END IF + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'AB13DX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MINPM.EQ.0 ) THEN + AB13DX = ZERO +C + DWORK( 1 ) = ONE + CWORK( 1 ) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + IS = 1 + IWRK = IS + MINPM +C + IF( NODYN ) THEN +C +C No dynamics: Determine the maximum singular value of G = D . +C + IF ( WITHD ) THEN +C +C Workspace: need MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), +C 5*MIN(P,M)); +C prefer larger. +C + CALL DGESVD( 'No Vectors', 'No Vectors', P, M, D, LDD, + $ DWORK( IS ), DWORK, P, DWORK, M, DWORK( IWRK ), + $ LDWORK-IWRK+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = N + 1 + RETURN + END IF + AB13DX = DWORK( IS ) + MAXWRK = INT( DWORK( IWRK ) ) + IWRK - 1 + ELSE + AB13DX = ZERO + MAXWRK = 1 + END IF +C + DWORK( 1 ) = MAXWRK + CWORK( 1 ) = ONE + RETURN + END IF +C +C Determine the maximum singular value of +C G(lambda) = C*inv(lambda*E - A)*B + D. +C The (generalized) Hessenberg form of the system is used. +C + IF ( SPECL ) THEN +C +C Special continuous-time case: +C Determine the maximum singular value of the real matrix G(0). +C Workspace: need MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), +C 5*MIN(P,M)); +C prefer larger. +C + CALL MB02SD( N, A, LDA, IWORK, IERR ) + IF( IERR.GT.0 ) THEN + INFO = IERR + DWORK( 1 ) = ONE + CWORK( 1 ) = ONE + RETURN + END IF + CALL MB02RD( 'No Transpose', N, M, A, LDA, IWORK, B, LDB, + $ IERR ) + IF ( WITHD ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', P, M, N, -ONE, + $ C, LDC, B, LDB, ONE, D, LDD ) + CALL DGESVD( 'No Vectors', 'No Vectors', P, M, D, LDD, + $ DWORK( IS ), DWORK, P, DWORK, M, DWORK( IWRK ), + $ LDWORK-IWRK+1, IERR ) + ELSE +C +C Additional workspace: need P*M. +C + ID = IWRK + IWRK = ID + P*M + CALL DGEMM( 'No Transpose', 'No Transpose', P, M, N, -ONE, + $ C, LDC, B, LDB, ZERO, DWORK( ID ), P ) + CALL DGESVD( 'No Vectors', 'No Vectors', P, M, DWORK( ID ), + $ P, DWORK( IS ), DWORK, P, DWORK, M, + $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + END IF + IF( IERR.GT.0 ) THEN + INFO = N + 1 + RETURN + END IF +C + AB13DX = DWORK( IS ) + DWORK( 1 ) = INT( DWORK( IWRK ) ) + IWRK - 1 + CWORK( 1 ) = ONE + RETURN + END IF +C +C General case: Determine the maximum singular value of G(lambda). +C Complex workspace: need N*N + N*M + P*N + P*M. +C + ICB = 1 + N*N + ICC = ICB + N*M + ICD = ICC + P*N + ICWK = ICD + P*M +C + IF ( WITHD ) THEN + UPD = ONE + ELSE + UPD = ZERO + END IF +C + IF ( DISCR ) THEN + LAMBDR = COS( OMEGA ) + LAMBDI = SIN( OMEGA ) +C +C Build lambda*E - A . +C + IF ( FULLE ) THEN +C + DO 20 J = 1, N +C + DO 10 I = 1, J + CWORK( I+(J-1)*N ) = + $ DCMPLX( LAMBDR*E( I, J ) - A( I, J ), + $ LAMBDI*E( I, J ) ) + 10 CONTINUE +C + IF( J.LT.N ) + $ CWORK( J+1+(J-1)*N ) = DCMPLX( -A( J+1, J ), ZERO ) + 20 CONTINUE +C + ELSE +C + DO 40 J = 1, N +C + DO 30 I = 1, MIN( J+1, N ) + CWORK( I+(J-1)*N ) = -A( I, J ) + 30 CONTINUE +C + CWORK( J+(J-1)*N ) = DCMPLX( LAMBDR - A( J, J ), LAMBDI ) + 40 CONTINUE +C + END IF +C + ELSE +C +C Build j*omega*E - A. +C + IF ( FULLE ) THEN +C + DO 60 J = 1, N +C + DO 50 I = 1, J + CWORK( I+(J-1)*N ) = + $ DCMPLX( -A( I, J ), OMEGA*E( I, J ) ) + 50 CONTINUE +C + IF( J.LT.N ) + $ CWORK( J+1+(J-1)*N ) = DCMPLX( -A( J+1, J ), ZERO ) + 60 CONTINUE +C + ELSE +C + DO 80 J = 1, N +C + DO 70 I = 1, MIN( J+1, N ) + CWORK( I+(J-1)*N ) = -A( I, J ) + 70 CONTINUE +C + CWORK( J+(J-1)*N ) = DCMPLX( -A( J, J ), OMEGA ) + 80 CONTINUE +C + END IF +C + END IF +C +C Build G(lambda) . +C + CALL ZLACP2( 'Full', N, M, B, LDB, CWORK( ICB ), N ) + CALL ZLACP2( 'Full', P, N, C, LDC, CWORK( ICC ), P ) + IF ( WITHD ) + $ CALL ZLACP2( 'Full', P, M, D, LDD, CWORK( ICD ), P ) +C + CALL MB02SZ( N, CWORK, N, IWORK, IERR ) + IF( IERR.GT.0 ) THEN + INFO = IERR + DWORK( 1 ) = ONE + CWORK( 1 ) = ICWK - 1 + RETURN + END IF + CALL MB02RZ( 'No Transpose', N, M, CWORK, N, IWORK, + $ CWORK( ICB ), N, IERR ) + CALL ZGEMM( 'No Transpose', 'No Transpose', P, M, N, CONE, + $ CWORK( ICC ), P, CWORK( ICB ), N, + $ DCMPLX( UPD, ZERO ), CWORK( ICD ), P ) +C +C Additional workspace, complex: need 2*MIN(P,M) + MAX(P,M); +C prefer larger; +C real: need 5*MIN(P,M). +C + CALL ZGESVD( 'No Vectors', 'No Vectors', P, M, CWORK( ICD ), P, + $ DWORK( IS ), CWORK, P, CWORK, M, CWORK( ICWK ), + $ LCWORK-ICWK+1, DWORK( IWRK ), IERR ) + IF( IERR.GT.0 ) THEN + INFO = N + 1 + RETURN + END IF + AB13DX = DWORK( IS ) +C + DWORK( 1 ) = 6*MINPM + CWORK( 1 ) = INT( CWORK( ICWK ) ) + ICWK - 1 +C + RETURN +C *** Last line of AB13DX *** + END diff --git a/mex/sources/libslicot/AB13ED.f b/mex/sources/libslicot/AB13ED.f new file mode 100644 index 000000000..32033b739 --- /dev/null +++ b/mex/sources/libslicot/AB13ED.f @@ -0,0 +1,347 @@ + SUBROUTINE AB13ED( N, A, LDA, LOW, HIGH, TOL, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate beta(A), the 2-norm distance from a real matrix A to +C the nearest complex matrix with an eigenvalue on the imaginary +C axis. The estimate is given as +C +C LOW <= beta(A) <= HIGH, +C +C where either +C +C (1 + TOL) * LOW >= HIGH, +C +C or +C +C LOW = 0 and HIGH = delta, +C +C and delta is a small number approximately equal to the square root +C of machine precision times the Frobenius norm (Euclidean norm) +C of A. If A is stable in the sense that all eigenvalues of A lie +C in the open left half complex plane, then beta(A) is the distance +C to the nearest unstable complex matrix, i.e., the complex +C stability radius. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C LOW (output) DOUBLE PRECISION +C A lower bound for beta(A). +C +C HIGH (output) DOUBLE PRECISION +C An upper bound for beta(A). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Specifies the accuracy with which LOW and HIGH approximate +C beta(A). If the user sets TOL to be less than SQRT(EPS), +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH), then the tolerance is taken to be +C SQRT(EPS). +C The recommended value is TOL = 9, which gives an estimate +C of beta(A) correct to within an order of magnitude. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, 3*N*(N+1) ). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the QR algorithm (LAPACK Library routine DHSEQR) +C fails to converge; this error is very rare. +C +C METHOD +C +C Let beta(A) be the 2-norm distance from a real matrix A to the +C nearest complex matrix with an eigenvalue on the imaginary axis. +C It is known that beta(A) = minimum of the smallest singular +C value of (A - jwI), where I is the identity matrix and j**2 = -1, +C and the minimum is taken over all real w. +C The algorithm computes a lower bound LOW and an upper bound HIGH +C for beta(A) by a bisection method in the following way. Given a +C non-negative real number sigma, the Hamiltonian matrix H(sigma) +C is constructed: +C +C | A -sigma*I | | A G | +C H(sigma) = | | := | | . +C | sigma*I -A' | | F -A' | +C +C It can be shown [1] that H(sigma) has an eigenvalue whose real +C part is zero if and only if sigma >= beta. Any lower and upper +C bounds on beta(A) can be improved by choosing a number between +C them and checking to see if H(sigma) has an eigenvalue with zero +C real part. This decision is made by computing the eigenvalues of +C H(sigma) using the square reduced algorithm of Van Loan [2]. +C +C REFERENCES +C +C [1] Byers, R. +C A bisection method for measuring the distance of a stable +C matrix to the unstable matrices. +C SIAM J. Sci. Stat. Comput., Vol. 9, No. 5, pp. 875-880, 1988. +C +C [2] Van Loan, C.F. +C A symplectic method for approximating all the eigenvalues of a +C Hamiltonian matrix. +C Linear Algebra and its Applications, Vol 61, 233-251, 1984. +C +C NUMERICAL ASPECTS +C +C Due to rounding errors the computed values of LOW and HIGH can be +C proven to satisfy +C +C LOW - p(n) * sqrt(e) * norm(A) <= beta(A) +C and +C beta(A) <= HIGH + p(n) * sqrt(e) * norm(A), +C +C where p(n) is a modest polynomial of degree 3, e is the machine +C precision and norm(A) is the Frobenius norm of A, see [1]. +C The recommended value for TOL is 9 which gives an estimate of +C beta(A) correct to within an order of magnitude. +C AB13ED requires approximately 38*N**3 flops for TOL = 9. +C +C CONTRIBUTOR +C +C R. Byers, the routines BISEC and BISEC0 (January, 1995). +C +C REVISIONS +C +C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. +C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2003. +C +C KEYWORDS +C +C Distances, eigenvalue, eigenvalue perturbation, norms, stability +C radius. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION HIGH, LOW, TOL + INTEGER INFO, LDA, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*) +C .. Local Scalars .. + INTEGER I, IA2, IAA, IGF, IHI, ILO, IWI, IWK, IWR, + $ JWORK, MINWRK, N2 + DOUBLE PRECISION ANRM, SEPS, SFMN, SIGMA, TAU, TEMP, TOL1, TOL2 + LOGICAL RNEG, SUFWRK +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1), DUMMY2(1,1) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE +C .. External Subroutines .. + EXTERNAL DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DSYMM, + $ DSYMV, MA02ED, MB04ZD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, SQRT +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + MINWRK = 3*N*( N + 1 ) +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -3 + ELSE IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN + INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB13ED', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + LOW = ZERO + IF ( N.EQ.0 ) THEN + HIGH = ZERO + DWORK(1) = ONE + RETURN + END IF +C +C Indices for splitting the work array. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + N2 = N*N + IGF = 1 + IA2 = IGF + N2 + N + IAA = IA2 + N2 + IWK = IAA + N2 + IWR = IAA + IWI = IWR + N +C + SUFWRK = LDWORK-IWK.GE.N2 +C +C Computation of the tolerances and the treshold for termination of +C the bisection method. SEPS is the square root of the machine +C precision. +C + SFMN = DLAMCH( 'Safe minimum' ) + SEPS = SQRT( DLAMCH( 'Epsilon' ) ) + TAU = ONE + MAX( TOL, SEPS ) + ANRM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) + TOL1 = SEPS * ANRM + TOL2 = TOL1 * DBLE( 2*N ) +C +C Initialization of the bisection method. +C + HIGH = ANRM +C +C WHILE ( HIGH > TAU*MAX( TOL1, LOW ) ) DO + 10 IF ( HIGH.GT.( TAU*MAX( TOL1, LOW ) ) ) THEN + SIGMA = SQRT( HIGH ) * SQRT( MAX( TOL1, LOW ) ) +C +C Set up H(sigma). +C Workspace: N*(N+1)+2*N*N. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IAA), N ) + DWORK(IGF) = SIGMA + DWORK(IGF+N) = -SIGMA + DUMMY(1) = ZERO + CALL DCOPY( N-1, DUMMY, 0, DWORK(IGF+1), 1 ) +C + DO 20 I = IGF, IA2 - N - 2, N + 1 + CALL DCOPY( N+1, DWORK(I), 1, DWORK(I+N+1), 1 ) + 20 CONTINUE +C +C Computation of the eigenvalues by the square reduced algorithm. +C Workspace: N*(N+1)+2*N*N+2*N. +C + CALL MB04ZD( 'No vectors', N, DWORK(IAA), N, DWORK(IGF), N, + $ DUMMY2, 1, DWORK(IWK), INFO ) +C +C Form the matrix A*A + F*G. +C Workspace: need N*(N+1)+2*N*N+N; +C prefer N*(N+1)+3*N*N. +C + JWORK = IA2 + IF ( SUFWRK ) + $ JWORK = IWK +C + CALL DLACPY( 'Lower', N, N, DWORK(IGF), N, DWORK(JWORK), N ) + CALL MA02ED( 'Lower', N, DWORK(JWORK), N ) +C + IF ( SUFWRK ) THEN +C +C Use BLAS 3 calculation. +C + CALL DSYMM( 'Left', 'Upper', N, N, ONE, DWORK(IGF+N), N, + $ DWORK(JWORK), N, ZERO, DWORK(IA2), N ) + ELSE +C +C Use BLAS 2 calculation. +C + DO 30 I = 1, N + CALL DSYMV( 'Upper', N, ONE, DWORK(IGF+N), N, + $ DWORK(IA2+N*(I-1)), 1, ZERO, DWORK(IWK), 1 ) + CALL DCOPY( N, DWORK(IWK), 1, DWORK(IA2+N*(I-1)), 1 ) + 30 CONTINUE +C + END IF +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, + $ DWORK(IAA), N, DWORK(IAA), N, ONE, DWORK(IA2), N ) +C +C Find the eigenvalues of A*A + F*G. +C Workspace: N*(N+1)+N*N+3*N. +C + JWORK = IWI + N + CALL DGEBAL( 'Scale', N, DWORK(IA2), N, ILO, IHI, DWORK(JWORK), + $ I ) + CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI, + $ DWORK(IA2), N, DWORK(IWR), DWORK(IWI), DUMMY2, 1, + $ DWORK(JWORK), N, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = 1 + RETURN + END IF +C +C (DWORK(IWR+i), DWORK(IWI+i)), i = 0,...,N-1, contain the +C squares of the eigenvalues of H(sigma). +C + I = 0 + RNEG = .FALSE. +C WHILE ( ( DWORK(IWR+i),DWORK(IWI+i) ) not real positive +C .AND. I < N ) DO + 40 IF ( .NOT.RNEG .AND. I.LT.N ) THEN + TEMP = ABS( DWORK(IWI+I) ) + IF ( TOL1.GT.SFMN ) TEMP = TEMP / TOL1 + RNEG = ( ( DWORK(IWR+I).LT.ZERO ) .AND. ( TEMP.LE.TOL2 ) ) + I = I + 1 + GO TO 40 +C END WHILE 40 + END IF + + IF ( RNEG ) THEN + HIGH = SIGMA + ELSE + LOW = SIGMA + END IF + GO TO 10 +C END WHILE 10 + END IF +C +C Set optimal workspace dimension. +C + DWORK(1) = DBLE( MAX( 4*N2 + N, MINWRK ) ) +C +C *** Last line of AB13ED *** + END diff --git a/mex/sources/libslicot/AB13FD.f b/mex/sources/libslicot/AB13FD.f new file mode 100644 index 000000000..44628b470 --- /dev/null +++ b/mex/sources/libslicot/AB13FD.f @@ -0,0 +1,403 @@ + SUBROUTINE AB13FD( N, A, LDA, BETA, OMEGA, TOL, DWORK, LDWORK, + $ CWORK, LCWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute beta(A), the 2-norm distance from a real matrix A to +C the nearest complex matrix with an eigenvalue on the imaginary +C axis. If A is stable in the sense that all eigenvalues of A lie +C in the open left half complex plane, then beta(A) is the complex +C stability radius, i.e., the distance to the nearest unstable +C complex matrix. The value of beta(A) is the minimum of the +C smallest singular value of (A - jwI), taken over all real w. +C The value of w corresponding to the minimum is also computed. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C BETA (output) DOUBLE PRECISION +C The computed value of beta(A), which actually is an upper +C bound. +C +C OMEGA (output) DOUBLE PRECISION +C The value of w such that the smallest singular value of +C (A - jwI) equals beta(A). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Specifies the accuracy with which beta(A) is to be +C calculated. (See the Numerical Aspects section below.) +C If the user sets TOL to be less than EPS, where EPS is the +C machine precision (see LAPACK Library Routine DLAMCH), +C then the tolerance is taken to be EPS. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C If DWORK(1) is not needed, the first 2*N*N entries of +C DWORK may overlay CWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, 3*N*(N+2) ). +C For optimum performance LDWORK should be larger. +C +C CWORK COMPLEX*16 array, dimension (LCWORK) +C On exit, if INFO = 0, CWORK(1) returns the optimal value +C of LCWORK. +C If CWORK(1) is not needed, the first N*N entries of +C CWORK may overlay DWORK. +C +C LCWORK INTEGER +C The length of the array CWORK. +C LCWORK >= MAX( 1, N*(N+3) ). +C For optimum performance LCWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the routine fails to compute beta(A) within the +C specified tolerance. Nevertheless, the returned +C value is an upper bound on beta(A); +C = 2: either the QR or SVD algorithm (LAPACK Library +C routines DHSEQR, DGESVD or ZGESVD) fails to +C converge; this error is very rare. +C +C METHOD +C +C AB13FD combines the methods of [1] and [2] into a provably +C reliable, quadratically convergent algorithm. It uses the simple +C bisection strategy of [1] to find an interval which contains +C beta(A), and then switches to the modified bisection strategy of +C [2] which converges quadratically to a minimizer. Note that the +C efficiency of the strategy degrades if there are several local +C minima that are near or equal the global minimum. +C +C REFERENCES +C +C [1] Byers, R. +C A bisection method for measuring the distance of a stable +C matrix to the unstable matrices. +C SIAM J. Sci. Stat. Comput., Vol. 9, No. 5, pp. 875-880, 1988. +C +C [2] Boyd, S. and Balakrishnan, K. +C A regularity result for the singular values of a transfer +C matrix and a quadratically convergent algorithm for computing +C its L-infinity norm. +C Systems and Control Letters, Vol. 15, pp. 1-7, 1990. +C +C NUMERICAL ASPECTS +C +C In the presence of rounding errors, the computed function value +C BETA satisfies +C +C beta(A) <= BETA + epsilon, +C +C BETA/(1+TOL) - delta <= MAX(beta(A), SQRT(2*N*EPS)*norm(A)), +C +C where norm(A) is the Frobenius norm of A, +C +C epsilon = p(N) * EPS * norm(A), +C and +C delta = p(N) * SQRT(EPS) * norm(A), +C +C and p(N) is a low degree polynomial. It is recommended to choose +C TOL greater than SQRT(EPS). Although rounding errors can cause +C AB13FD to fail for smaller values of TOL, nevertheless, it usually +C succeeds. Regardless of success or failure, the first inequality +C holds. +C +C CONTRIBUTORS +C +C R. Byers, the routines QSEC and QSEC0 (January, 1995). +C +C REVISIONS +C +C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2002, +C Jan. 2003. +C +C KEYWORDS +C +C complex stability radius, distances, eigenvalue, eigenvalue +C perturbation, norms. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 50 ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) +C .. Scalar Arguments .. + INTEGER INFO, LCWORK, LDA, LDWORK, N + DOUBLE PRECISION BETA, OMEGA, TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*) + COMPLEX*16 CWORK(*) +C .. Local Scalars .. + INTEGER I, IA2, IAA, IGF, IHI, ILO, ITNUM, IWI, IWK, + $ IWR, JWORK, KOM, LBEST, MINWRK, N2 + DOUBLE PRECISION EPS, LOW, OM, OM1, OM2, SFMN, SIGMA, SV, TAU, + $ TEMP, TOL1 + LOGICAL SUFWRK +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1), DUMMY2(1,1) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, MB03NY + EXTERNAL DLAMCH, DLANGE, MB03NY +C .. External Subroutines .. + EXTERNAL DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DSYMM, + $ DSYMV, MA02ED, MB04ZD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, SQRT +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + MINWRK = 3*N*( N + 2 ) +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -3 + ELSE IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN + INFO = -8 + ELSE IF( LCWORK.LT.MAX( 1, N*( N + 3 ) ) ) THEN + INFO = -10 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB13FD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + OMEGA = ZERO + IF ( N.EQ.0 ) THEN + BETA = ZERO + DWORK(1) = ONE + CWORK(1) = CONE + RETURN + END IF +C +C Indices for splitting the work array. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance.) +C + N2 = N*N + IGF = 1 + IA2 = IGF + N2 + N + IAA = IA2 + N2 + IWK = IAA + N2 + IWR = IAA + IWI = IWR + N +C + SUFWRK = LDWORK-IWK.GE.N2 +C +C Computation of the tolerances. EPS is the machine precision. +C + SFMN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Epsilon' ) + TOL1 = SQRT( EPS * DBLE( 2*N ) ) * + $ DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) + TAU = ONE + MAX( TOL, EPS ) +C +C Initialization, upper bound at known critical point. +C Workspace: need N*(N+1)+5*N; prefer larger. +C + KOM = 2 + LOW = ZERO + CALL DLACPY( 'All', N, N, A, LDA, DWORK(IGF), N ) + BETA = MB03NY( N, OMEGA, DWORK(IGF), N, DWORK(IGF+N2), + $ DWORK(IA2), LDWORK-IA2, CWORK, LCWORK, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + LBEST = MAX( MINWRK, INT( DWORK(IA2) ) - IA2 + 1, 4*N2 + N ) +C + ITNUM = 1 +C WHILE ( ITNUM <= MAXIT and BETA > TAU*MAX( TOL1, LOW ) ) DO + 10 IF ( ( ITNUM.LE.MAXIT ) .AND. + $ ( BETA.GT.TAU*MAX( TOL1, LOW ) ) ) THEN + IF ( KOM.EQ.2 ) THEN + SIGMA = BETA/TAU + ELSE + SIGMA = SQRT( BETA ) * SQRT( MAX( TOL1, LOW ) ) + END IF +C +C Set up H(sigma). +C Workspace: N*(N+1)+2*N*N. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IAA), N ) + DWORK(IGF) = SIGMA + DWORK(IGF+N) = -SIGMA + DUMMY(1) = ZERO + CALL DCOPY( N-1, DUMMY, 0, DWORK(IGF+1), 1 ) +C + DO 20 I = IGF, IA2 - N - 2, N + 1 + CALL DCOPY( N+1, DWORK(I), 1, DWORK(I+N+1), 1 ) + 20 CONTINUE +C +C Computation of the eigenvalues by the square reduced algorithm. +C Workspace: N*(N+1)+2*N*N+2*N. +C + CALL MB04ZD( 'No vectors', N, DWORK(IAA), N, DWORK(IGF), N, + $ DUMMY2, 1, DWORK(IWK), INFO ) +C +C Form the matrix A*A + F*G. +C Workspace: need N*(N+1)+2*N*N+N; +C prefer N*(N+1)+3*N*N. +C + JWORK = IA2 + IF ( SUFWRK ) + $ JWORK = IWK +C + CALL DLACPY( 'Lower', N, N, DWORK(IGF), N, DWORK(JWORK), N ) + CALL MA02ED( 'Lower', N, DWORK(JWORK), N ) +C + IF ( SUFWRK ) THEN +C +C Use BLAS 3 calculation. +C + CALL DSYMM( 'Left', 'Upper', N, N, ONE, DWORK(IGF+N), N, + $ DWORK(JWORK), N, ZERO, DWORK(IA2), N ) + ELSE +C +C Use BLAS 2 calculation. +C + DO 30 I = 1, N + CALL DSYMV( 'Upper', N, ONE, DWORK(IGF+N), N, + $ DWORK(IA2+N*(I-1)), 1, ZERO, DWORK(IWK), 1 ) + CALL DCOPY( N, DWORK(IWK), 1, DWORK(IA2+N*(I-1)), 1 ) + 30 CONTINUE +C + END IF +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, + $ DWORK(IAA), N, DWORK(IAA), N, ONE, DWORK(IA2), N ) +C +C Find the eigenvalues of A*A + F*G. +C Workspace: N*(N+1)+N*N+3*N. +C + JWORK = IWI + N + CALL DGEBAL( 'Scale', N, DWORK(IA2), N, ILO, IHI, DWORK(JWORK), + $ I ) + CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI, + $ DWORK(IA2), N, DWORK(IWR), DWORK(IWI), DUMMY2, 1, + $ DWORK(JWORK), N, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = 2 + RETURN + END IF +C +C Count negative real axis squared eigenvalues. If there are two, +C then the valley is isolated, and next approximate minimizer is +C mean of the square roots. +C + KOM = 0 + DO 40 I = 0, N - 1 + TEMP = ABS( DWORK(IWI+I) ) + IF ( TOL1.GT.SFMN ) TEMP = TEMP / TOL1 + IF ( ( DWORK(IWR+I).LT.ZERO ) .AND. ( TEMP.LE.TOL1 ) ) THEN + KOM = KOM + 1 + OM = SQRT( -DWORK(IWR+I) ) + IF ( KOM.EQ.1 ) OM1 = OM + IF ( KOM.EQ.2 ) OM2 = OM + END IF + 40 CONTINUE +C + IF ( KOM.EQ.0 ) THEN + LOW = SIGMA + ELSE +C +C In exact arithmetic KOM = 1 is impossible, but if tau is +C close enough to one, MB04ZD may miss the initial near zero +C eigenvalue. +C Workspace, real: need 3*N*(N+2); prefer larger; +C complex: need N*(N+3); prefer larger. +C + IF ( KOM.EQ.2 ) THEN + OM = OM1 + ( OM2 - OM1 ) / TWO + ELSE IF ( KOM.EQ.1 .AND. ITNUM.EQ.1 ) THEN + OM = OM1 / TWO + KOM = 2 + END IF +C + CALL DLACPY( 'All', N, N, A, LDA, DWORK(IGF), N ) + SV = MB03NY( N, OM, DWORK(IGF), N, DWORK(IGF+N2), + $ DWORK(IA2), LDWORK-IA2, CWORK, LCWORK, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + IF ( BETA.GT.SV ) THEN + BETA = SV + OMEGA = OM + ELSE + INFO = 1 + RETURN + END IF + END IF + ITNUM = ITNUM + 1 + GO TO 10 +C END WHILE 10 + END IF +C + IF ( BETA .GT. TAU*MAX( TOL1, LOW ) ) THEN +C +C Failed to meet bounds within MAXIT iterations. +C + INFO = 1 + RETURN + END IF +C +C Set optimal real workspace dimension (complex workspace is already +C set by MB03NY). +C + DWORK(1) = LBEST +C + RETURN +C *** Last line of AB13FD *** + END diff --git a/mex/sources/libslicot/AB13MD.f b/mex/sources/libslicot/AB13MD.f new file mode 100644 index 000000000..e0e0d4724 --- /dev/null +++ b/mex/sources/libslicot/AB13MD.f @@ -0,0 +1,1782 @@ + SUBROUTINE AB13MD( FACT, N, Z, LDZ, M, NBLOCK, ITYPE, X, BOUND, D, + $ G, IWORK, DWORK, LDWORK, ZWORK, LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute an upper bound on the structured singular value for a +C given square complex matrix and a given block structure of the +C uncertainty. +C +C ARGUMENTS +C +C Mode Parameters +C +C FACT CHARACTER*1 +C Specifies whether or not an information from the +C previous call is supplied in the vector X. +C = 'F': On entry, X contains information from the +C previous call. +C = 'N': On entry, X does not contain an information from +C the previous call. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix Z. N >= 0. +C +C Z (input) COMPLEX*16 array, dimension (LDZ,N) +C The leading N-by-N part of this array must contain the +C complex matrix Z for which the upper bound on the +C structured singular value is to be computed. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= max(1,N). +C +C M (input) INTEGER +C The number of diagonal blocks in the block structure of +C the uncertainty. M >= 1. +C +C NBLOCK (input) INTEGER array, dimension (M) +C The vector of length M containing the block structure +C of the uncertainty. NBLOCK(I), I = 1:M, is the size of +C each block. +C +C ITYPE (input) INTEGER array, dimension (M) +C The vector of length M indicating the type of each block. +C For I = 1:M, +C ITYPE(I) = 1 indicates that the corresponding block is a +C real block, and +C ITYPE(I) = 2 indicates that the corresponding block is a +C complex block. +C NBLOCK(I) must be equal to 1 if ITYPE(I) is equal to 1. +C +C X (input/output) DOUBLE PRECISION array, dimension +C ( M + MR - 1 ), where MR is the number of the real blocks. +C On entry, if FACT = 'F' and NBLOCK(1) < N, this array +C must contain information from the previous call to AB13MD. +C If NBLOCK(1) = N, this array is not used. +C On exit, if NBLOCK(1) < N, this array contains information +C that can be used in the next call to AB13MD for a matrix +C close to Z. +C +C BOUND (output) DOUBLE PRECISION +C The upper bound on the structured singular value. +C +C D, G (output) DOUBLE PRECISION arrays, dimension (N) +C The vectors of length N containing the diagonal entries +C of the diagonal N-by-N matrices D and G, respectively, +C such that the matrix +C Z'*D^2*Z + sqrt(-1)*(G*Z-Z'*G) - BOUND^2*D^2 +C is negative semidefinite. +C +C Workspace +C +C IWORK INTEGER array, dimension MAX(4*M-2,N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 2*N*N*M - N*N + 9*M*M + N*M + 11*N + 33*M - 11. +C For best performance +C LDWORK >= 2*N*N*M - N*N + 9*M*M + N*M + 6*N + 33*M - 11 + +C MAX( 5*N,2*N*NB ) +C where NB is the optimal blocksize returned by ILAENV. +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C On exit, if INFO = 0, ZWORK(1) contains the optimal value +C of LZWORK. +C +C LZWORK INTEGER +C The dimension of the array ZWORK. +C LZWORK >= 6*N*N*M + 12*N*N + 6*M + 6*N - 3. +C For best performance +C LZWORK >= 6*N*N*M + 12*N*N + 6*M + 3*N - 3 + +C MAX( 3*N,N*NB ) +C where NB is the optimal blocksize returned by ILAENV. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the block sizes must be positive integers; +C = 2: the sum of block sizes must be equal to N; +C = 3: the size of a real block must be equal to 1; +C = 4: the block type must be either 1 or 2; +C = 5: errors in solving linear equations or in matrix +C inversion; +C = 6: errors in computing eigenvalues or singular values. +C +C METHOD +C +C The routine computes the upper bound proposed in [1]. +C +C REFERENCES +C +C [1] Fan, M.K.H., Tits, A.L., and Doyle, J.C. +C Robustness in the presence of mixed parametric uncertainty +C and unmodeled dynamics. +C IEEE Trans. Automatic Control, vol. AC-36, 1991, pp. 25-38. +C +C NUMERICAL ASPECTS +C +C The accuracy and speed of computation depend on the value of +C the internal threshold TOL. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, F. Delebecque, D.W. Gu, M.M. Konstantinov and +C S. Steer with the assistance of V. Sima, September 2000. +C +C REVISIONS +C +C V. Sima, Katholieke Universiteit Leuven, February 2001. +C +C KEYWORDS +C +C H-infinity optimal control, Robust control, Structured singular +C value. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 CZERO, CONE, CIMAG + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ), + $ CIMAG = ( 0.0D+0, 1.0D+0 ) ) + DOUBLE PRECISION ZERO, ONE, TWO, FOUR, FIVE, EIGHT, TEN, FORTY, + $ FIFTY + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+0, FIVE = 5.0D+0, EIGHT = 8.0D+0, + $ TEN = 1.0D+1, FORTY = 4.0D+1, FIFTY = 5.0D+1 + $ ) + DOUBLE PRECISION ALPHA, BETA, THETA + PARAMETER ( ALPHA = 100.0D+0, BETA = 1.0D-2, + $ THETA = 1.0D-2 ) + DOUBLE PRECISION C1, C2, C3, C4, C5, C6, C7, C8, C9 + PARAMETER ( C1 = 1.0D-3, C2 = 1.0D-2, C3 = 0.25D+0, + $ C4 = 0.9D+0, C5 = 1.5D+0, C6 = 1.0D+1, + $ C7 = 1.0D+2, C8 = 1.0D+3, C9 = 1.0D+4 ) +C .. +C .. Scalar Arguments .. + CHARACTER FACT + INTEGER INFO, LDWORK, LDZ, LZWORK, M, N + DOUBLE PRECISION BOUND +C .. +C .. Array Arguments .. + INTEGER ITYPE( * ), IWORK( * ), NBLOCK( * ) + COMPLEX*16 Z( LDZ, * ), ZWORK( * ) + DOUBLE PRECISION D( * ), DWORK( * ), G( * ), X( * ) +C .. +C .. Local Scalars .. + INTEGER I, INFO2, ISUM, ITER, IW2, IW3, IW4, IW5, IW6, + $ IW7, IW8, IW9, IW10, IW11, IW12, IW13, IW14, + $ IW15, IW16, IW17, IW18, IW19, IW20, IW21, IW22, + $ IW23, IW24, IW25, IW26, IW27, IW28, IW29, IW30, + $ IW31, IW32, IW33, IWRK, IZ2, IZ3, IZ4, IZ5, + $ IZ6, IZ7, IZ8, IZ9, IZ10, IZ11, IZ12, IZ13, + $ IZ14, IZ15, IZ16, IZ17, IZ18, IZ19, IZ20, IZ21, + $ IZ22, IZ23, IZ24, IZWRK, J, K, L, LWA, LWAMAX, + $ LZA, LZAMAX, MINWRK, MINZRK, MR, MT, NSUM, SDIM + COMPLEX*16 DETF, TEMPIJ, TEMPJI + DOUBLE PRECISION C, COLSUM, DELTA, DLAMBD, E, EMAX, EMIN, EPS, + $ HN, HNORM, HNORM1, PHI, PP, PROD, RAT, RCOND, + $ REGPAR, ROWSUM, SCALE, SNORM, STSIZE, SVLAM, + $ T1, T2, T3, TAU, TEMP, TOL, TOL2, TOL3, TOL4, + $ TOL5, YNORM1, YNORM2, ZNORM, ZNORM2 + LOGICAL GTEST, POS, XFACT +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions + DOUBLE PRECISION DDOT, DLAMCH, DLANGE, ZLANGE + LOGICAL LSAME, SELECT + EXTERNAL DDOT, DLAMCH, DLANGE, LSAME, SELECT, ZLANGE +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DLACPY, DLASET, DSCAL, DSYCON, + $ DSYSV, DSYTRF, DSYTRS, XERBLA, ZCOPY, ZGEES, + $ ZGEMM, ZGEMV, ZGESVD, ZGETRF, ZGETRI, ZLACPY, + $ ZLASCL +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DCMPLX, DCONJG, DFLOAT, DREAL, INT, LOG, + $ MAX, SQRT +C .. +C .. Executable Statements .. +C +C Compute workspace. +C + MINWRK = 2*N*N*M - N*N + 9*M*M + N*M + 11*N + 33*M - 11 + MINZRK = 6*N*N*M + 12*N*N + 6*M + 6*N - 3 +C +C Decode and Test input parameters. +C + INFO = 0 + XFACT = LSAME( FACT, 'F' ) + IF( .NOT.XFACT .AND. .NOT.LSAME( FACT, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( M.LT.1 ) THEN + INFO = -5 + ELSE IF( LDWORK.LT.MINWRK ) THEN + INFO = -14 + ELSE IF( LZWORK.LT.MINZRK ) THEN + INFO = -16 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'AB13MD', -INFO ) + RETURN + END IF +C + NSUM = 0 + ISUM = 0 + MR = 0 + DO 10 I = 1, M + IF( NBLOCK( I ).LT.1 ) THEN + INFO = 1 + RETURN + END IF + IF( ITYPE( I ).EQ.1 .AND. NBLOCK( I ).GT.1 ) THEN + INFO = 3 + RETURN + END IF + NSUM = NSUM + NBLOCK( I ) + IF( ITYPE( I ).EQ.1 ) MR = MR + 1 + IF( ITYPE( I ).EQ.1 .OR. ITYPE( I ).EQ.2 ) ISUM = ISUM + 1 + 10 CONTINUE + IF( NSUM.NE.N ) THEN + INFO = 2 + RETURN + END IF + IF( ISUM.NE.M ) THEN + INFO = 4 + RETURN + END IF + MT = M + MR - 1 +C + LWAMAX = 0 + LZAMAX = 0 +C +C Set D = In, G = 0. +C + CALL DLASET( 'Full', N, 1, ONE, ONE, D, N ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, G, N ) +C +C Quick return if possible. +C + ZNORM = ZLANGE( 'F', N, N, Z, LDZ, DWORK ) + IF( ZNORM.EQ.ZERO ) THEN + BOUND = ZERO + DWORK( 1 ) = ONE + ZWORK( 1 ) = CONE + RETURN + END IF +C +C Copy Z into ZWORK. +C + CALL ZLACPY( 'Full', N, N, Z, LDZ, ZWORK, N ) +C +C Exact bound for the case NBLOCK( 1 ) = N. +C + IF( NBLOCK( 1 ).EQ.N ) THEN + IF( ITYPE( 1 ).EQ.1 ) THEN +C +C 1-by-1 real block. +C + BOUND = ZERO + DWORK( 1 ) = ONE + ZWORK( 1 ) = CONE + ELSE +C +C N-by-N complex block. +C + CALL ZGESVD( 'N', 'N', N, N, ZWORK, N, DWORK, ZWORK, 1, + $ ZWORK, 1, ZWORK( N*N+1 ), LZWORK, + $ DWORK( N+1 ), INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + BOUND = DWORK( 1 ) + LZA = N*N + INT( ZWORK( N*N+1 ) ) + DWORK( 1 ) = 5*N + ZWORK( 1 ) = DCMPLX( LZA ) + END IF + RETURN + END IF +C +C Get machine precision. +C + EPS = DLAMCH( 'P' ) +C +C Set tolerances. +C + TOL = C7*SQRT( EPS ) + TOL2 = C9*EPS + TOL3 = C6*EPS + TOL4 = C1 + TOL5 = C1 + REGPAR = C8*EPS +C +C Real workspace usage. +C + IW2 = M*M + IW3 = IW2 + M + IW4 = IW3 + N + IW5 = IW4 + M + IW6 = IW5 + M + IW7 = IW6 + N + IW8 = IW7 + N + IW9 = IW8 + N*( M - 1 ) + IW10 = IW9 + N*N*MT + IW11 = IW10 + MT + IW12 = IW11 + MT*MT + IW13 = IW12 + N + IW14 = IW13 + MT + 1 + IW15 = IW14 + MT + 1 + IW16 = IW15 + MT + 1 + IW17 = IW16 + MT + 1 + IW18 = IW17 + MT + 1 + IW19 = IW18 + MT + IW20 = IW19 + MT + IW21 = IW20 + MT + IW22 = IW21 + N + IW23 = IW22 + M - 1 + IW24 = IW23 + MR + IW25 = IW24 + N + IW26 = IW25 + 2*MT + IW27 = IW26 + MT + IW28 = IW27 + MT + IW29 = IW28 + M - 1 + IW30 = IW29 + MR + IW31 = IW30 + N + 2*MT + IW32 = IW31 + MT*MT + IW33 = IW32 + MT + IWRK = IW33 + MT + 1 +C +C Double complex workspace usage. +C + IZ2 = N*N + IZ3 = IZ2 + N*N + IZ4 = IZ3 + N*N + IZ5 = IZ4 + N*N + IZ6 = IZ5 + N*N + IZ7 = IZ6 + N*N*MT + IZ8 = IZ7 + N*N + IZ9 = IZ8 + N*N + IZ10 = IZ9 + N*N + IZ11 = IZ10 + MT + IZ12 = IZ11 + N*N + IZ13 = IZ12 + N + IZ14 = IZ13 + N*N + IZ15 = IZ14 + N + IZ16 = IZ15 + N*N + IZ17 = IZ16 + N + IZ18 = IZ17 + N*N + IZ19 = IZ18 + N*N*MT + IZ20 = IZ19 + MT + IZ21 = IZ20 + N*N*MT + IZ22 = IZ21 + N*N + IZ23 = IZ22 + N*N + IZ24 = IZ23 + N*N + IZWRK = IZ24 + MT +C +C Compute the cumulative sums of blocks dimensions. +C + IWORK( 1 ) = 0 + DO 20 I = 2, M+1 + IWORK( I ) = IWORK( I - 1 ) + NBLOCK( I - 1 ) + 20 CONTINUE +C +C Find Osborne scaling if initial scaling is not given. +C + IF( .NOT.XFACT ) THEN + CALL DLASET( 'Full', M, M, ZERO, ZERO, DWORK, M ) + CALL DLASET( 'Full', M, 1, ONE, ONE, DWORK( IW2+1 ), M ) + ZNORM = ZLANGE( 'F', N, N, ZWORK, N, DWORK ) + DO 40 J = 1, M + DO 30 I = 1, M + IF( I.NE.J ) THEN + CALL ZLACPY( 'Full', IWORK( I+1 )-IWORK( I ), + $ IWORK( J+1 )-IWORK( J ), + $ Z( IWORK( I )+1, IWORK( J )+1 ), LDZ, + $ ZWORK( IZ2+1 ), N ) + CALL ZGESVD( 'N', 'N', IWORK( I+1 )-IWORK( I ), + $ IWORK( J+1 )-IWORK( J ), ZWORK( IZ2+1 ), + $ N, DWORK( IW3+1 ), ZWORK, 1, ZWORK, 1, + $ ZWORK( IZWRK+1 ), LZWORK-IZWRK, + $ DWORK( IWRK+1 ), INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + ZNORM2 = DWORK( IW3+1 ) + DWORK( I+(J-1)*M ) = ZNORM2 + ZNORM*TOL2 + END IF + 30 CONTINUE + 40 CONTINUE + CALL DLASET( 'Full', M, 1, ZERO, ZERO, DWORK( IW4+1 ), M ) + 50 DO 60 I = 1, M + DWORK( IW5+I ) = DWORK( IW4+I ) - ONE + 60 CONTINUE + HNORM = DLANGE( 'F', M, 1, DWORK( IW5+1 ), M, DWORK ) + IF( HNORM.LE.TOL2 ) GO TO 120 + DO 110 K = 1, M + COLSUM = ZERO + DO 70 I = 1, M + COLSUM = COLSUM + DWORK( I+(K-1)*M ) + 70 CONTINUE + ROWSUM = ZERO + DO 80 J = 1, M + ROWSUM = ROWSUM + DWORK( K+(J-1)*M ) + 80 CONTINUE + RAT = SQRT( COLSUM / ROWSUM ) + DWORK( IW4+K ) = RAT + DO 90 I = 1, M + DWORK( I+(K-1)*M ) = DWORK( I+(K-1)*M ) / RAT + 90 CONTINUE + DO 100 J = 1, M + DWORK( K+(J-1)*M ) = DWORK( K+(J-1)*M )*RAT + 100 CONTINUE + DWORK( IW2+K ) = DWORK( IW2+K )*RAT + 110 CONTINUE + GO TO 50 + 120 SCALE = ONE / DWORK( IW2+1 ) + CALL DSCAL( M, SCALE, DWORK( IW2+1 ), 1 ) + ELSE + DWORK( IW2+1 ) = ONE + DO 130 I = 2, M + DWORK( IW2+I ) = SQRT( X( I-1 ) ) + 130 CONTINUE + END IF + DO 150 J = 1, M + DO 140 I = 1, M + IF( I.NE.J ) THEN + CALL ZLASCL( 'G', M, M, DWORK( IW2+J ), DWORK( IW2+I ), + $ IWORK( I+1 )-IWORK( I ), + $ IWORK( J+1 )-IWORK( J ), + $ ZWORK( IWORK( I )+1+IWORK( J )*N ), N, + $ INFO2 ) + END IF + 140 CONTINUE + 150 CONTINUE +C +C Scale Z by its 2-norm. +C + CALL ZLACPY( 'Full', N, N, ZWORK, N, ZWORK( IZ2+1 ), N ) + CALL ZGESVD( 'N', 'N', N, N, ZWORK( IZ2+1 ), N, DWORK( IW3+1 ), + $ ZWORK, 1, ZWORK, 1, ZWORK( IZWRK+1 ), LZWORK-IZWRK, + $ DWORK( IWRK+1 ), INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + ZNORM = DWORK( IW3+1 ) + CALL ZLASCL( 'G', M, M, ZNORM, ONE, N, N, ZWORK, N, INFO2 ) +C +C Set BB. +C + CALL DLASET( 'Full', N*N, MT, ZERO, ZERO, DWORK( IW9+1 ), N*N ) +C +C Set P. +C + DO 160 I = 1, NBLOCK( 1 ) + DWORK( IW6+I ) = ONE + 160 CONTINUE + DO 170 I = NBLOCK( 1 )+1, N + DWORK( IW6+I ) = ZERO + 170 CONTINUE +C +C Compute P*Z. +C + DO 190 J = 1, N + DO 180 I = 1, N + ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* + $ ZWORK( I+(J-1)*N ) + 180 CONTINUE + 190 CONTINUE +C +C Compute Z'*P*Z. +C + CALL ZGEMM( 'C', 'N', N, N, N, CONE, ZWORK, N, ZWORK( IZ3+1 ), N, + $ CZERO, ZWORK( IZ4+1 ), N ) +C +C Copy Z'*P*Z into A0. +C + CALL ZLACPY( 'Full', N, N, ZWORK( IZ4+1 ), N, ZWORK( IZ5+1 ), N ) +C +C Copy diag(P) into B0d. +C + CALL DCOPY( N, DWORK( IW6+1 ), 1, DWORK( IW7+1 ), 1 ) +C + DO 270 K = 2, M +C +C Set P. +C + DO 200 I = 1, IWORK( K ) + DWORK( IW6+I ) = ZERO + 200 CONTINUE + DO 210 I = IWORK( K )+1, IWORK( K )+NBLOCK( K ) + DWORK( IW6+I ) = ONE + 210 CONTINUE + IF( K.LT.M ) THEN + DO 220 I = IWORK( K+1 )+1, N + DWORK( IW6+I ) = ZERO + 220 CONTINUE + END IF +C +C Compute P*Z. +C + DO 240 J = 1, N + DO 230 I = 1, N + ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* + $ ZWORK( I+(J-1)*N ) + 230 CONTINUE + 240 CONTINUE +C +C Compute t = Z'*P*Z. +C + CALL ZGEMM( 'C', 'N', N, N, N, CONE, ZWORK, N, ZWORK( IZ3+1 ), + $ N, CZERO, ZWORK( IZ4+1 ), N ) +C +C Copy t(:) into the (k-1)-th column of AA. +C + CALL ZCOPY( N*N, ZWORK( IZ4+1 ), 1, ZWORK( IZ6+1+(K-2)*N*N ), + $ 1 ) +C +C Copy diag(P) into the (k-1)-th column of BBd. +C + CALL DCOPY( N, DWORK( IW6+1 ), 1, DWORK( IW8+1+(K-2)*N ), 1 ) +C +C Copy P(:) into the (k-1)-th column of BB. +C + DO 260 I = 1, N + DWORK( IW9+I+(I-1)*N+(K-2)*N*N ) = DWORK( IW6+I ) + 260 CONTINUE + 270 CONTINUE +C + L = 0 +C + DO 350 K = 1, M + IF( ITYPE( K ).EQ.1 ) THEN + L = L + 1 +C +C Set P. +C + DO 280 I = 1, IWORK( K ) + DWORK( IW6+I ) = ZERO + 280 CONTINUE + DO 290 I = IWORK( K )+1, IWORK( K )+NBLOCK( K ) + DWORK( IW6+I ) = ONE + 290 CONTINUE + IF( K.LT.M ) THEN + DO 300 I = IWORK( K+1 )+1, N + DWORK( IW6+I ) = ZERO + 300 CONTINUE + END IF +C +C Compute P*Z. +C + DO 320 J = 1, N + DO 310 I = 1, N + ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* + $ ZWORK( I+(J-1)*N ) + 310 CONTINUE + 320 CONTINUE +C +C Compute t = sqrt(-1)*( P*Z - Z'*P ). +C + DO 340 J = 1, N + DO 330 I = 1, J + TEMPIJ = ZWORK( IZ3+I+(J-1)*N ) + TEMPJI = ZWORK( IZ3+J+(I-1)*N ) + ZWORK( IZ4+I+(J-1)*N ) = CIMAG*( TEMPIJ - + $ DCONJG( TEMPJI ) ) + ZWORK( IZ4+J+(I-1)*N ) = CIMAG*( TEMPJI - + $ DCONJG( TEMPIJ ) ) + 330 CONTINUE + 340 CONTINUE +C +C Copy t(:) into the (m-1+l)-th column of AA. +C + CALL ZCOPY( N*N, ZWORK( IZ4+1 ), 1, + $ ZWORK( IZ6+1+(M-2+L)*N*N ), 1 ) + END IF + 350 CONTINUE +C +C Set initial X. +C + DO 360 I = 1, M - 1 + X( I ) = ONE + 360 CONTINUE + IF( MR.GT.0 ) THEN + IF( .NOT.XFACT ) THEN + DO 370 I = 1, MR + X( M-1+I ) = ZERO + 370 CONTINUE + ELSE + L = 0 + DO 380 K = 1, M + IF( ITYPE( K ).EQ.1 ) THEN + L = L + 1 + X( M-1+L ) = X( M-1+L ) / DWORK( IW2+K )**2 + END IF + 380 CONTINUE + END IF + END IF +C +C Set constants. +C + SVLAM = ONE / EPS + C = ONE +C +C Set H. +C + CALL DLASET( 'Full', MT, MT, ZERO, ONE, DWORK( IW11+1 ), MT ) +C + ITER = -1 +C +C Main iteration loop. +C + 390 ITER = ITER + 1 +C +C Compute A(:) = A0 + AA*x. +C + DO 400 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( X( I ) ) + 400 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute diag( Binv ). +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW12+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, X, 1, ONE, + $ DWORK( IW12+1 ), 1 ) + DO 410 I = 1, N + DWORK( IW12+I ) = ONE / DWORK( IW12+I ) + 410 CONTINUE +C +C Compute Binv*A. +C + DO 430 J = 1, N + DO 420 I = 1, N + ZWORK( IZ11+I+(J-1)*N ) = DCMPLX( DWORK( IW12+I ) )* + $ ZWORK( IZ7+I+(J-1)*N ) + 420 CONTINUE + 430 CONTINUE +C +C Compute eig( Binv*A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ11+1 ), N, SDIM, + $ ZWORK( IZ12+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + E = DREAL( ZWORK( IZ12+1 ) ) + IF( N.GT.1 ) THEN + DO 440 I = 2, N + IF( DREAL( ZWORK( IZ12+I ) ).GT.E ) + $ E = DREAL( ZWORK( IZ12+I ) ) + 440 CONTINUE + END IF +C +C Set tau. +C + IF( MR.GT.0 ) THEN + SNORM = ABS( X( M ) ) + IF( MR.GT.1 ) THEN + DO 450 I = M+1, MT + IF( ABS( X( I ) ).GT.SNORM ) SNORM = ABS( X( I ) ) + 450 CONTINUE + END IF + IF( SNORM.GT.FORTY ) THEN + TAU = C7 + ELSE IF( SNORM.GT.EIGHT ) THEN + TAU = FIFTY + ELSE IF( SNORM.GT.FOUR ) THEN + TAU = TEN + ELSE IF( SNORM.GT.ONE ) THEN + TAU = FIVE + ELSE + TAU = TWO + END IF + END IF + IF( ITER.EQ.0 ) THEN + DLAMBD = E + C1 + ELSE + DWORK( IW13+1 ) = E + CALL DCOPY( MT, X, 1, DWORK( IW13+2 ), 1 ) + DLAMBD = ( ONE - THETA )*DWORK( IW13+1 ) + + $ THETA*DWORK( IW14+1 ) + CALL DCOPY( MT, DWORK( IW13+2 ), 1, DWORK( IW18+1 ), 1 ) + CALL DCOPY( MT, DWORK( IW14+2 ), 1, DWORK( IW19+1 ), 1 ) + L = 0 + 460 DO 470 I = 1, MT + X( I ) = ( ONE - THETA / TWO**L )*DWORK( IW18+I ) + + $ ( THETA / TWO**L )*DWORK( IW19+I ) + 470 CONTINUE +C +C Compute At(:) = A0 + AA*x. +C + DO 480 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( X( I ) ) + 480 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ9+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ9+1 ), 1 ) +C +C Compute diag(Bt). +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW21+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, X, 1, ONE, + $ DWORK( IW21+1 ), 1 ) +C +C Compute W. +C + DO 500 J = 1, N + DO 490 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ13+I+(I-1)*N ) = DCMPLX( THETA*BETA* + $ ( DWORK( IW14+1 ) - DWORK( IW13+1 ) ) /TWO - + $ DLAMBD*DWORK( IW21+I ) ) + + $ ZWORK( IZ9+I+(I-1)*N ) + ELSE + ZWORK( IZ13+I+(J-1)*N ) = ZWORK( IZ9+I+(J-1)*N ) + END IF + 490 CONTINUE + 500 CONTINUE +C +C Compute eig( W ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ13+1 ), N, SDIM, + $ ZWORK( IZ14+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + EMAX = DREAL( ZWORK( IZ14+1 ) ) + IF( N.GT.1 ) THEN + DO 510 I = 2, N + IF( DREAL( ZWORK( IZ14+I ) ).GT.EMAX ) + $ EMAX = DREAL( ZWORK( IZ14+I ) ) + 510 CONTINUE + END IF + IF( EMAX.LE.ZERO ) THEN + GO TO 515 + ELSE + L = L + 1 + GO TO 460 + END IF + END IF +C +C Set y. +C + 515 DWORK( IW13+1 ) = DLAMBD + CALL DCOPY( MT, X, 1, DWORK( IW13+2 ), 1 ) +C + IF( ( SVLAM - DLAMBD ).LT.TOL ) THEN + BOUND = SQRT( MAX( E, ZERO ) )*ZNORM + DO 520 I = 1, M - 1 + X( I ) = X( I )*DWORK( IW2+I+1 )**2 + 520 CONTINUE +C +C Compute sqrt( x ). +C + DO 530 I = 1, M-1 + DWORK( IW20+I ) = SQRT( X( I ) ) + 530 CONTINUE +C +C Compute diag( D ). +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, D, 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW20+1 ), 1, ONE, D, 1 ) +C +C Compute diag( G ). +C + J = 0 + L = 0 + DO 540 K = 1, M + J = J + NBLOCK( K ) + IF( ITYPE( K ).EQ.1 ) THEN + L = L + 1 + X( M-1+L ) = X( M-1+L )*DWORK( IW2+K )**2 + G( J ) = X( M-1+L ) + END IF + 540 CONTINUE + CALL DSCAL( N, ZNORM, G, 1 ) + DWORK( 1 ) = DFLOAT( MINWRK - 5*N + LWAMAX ) + ZWORK( 1 ) = DCMPLX( MINZRK - 3*N + LZAMAX ) + RETURN + END IF + SVLAM = DLAMBD + DO 800 K = 1, M +C +C Store xD. +C + CALL DCOPY( M-1, X, 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, X( M ), 1, DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*x. +C + DO 550 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( X( I ) ) + 550 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute B = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute F. +C + DO 556 J = 1, N + DO 555 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 555 CONTINUE + 556 CONTINUE + CALL ZLACPY( 'Full', N, N, ZWORK( IZ15+1 ), N, + $ ZWORK( IZ17+1 ), N ) +C +C Compute det( F ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + DETF = CONE + DO 560 I = 1, N + DETF = DETF*ZWORK( IZ16+I ) + 560 CONTINUE +C +C Compute Finv. +C + CALL ZGETRF( N, N, ZWORK( IZ17+1 ), N, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL ZGETRI( N, ZWORK( IZ17+1 ), N, IWORK, ZWORK( IZWRK+1 ), + $ LDWORK-IWRK, INFO2 ) + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) +C +C Compute phi. +C + DO 570 I = 1, M-1 + DWORK( IW25+I ) = DWORK( IW22+I ) - BETA + DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) + 570 CONTINUE + IF( MR.GT.0 ) THEN + DO 580 I = 1, MR + DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 580 CONTINUE + END IF + PROD = ONE + DO 590 I = 1, 2*MT + PROD = PROD*DWORK( IW25+I ) + 590 CONTINUE + TEMP = DREAL( DETF ) + IF( TEMP.LT.EPS ) TEMP = EPS + PHI = -LOG( TEMP ) - LOG( PROD ) +C +C Compute g. +C + DO 610 J = 1, MT + DO 600 I = 1, N*N + ZWORK( IZ18+I+(J-1)*N*N ) = DCMPLX( DLAMBD* + $ DWORK( IW9+I+(J-1)*N*N ) ) - ZWORK( IZ6+I+(J-1)*N*N ) + 600 CONTINUE + 610 CONTINUE + CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ18+1 ), N*N, + $ ZWORK( IZ17+1 ), 1, CZERO, ZWORK( IZ19+1 ), 1 ) + DO 620 I = 1, M-1 + DWORK( IW26+I ) = ONE / ( DWORK( IW22+I ) - BETA ) - + $ ONE / ( ALPHA - DWORK( IW22+I ) ) + 620 CONTINUE + IF( MR.GT.0 ) THEN + DO 630 I = 1, MR + DWORK( IW26+M-1+I ) = ONE / ( DWORK( IW23+I ) + TAU ) + $ -ONE / ( TAU - DWORK( IW23+I ) ) + 630 CONTINUE + END IF + DO 640 I = 1, MT + DWORK( IW26+I ) = -DREAL( ZWORK( IZ19+I ) ) - + $ DWORK( IW26+I ) + 640 CONTINUE +C +C Compute h. +C + CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, + $ DWORK( IW31+1 ), MT ) + CALL DCOPY( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) + CALL DSYSV( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, + $ DWORK( IW27+1 ), MT, DWORK( IWRK+1 ), + $ LDWORK-IWRK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) + STSIZE = ONE +C +C Store hD. +C + CALL DCOPY( M-1, DWORK( IW27+1 ), 1, DWORK( IW28+1 ), 1 ) +C +C Determine stepsize. +C + L = 0 + DO 650 I = 1, M-1 + IF( DWORK( IW28+I ).GT.ZERO ) THEN + L = L + 1 + IF( L.EQ.1 ) THEN + TEMP = ( DWORK( IW22+I ) - BETA ) / DWORK( IW28+I ) + ELSE + TEMP = MIN( TEMP, ( DWORK( IW22+I ) - BETA ) / + $ DWORK( IW28+I ) ) + END IF + END IF + 650 CONTINUE + IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) + L = 0 + DO 660 I = 1, M-1 + IF( DWORK( IW28+I ).LT.ZERO ) THEN + L = L + 1 + IF( L.EQ.1 ) THEN + TEMP = ( ALPHA - DWORK( IW22+I ) ) / + $ ( -DWORK( IW28+I ) ) + ELSE + TEMP = MIN( TEMP, ( ALPHA - DWORK( IW22+I ) ) / + $ ( -DWORK( IW28+I ) ) ) + END IF + END IF + 660 CONTINUE + IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) + IF( MR.GT.0 ) THEN +C +C Store hG. +C + CALL DCOPY( MR, DWORK( IW27+M ), 1, DWORK( IW29+1 ), 1 ) +C +C Determine stepsize. +C + L = 0 + DO 670 I = 1, MR + IF( DWORK( IW29+I ).GT.ZERO ) THEN + L = L + 1 + IF( L.EQ.1 ) THEN + TEMP = ( DWORK( IW23+I ) + TAU ) / + $ DWORK( IW29+I ) + ELSE + TEMP = MIN( TEMP, ( DWORK( IW23+I ) + TAU ) / + $ DWORK( IW29+I ) ) + END IF + END IF + 670 CONTINUE + IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) + L = 0 + DO 680 I = 1, MR + IF( DWORK( IW29+I ).LT.ZERO ) THEN + L = L + 1 + IF( L.EQ.1 ) THEN + TEMP = ( TAU - DWORK( IW23+I ) ) / + $ ( -DWORK( IW29+I ) ) + ELSE + TEMP = MIN( TEMP, ( TAU - DWORK( IW23+I ) ) / + $ ( -DWORK( IW29+I ) ) ) + END IF + END IF + 680 CONTINUE + END IF + IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) + STSIZE = C4*STSIZE + IF( STSIZE.GE.TOL4 ) THEN +C +C Compute x_new. +C + DO 700 I = 1, MT + DWORK( IW20+I ) = X( I ) - STSIZE*DWORK( IW27+I ) + 700 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, DWORK( IW20+1 ), 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, DWORK( IW20+M ), 1, DWORK( IW23+1 ), + $ 1 ) + END IF +C +C Compute A(:) = A0 + AA*x_new. +C + DO 710 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( DWORK( IW20+I ) ) + 710 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute B = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute lambda*diag(B) - A. +C + DO 730 J = 1, N + DO 720 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = + $ -ZWORK( IZ7+I+(J-1)*N ) + END IF + 720 CONTINUE + 730 CONTINUE +C +C Compute eig( lambda*diag(B)-A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, + $ SDIM, ZWORK( IZ16+1 ), ZWORK, N, + $ ZWORK( IZWRK+1 ), LZWORK-IZWRK, + $ DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + EMIN = DREAL( ZWORK( IZ16+1 ) ) + IF( N.GT.1 ) THEN + DO 740 I = 2, N + IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) + $ EMIN = DREAL( ZWORK( IZ16+I ) ) + 740 CONTINUE + END IF + DO 750 I = 1, N + DWORK( IW30+I ) = DREAL( ZWORK( IZ16+I ) ) + 750 CONTINUE + DO 760 I = 1, M-1 + DWORK( IW30+N+I ) = DWORK( IW22+I ) - BETA + DWORK( IW30+N+M-1+I ) = ALPHA - DWORK( IW22+I ) + 760 CONTINUE + IF( MR.GT.0 ) THEN + DO 770 I = 1, MR + DWORK( IW30+N+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW30+N+2*(M-1)+MR+I ) = TAU - + $ DWORK( IW23+I ) + 770 CONTINUE + END IF + PROD = ONE + DO 780 I = 1, N+2*MT + PROD = PROD*DWORK( IW30+I ) + 780 CONTINUE + IF( EMIN.LE.ZERO .OR. ( -LOG( PROD ) ).GE.PHI ) THEN + STSIZE = STSIZE / TEN + ELSE + CALL DCOPY( MT, DWORK( IW20+1 ), 1, X, 1 ) + END IF + END IF + IF( STSIZE.LT.TOL4 ) GO TO 810 + 800 CONTINUE +C + 810 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, X, 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, X( M ), 1, DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*x. +C + DO 820 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( X( I ) ) + 820 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute diag( B ) = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute F. +C + DO 840 J = 1, N + DO 830 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 830 CONTINUE + 840 CONTINUE + CALL ZLACPY( 'Full', N, N, ZWORK( IZ15+1 ), N, + $ ZWORK( IZ17+1 ), N ) +C +C Compute det( F ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + DETF = CONE + DO 850 I = 1, N + DETF = DETF*ZWORK( IZ16+I ) + 850 CONTINUE +C +C Compute Finv. +C + CALL ZGETRF( N, N, ZWORK( IZ17+1 ), N, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL ZGETRI( N, ZWORK( IZ17+1 ), N, IWORK, ZWORK( IZWRK+1 ), + $ LDWORK-IWRK, INFO2 ) + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) +C +C Compute the barrier function. +C + DO 860 I = 1, M-1 + DWORK( IW25+I ) = DWORK( IW22+I ) - BETA + DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) + 860 CONTINUE + IF( MR.GT.0 ) THEN + DO 870 I = 1, MR + DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 870 CONTINUE + END IF + PROD = ONE + DO 880 I = 1, 2*MT + PROD = PROD*DWORK( IW25+I ) + 880 CONTINUE + TEMP = DREAL( DETF ) + IF( TEMP.LT.EPS ) TEMP = EPS + PHI = -LOG( TEMP ) - LOG( PROD ) +C +C Compute the gradient of the barrier function. +C + DO 900 J = 1, MT + DO 890 I = 1, N*N + ZWORK( IZ18+I+(J-1)*N*N ) = DCMPLX( DLAMBD* + $ DWORK( IW9+I+(J-1)*N*N ) ) - ZWORK( IZ6+I+(J-1)*N*N ) + 890 CONTINUE + 900 CONTINUE + CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ18+1 ), N*N, + $ ZWORK( IZ17+1 ), 1, CZERO, ZWORK( IZ19+1 ), 1 ) + DO 910 I = 1, M-1 + DWORK( IW26+I ) = ONE / ( DWORK( IW22+I ) - BETA ) - + $ ONE / ( ALPHA - DWORK( IW22+I ) ) + 910 CONTINUE + IF( MR.GT.0 ) THEN + DO 920 I = 1, MR + DWORK( IW26+M-1+I ) = ONE / ( DWORK( IW23+I ) + TAU ) + $ -ONE / ( TAU - DWORK( IW23+I ) ) + 920 CONTINUE + END IF + DO 925 I = 1, MT + DWORK( IW26+I ) = -DREAL( ZWORK( IZ19+I ) ) - + $ DWORK( IW26+I ) + 925 CONTINUE +C +C Compute the Hessian of the barrier function. +C + CALL ZGEMM( 'N', 'N', N, N*MT, N, CONE, ZWORK( IZ17+1 ), N, + $ ZWORK( IZ18+1 ), N, CZERO, ZWORK( IZ20+1 ), N ) + + CALL DLASET( 'Full', MT, MT, ZERO, ZERO, DWORK( IW11+1 ), + $ MT ) + DO 960 K = 1, MT + CALL ZCOPY( N*N, ZWORK( IZ20+1+(K-1)*N*N ), 1, + $ ZWORK( IZ22+1 ), 1 ) + DO 940 J = 1, N + DO 930 I = 1, N + ZWORK( IZ23+I+(J-1)*N ) = + $ DCONJG( ZWORK( IZ22+J+(I-1)*N ) ) + 930 CONTINUE + 940 CONTINUE + CALL ZGEMV( 'C', N*N, K, CONE, ZWORK( IZ20+1 ), N*N, + $ ZWORK( IZ23+1 ), 1, CZERO, ZWORK( IZ24+1 ), + $ 1 ) + DO 950 J = 1, K + DWORK( IW11+K+(J-1)*MT ) = + $ DREAL( DCONJG( ZWORK( IZ24+J ) ) ) + 950 CONTINUE + 960 CONTINUE + DO 970 I = 1, M-1 + DWORK( IW10+I ) = ONE / ( DWORK( IW22+I ) - BETA )**2 + + $ ONE / ( ALPHA - DWORK( IW22+I ) )**2 + 970 CONTINUE + IF( MR.GT.0 ) THEN + DO 980 I = 1, MR + DWORK( IW10+M-1+I ) = + $ ONE / ( DWORK( IW23+I ) + TAU )**2 + + $ ONE / ( TAU - DWORK( IW23+I ) )**2 + 980 CONTINUE + END IF + DO 990 I = 1, MT + DWORK( IW11+I+(I-1)*MT ) = DWORK( IW11+I+(I-1)*MT ) + + $ DWORK( IW10+I ) + 990 CONTINUE + DO 1100 J = 1, MT + DO 1000 I = 1, J + IF( I.NE.J ) THEN + T1 = DWORK( IW11+I+(J-1)*MT ) + T2 = DWORK( IW11+J+(I-1)*MT ) + DWORK( IW11+I+(J-1)*MT ) = T1 + T2 + DWORK( IW11+J+(I-1)*MT ) = T1 + T2 + END IF + 1000 CONTINUE + 1100 CONTINUE +C +C Compute norm( H ). +C + 1110 HNORM = DLANGE( 'F', MT, MT, DWORK( IW11+1 ), MT, DWORK ) +C +C Compute rcond( H ). +C + CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, + $ DWORK( IW31+1 ), MT ) + HNORM1 = DLANGE( '1', MT, MT, DWORK( IW31+1 ), MT, DWORK ) + CALL DSYTRF( 'U', MT, DWORK( IW31+1 ), MT, IWORK, + $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) + CALL DSYCON( 'U', MT, DWORK( IW31+1 ), MT, IWORK, HNORM1, + $ RCOND, DWORK( IWRK+1 ), IWORK( MT+1 ), INFO2 ) + IF( RCOND.LT.TOL3 ) THEN + DO 1120 I = 1, MT + DWORK( IW11+I+(I-1)*MT ) = DWORK( IW11+I+(I-1)*MT ) + + $ HNORM*REGPAR + 1120 CONTINUE + GO TO 1110 + END IF +C +C Compute the tangent line to path of center. +C + CALL DCOPY( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) + CALL DSYTRS( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, + $ DWORK( IW27+1 ), MT, INFO2 ) +C +C Check if x-h satisfies the Goldstein test. +C + GTEST = .FALSE. + DO 1130 I = 1, MT + DWORK( IW20+I ) = X( I ) - DWORK( IW27+I ) + 1130 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, DWORK( IW20+1 ), 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, DWORK( IW20+M ), 1, DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*x_new. +C + DO 1140 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( DWORK( IW20+I ) ) + 1140 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute diag( B ) = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute lambda*diag(B) - A. +C + DO 1160 J = 1, N + DO 1150 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 1150 CONTINUE + 1160 CONTINUE +C +C Compute eig( lambda*diag(B)-A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + DO 1190 I = 1, N + DWORK( IW30+I ) = DREAL( ZWORK( IZ16+I ) ) + 1190 CONTINUE + DO 1200 I = 1, M-1 + DWORK( IW30+N+I ) = DWORK( IW22+I ) - BETA + DWORK( IW30+N+M-1+I ) = ALPHA - DWORK( IW22+I ) + 1200 CONTINUE + IF( MR.GT.0 ) THEN + DO 1210 I = 1, MR + DWORK( IW30+N+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW30+N+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 1210 CONTINUE + END IF + EMIN = DWORK( IW30+1 ) + DO 1220 I = 1, N+2*MT + IF( DWORK( IW30+I ).LT.EMIN ) EMIN = DWORK( IW30+I ) + 1220 CONTINUE + IF( EMIN.LE.ZERO ) THEN + GTEST = .FALSE. + ELSE + PP = DDOT( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) + PROD = ONE + DO 1230 I = 1, N+2*MT + PROD = PROD*DWORK( IW30+I ) + 1230 CONTINUE + T1 = -LOG( PROD ) + T2 = PHI - C2*PP + T3 = PHI - C4*PP + IF( T1.GE.T3 .AND. T1.LT.T2 ) GTEST = .TRUE. + END IF +C +C Use x-h if Goldstein test is satisfied. Otherwise use +C Nesterov-Nemirovsky's stepsize length. +C + PP = DDOT( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) + DELTA = SQRT( PP ) + IF( GTEST .OR. DELTA.LE.C3 ) THEN + DO 1240 I = 1, MT + X( I ) = X( I ) - DWORK( IW27+I ) + 1240 CONTINUE + ELSE + DO 1250 I = 1, MT + X( I ) = X( I ) - DWORK( IW27+I ) / ( ONE + DELTA ) + 1250 CONTINUE + END IF +C +C Analytic center is found if delta is sufficiently small. +C + IF( DELTA.LT.TOL5 ) GO TO 1260 + GO TO 810 +C +C Set yf. +C + 1260 DWORK( IW14+1 ) = DLAMBD + CALL DCOPY( MT, X, 1, DWORK( IW14+2 ), 1 ) +C +C Set yw. +C + CALL DCOPY( MT+1, DWORK( IW14+1 ), 1, DWORK( IW15+1 ), 1 ) +C +C Compute Fb. +C + DO 1280 J = 1, N + DO 1270 I = 1, N + ZWORK( IZ21+I+(J-1)*N ) = DCMPLX( DWORK( IW24+I ) )* + $ DCONJG( ZWORK( IZ17+J+(I-1)*N ) ) + 1270 CONTINUE + 1280 CONTINUE + CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ20+1 ), N*N, + $ ZWORK( IZ21+1 ), 1, CZERO, ZWORK( IZ24+1 ), 1 ) + DO 1300 I = 1, MT + DWORK( IW32+I ) = DREAL( ZWORK( IZ24+I ) ) + 1300 CONTINUE +C +C Compute h1. +C + CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, + $ DWORK( IW31+1 ), MT ) + CALL DSYSV( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, + $ DWORK( IW32+1 ), MT, DWORK( IWRK+1 ), + $ LDWORK-IWRK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +C +C Compute hn. +C + HN = DLANGE( 'F', MT, 1, DWORK( IW32+1 ), MT, DWORK ) +C +C Compute y. +C + DWORK( IW13+1 ) = DLAMBD - C / HN + DO 1310 I = 1, MT + DWORK( IW13+1+I ) = X( I ) + C*DWORK( IW32+I ) / HN + 1310 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, DWORK( IW13+2 ), 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, DWORK( IW13+M+1 ), 1, DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*y(2:mt+1). +C + DO 1320 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( DWORK( IW13+1+I ) ) + 1320 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute B = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute y(1)*diag(B) - A. +C + DO 1340 J = 1, N + DO 1330 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW13+1 )* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 1330 CONTINUE + 1340 CONTINUE +C +C Compute eig( y(1)*diag(B)-A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + EMIN = DREAL( ZWORK( IZ16+1 ) ) + IF( N.GT.1 ) THEN + DO 1350 I = 2, N + IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) + $ EMIN = DREAL( ZWORK( IZ16+I ) ) + 1350 CONTINUE + END IF + POS = .TRUE. + DO 1360 I = 1, M-1 + DWORK( IW25+I ) = DWORK( IW22+I ) - BETA + DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) + 1360 CONTINUE + IF( MR.GT.0 ) THEN + DO 1370 I = 1, MR + DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 1370 CONTINUE + END IF + TEMP = DWORK( IW25+1 ) + DO 1380 I = 2, 2*MT + IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) + 1380 CONTINUE + IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. + 1390 IF( POS ) THEN +C +C Set y2 = y. +C + CALL DCOPY( MT+1, DWORK( IW13+1 ), 1, DWORK( IW17+1 ), 1 ) +C +C Compute y = y + 1.5*( y - yw ). +C + DO 1400 I = 1, MT+1 + DWORK( IW13+I ) = DWORK( IW13+I ) + + $ C5*( DWORK( IW13+I ) - DWORK( IW15+I ) ) + 1400 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, DWORK( IW13+2 ), 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, DWORK( IW13+M+1 ), 1, + $ DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*y(2:mt+1). +C + DO 1420 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( DWORK( IW13+1+I ) ) + 1420 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute diag( B ) = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Set yw = y2. +C + CALL DCOPY( MT+1, DWORK( IW17+1 ), 1, DWORK( IW15+1 ), 1 ) +C +C Compute y(1)*diag(B) - A. +C + DO 1440 J = 1, N + DO 1430 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW13+1 )* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 1430 CONTINUE + 1440 CONTINUE +C +C Compute eig( y(1)*diag(B)-A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + EMIN = DREAL( ZWORK( IZ16+1 ) ) + IF( N.GT.1 ) THEN + DO 1450 I = 2, N + IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) + $ EMIN = DREAL( ZWORK( IZ16+I ) ) + 1450 CONTINUE + END IF + POS = .TRUE. + DO 1460 I = 1, M-1 + DWORK( IW25+I ) = DWORK( IW22+I ) - BETA + DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) + 1460 CONTINUE + IF( MR.GT.0 ) THEN + DO 1470 I = 1, MR + DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 1470 CONTINUE + END IF + TEMP = DWORK( IW25+1 ) + DO 1480 I = 2, 2*MT + IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) + 1480 CONTINUE + IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. + GO TO 1390 + END IF + 1490 CONTINUE +C +C Set y1 = ( y + yw ) / 2. +C + DO 1500 I = 1, MT+1 + DWORK( IW16+I ) = ( DWORK( IW13+I ) + DWORK( IW15+I ) ) + $ / TWO + 1500 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, DWORK( IW16+2 ), 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, DWORK( IW16+M+1 ), 1, DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*y1(2:mt+1). +C + DO 1510 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( DWORK( IW16+1+I ) ) + 1510 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute diag( B ) = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute y1(1)*diag(B) - A. +C + DO 1530 J = 1, N + DO 1520 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW16+1 )* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 1520 CONTINUE + 1530 CONTINUE +C +C Compute eig( y1(1)*diag(B)-A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + EMIN = DREAL( ZWORK( IZ16+1 ) ) + IF( N.GT.1 ) THEN + DO 1540 I = 2, N + IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) + $ EMIN = DREAL( ZWORK( IZ16+I ) ) + 1540 CONTINUE + END IF + POS = .TRUE. + DO 1550 I = 1, M-1 + DWORK( IW25+I ) = DWORK( IW22+I ) - BETA + DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) + 1550 CONTINUE + IF( MR.GT.0 ) THEN + DO 1560 I = 1, MR + DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 1560 CONTINUE + END IF + TEMP = DWORK( IW25+1 ) + DO 1570 I = 2, 2*MT + IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) + 1570 CONTINUE + IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. + IF( POS ) THEN +C +C Set yw = y1. +C + CALL DCOPY( MT+1, DWORK( IW16+1 ), 1, DWORK( IW15+1 ), 1 ) + ELSE +C +C Set y = y1. +C + CALL DCOPY( MT+1, DWORK( IW16+1 ), 1, DWORK( IW13+1 ), 1 ) + END IF + DO 1580 I = 1, MT+1 + DWORK( IW33+I ) = DWORK( IW13+I ) - DWORK( IW15+I ) + 1580 CONTINUE + YNORM1 = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) + DO 1590 I = 1, MT+1 + DWORK( IW33+I ) = DWORK( IW13+I ) - DWORK( IW14+I ) + 1590 CONTINUE + YNORM2 = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) + IF( YNORM1.LT.YNORM2*THETA ) GO TO 1600 + GO TO 1490 +C +C Compute c. +C + 1600 DO 1610 I = 1, MT+1 + DWORK( IW33+I ) = DWORK( IW15+I ) - DWORK( IW14+I ) + 1610 CONTINUE + C = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) +C +C Set x = yw(2:mt+1). +C + CALL DCOPY( MT, DWORK( IW15+2 ), 1, X, 1 ) + GO TO 390 +C +C *** Last line of AB13MD *** + END diff --git a/mex/sources/libslicot/AB8NXZ.f b/mex/sources/libslicot/AB8NXZ.f new file mode 100644 index 000000000..9ec0da563 --- /dev/null +++ b/mex/sources/libslicot/AB8NXZ.f @@ -0,0 +1,456 @@ + SUBROUTINE AB8NXZ( N, M, P, RO, SIGMA, SVLMAX, ABCD, LDABCD, + $ NINFZ, INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, + $ DWORK, ZWORK, LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To extract from the (N+P)-by-(M+N) system +C ( B A ) +C ( D C ) +C an (NU+MU)-by-(M+NU) "reduced" system +C ( B' A') +C ( D' C') +C having the same transmission zeros but with D' of full row rank. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of state variables. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C RO (input/output) INTEGER +C On entry, +C = P for the original system; +C = MAX(P-M, 0) for the pertransposed system. +C On exit, RO contains the last computed rank. +C +C SIGMA (input/output) INTEGER +C On entry, +C = 0 for the original system; +C = M for the pertransposed system. +C On exit, SIGMA contains the last computed value sigma in +C the algorithm. +C +C SVLMAX (input) DOUBLE PRECISION +C During each reduction step, the rank-revealing QR +C factorization of a matrix stops when the estimated minimum +C singular value is smaller than TOL * MAX(SVLMAX,EMSV), +C where EMSV is the estimated maximum singular value. +C SVLMAX >= 0. +C +C ABCD (input/output) COMPLEX*16 array, dimension (LDABCD,M+N) +C On entry, the leading (N+P)-by-(M+N) part of this array +C must contain the compound input matrix of the system. +C On exit, the leading (NU+MU)-by-(M+NU) part of this array +C contains the reduced compound input matrix of the system. +C +C LDABCD INTEGER +C The leading dimension of array ABCD. +C LDABCD >= MAX(1,N+P). +C +C NINFZ (input/output) INTEGER +C On entry, the currently computed number of infinite zeros. +C It should be initialized to zero on the first call. +C NINFZ >= 0. +C On exit, the number of infinite zeros. +C +C INFZ (input/output) INTEGER array, dimension (N) +C On entry, INFZ(i) must contain the current number of +C infinite zeros of degree i, where i = 1,2,...,N, found in +C the previous call(s) of the routine. It should be +C initialized to zero on the first call. +C On exit, INFZ(i) contains the number of infinite zeros of +C degree i, where i = 1,2,...,N. +C +C KRONL (input/output) INTEGER array, dimension (N+1) +C On entry, this array must contain the currently computed +C left Kronecker (row) indices found in the previous call(s) +C of the routine. It should be initialized to zero on the +C first call. +C On exit, the leading NKROL elements of this array contain +C the left Kronecker (row) indices. +C +C MU (output) INTEGER +C The normal rank of the transfer function matrix of the +C original system. +C +C NU (output) INTEGER +C The dimension of the reduced system matrix and the number +C of (finite) invariant zeros if D' is invertible. +C +C NKROL (output) INTEGER +C The number of left Kronecker indices. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C NOTE that when SVLMAX > 0, the estimated ranks could be +C less than those defined above (see SVLMAX). +C +C Workspace +C +C IWORK INTEGER array, dimension (MAX(M,P)) +C +C DWORK DOUBLE PRECISION array, dimension (2*MAX(M,P)) +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C On exit, if INFO = 0, ZWORK(1) returns the optimal value +C of LZWORK. +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M) ). +C For optimum performance LZWORK should be larger. +C +C If LZWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C ZWORK array, returns this value as the first entry of +C the ZWORK array, and no error message related to LZWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Svaricek, F. +C Computation of the Structural Invariants of Linear +C Multivariable Systems with an Extended Version of +C the Program ZEROS. +C System & Control Letters, 6, pp. 261-266, 1985. +C +C [2] Emami-Naeini, A. and Van Dooren, P. +C Computation of Zeros of Linear Multivariable Systems. +C Automatica, 18, pp. 415-430, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008 with suggestions from P. Gahinet, +C The MathWorks. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, unitary transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION DZERO + PARAMETER ( DZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDABCD, LZWORK, M, MU, N, NINFZ, NKROL, + $ NU, P, RO, SIGMA + DOUBLE PRECISION SVLMAX, TOL +C .. Array Arguments .. + INTEGER INFZ(*), IWORK(*), KRONL(*) + COMPLEX*16 ABCD(LDABCD,*), ZWORK(*) + DOUBLE PRECISION DWORK(*) +C .. Local Scalars .. + LOGICAL LQUERY + INTEGER I1, IK, IROW, ITAU, IZ, JWORK, MM1, MNTAU, MNU, + $ MPM, NB, NP, RANK, RO1, TAU, WRKOPT + COMPLEX*16 TC +C .. Local Arrays .. + DOUBLE PRECISION SVAL(3) +C .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +C .. External Subroutines .. + EXTERNAL MB3OYZ, MB3PYZ, XERBLA, ZLAPMT, ZLARFG, ZLASET, + $ ZLATZM, ZUNMQR, ZUNMRQ +C .. Intrinsic Functions .. + INTRINSIC DCONJG, INT, MAX, MIN +C .. Executable Statements .. +C + NP = N + P + MPM = MIN( P, M ) + INFO = 0 + LQUERY = ( LZWORK.EQ.-1 ) +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( RO.NE.P .AND. RO.NE.MAX( P-M, 0 ) ) THEN + INFO = -4 + ELSE IF( SIGMA.NE.0 .AND. SIGMA.NE.M ) THEN + INFO = -5 + ELSE IF( SVLMAX.LT.DZERO ) THEN + INFO = -6 + ELSE IF( LDABCD.LT.MAX( 1, NP ) ) THEN + INFO = -8 + ELSE IF( NINFZ.LT.0 ) THEN + INFO = -9 + ELSE + JWORK = MAX( 1, MPM + MAX( 3*M - 1, N ), + $ MIN( P, N ) + MAX( 3*P - 1, NP, N+M ) ) + IF( LQUERY ) THEN + IF( M.GT.0 ) THEN + NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', P, N, MPM, + $ -1 ) ) + WRKOPT = MAX( JWORK, MPM + MAX( 1, N )*NB ) + ELSE + WRKOPT = JWORK + END IF + NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', NP, N, MIN( P, N ), + $ -1 ) ) + WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, NP )*NB ) + NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'LN', N, M+N, + $ MIN( P, N ), -1 ) ) + WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, M+N )*NB ) + ELSE IF( LZWORK.LT.JWORK ) THEN + INFO = -19 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB8NXZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + ZWORK(1) = WRKOPT + RETURN + END IF +C + MU = P + NU = N +C + IZ = 0 + IK = 1 + MM1 = M + 1 + ITAU = 1 + NKROL = 0 + WRKOPT = 1 +C +C Main reduction loop: +C +C M NU M NU +C NU [ B A ] NU [ B A ] +C MU [ D C ] --> SIGMA [ RD C1 ] (SIGMA = rank(D) = +C TAU [ 0 C2 ] row size of RD) +C +C M NU-RO RO +C NU-RO [ B1 A11 A12 ] +C --> RO [ B2 A21 A22 ] (RO = rank(C2) = +C SIGMA [ RD C11 C12 ] col size of LC) +C TAU [ 0 0 LC ] +C +C M NU-RO +C NU-RO [ B1 A11 ] NU := NU - RO +C [----------] MU := RO + SIGMA +C --> RO [ B2 A21 ] D := [B2;RD] +C SIGMA [ RD C11 ] C := [A21;C11] +C + 20 IF ( MU.EQ.0 ) + $ GO TO 80 +C +C (Note: Comments in the code beginning "xWorkspace:", where x is +C I, D, or C, describe the minimal amount of integer, real and +C complex workspace needed at that point in the code, respectively, +C as well as the preferred amount for good performance.) +C + RO1 = RO + MNU = M + NU + IF ( M.GT.0 ) THEN + IF ( SIGMA.NE.0 ) THEN + IROW = NU + 1 +C +C Compress rows of D. First exploit triangular shape. +C CWorkspace: need M+N-1. +C + DO 40 I1 = 1, SIGMA + CALL ZLARFG( RO+1, ABCD(IROW,I1), ABCD(IROW+1,I1), 1, + $ TC ) + CALL ZLATZM( 'L', RO+1, MNU-I1, ABCD(IROW+1,I1), 1, + $ DCONJG( TC ), ABCD(IROW,I1+1), + $ ABCD(IROW+1,I1+1), LDABCD, ZWORK ) + IROW = IROW + 1 + 40 CONTINUE + CALL ZLASET( 'Lower', RO+SIGMA-1, SIGMA, ZERO, ZERO, + $ ABCD(NU+2,1), LDABCD ) + END IF +C +C Continue with Householder with column pivoting. +C +C The rank of D is the number of (estimated) singular values +C that are greater than TOL * MAX(SVLMAX,EMSV). This number +C includes the singular values of the first SIGMA columns. +C IWorkspace: need M; +C RWorkspace: need 2*M; +C CWorkspace: need min(RO1,M) + 3*M - 1. RO1 <= P. +C + IF ( SIGMA.LT.M ) THEN + JWORK = ITAU + MIN( RO1, M ) + I1 = SIGMA + 1 + IROW = NU + I1 + CALL MB3OYZ( RO1, M-SIGMA, ABCD(IROW,I1), LDABCD, TOL, + $ SVLMAX, RANK, SVAL, IWORK, ZWORK(ITAU), DWORK, + $ ZWORK(JWORK), INFO ) + WRKOPT = MAX( WRKOPT, JWORK + 3*M - 2 ) +C +C Apply the column permutations to matrices B and part of D. +C + CALL ZLAPMT( .TRUE., NU+SIGMA, M-SIGMA, ABCD(1,I1), LDABCD, + $ IWORK ) +C + IF ( RANK.GT.0 ) THEN +C +C Apply the Householder transformations to the submatrix C. +C CWorkspace: need min(RO1,M) + NU; +C prefer min(RO1,M) + NU*NB. +C + CALL ZUNMQR( 'Left', 'Conjugate', RO1, NU, RANK, + $ ABCD(IROW,I1), LDABCD, ZWORK(ITAU), + $ ABCD(IROW,MM1), LDABCD, ZWORK(JWORK), + $ LZWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) + IF ( RO1.GT.1 ) + $ CALL ZLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO, + $ ZERO, ABCD(IROW+1,I1), LDABCD ) + RO1 = RO1 - RANK + END IF + END IF + END IF +C + TAU = RO1 + SIGMA = MU - TAU +C +C Determination of the orders of the infinite zeros. +C + IF ( IZ.GT.0 ) THEN + INFZ(IZ) = INFZ(IZ) + RO - TAU + NINFZ = NINFZ + IZ*( RO - TAU ) + END IF + IF ( RO1.EQ.0 ) + $ GO TO 80 + IZ = IZ + 1 +C + IF ( NU.LE.0 ) THEN + MU = SIGMA + NU = 0 + RO = 0 + ELSE +C +C Compress the columns of C2 using RQ factorization with row +C pivoting, P * C2 = R * Q. +C + I1 = NU + SIGMA + 1 + MNTAU = MIN( TAU, NU ) + JWORK = ITAU + MNTAU +C +C The rank of C2 is the number of (estimated) singular values +C greater than TOL * MAX(SVLMAX,EMSV). +C IWorkspace: need TAU; +C RWorkspace: need 2*TAU; +C CWorkspace: need min(TAU,NU) + 3*TAU - 1. +C + CALL MB3PYZ( TAU, NU, ABCD(I1,MM1), LDABCD, TOL, SVLMAX, RANK, + $ SVAL, IWORK, ZWORK(ITAU), DWORK, ZWORK(JWORK), + $ INFO ) + WRKOPT = MAX( WRKOPT, JWORK + 3*TAU - 1 ) + IF ( RANK.GT.0 ) THEN + IROW = I1 + TAU - RANK +C +C Apply Q' to the first NU columns of [A; C1] from the right. +C CWorkspace: need min(TAU,NU) + NU + SIGMA; SIGMA <= P; +C prefer min(TAU,NU) + (NU + SIGMA)*NB. +C + CALL ZUNMRQ( 'Right', 'ConjTranspose', I1-1, NU, RANK, + $ ABCD(IROW,MM1), LDABCD, ZWORK(MNTAU-RANK+1), + $ ABCD(1,MM1), LDABCD, ZWORK(JWORK), + $ LZWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) +C +C Apply Q to the first NU rows and M + NU columns of [ B A ] +C from the left. +C CWorkspace: need min(TAU,NU) + M + NU; +C prefer min(TAU,NU) + (M + NU)*NB. +C + CALL ZUNMRQ( 'Left', 'NoTranspose', NU, MNU, RANK, + $ ABCD(IROW,MM1), LDABCD, ZWORK(MNTAU-RANK+1), + $ ABCD, LDABCD, ZWORK(JWORK), LZWORK-JWORK+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) +C + CALL ZLASET( 'Full', RANK, NU-RANK, ZERO, ZERO, + $ ABCD(IROW,MM1), LDABCD ) + IF ( RANK.GT.1 ) + $ CALL ZLASET( 'Lower', RANK-1, RANK-1, ZERO, ZERO, + $ ABCD(IROW+1,MM1+NU-RANK), LDABCD ) + END IF +C + RO = RANK + END IF +C +C Determine the left Kronecker indices (row indices). +C + KRONL(IK) = KRONL(IK) + TAU - RO + NKROL = NKROL + KRONL(IK) + IK = IK + 1 +C +C C and D are updated to [A21 ; C11] and [B2 ; RD]. +C + NU = NU - RO + MU = SIGMA + RO + IF ( RO.NE.0 ) + $ GO TO 20 +C + 80 CONTINUE + ZWORK(1) = WRKOPT + RETURN +C *** Last line of AB8NXZ *** + END diff --git a/mex/sources/libslicot/AG07BD.f b/mex/sources/libslicot/AG07BD.f new file mode 100644 index 000000000..5a7ab4c5a --- /dev/null +++ b/mex/sources/libslicot/AG07BD.f @@ -0,0 +1,273 @@ + SUBROUTINE AG07BD( JOBE, N, M, A, LDA, E, LDE, B, LDB, C, LDC, + $ D, LDD, AI, LDAI, EI, LDEI, BI, LDBI, CI, LDCI, + $ DI, LDDI, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the inverse (Ai-lambda*Ei,Bi,Ci,Di) of a given +C descriptor system (A-lambda*E,B,C,D). +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBE CHARACTER*1 +C Specifies whether E is a general square or an identity +C matrix as follows: +C = 'G': E is a general square matrix; +C = 'I': E is the identity matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the square matrices A and E; +C also the number of rows of matrix B and the number of +C columns of matrix C. N >= 0. +C +C M (input) INTEGER +C The number of system inputs and outputs, i.e., the number +C of columns of matrices B and D and the number of rows of +C matrices C and D. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the original system. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C If JOBE = 'G', the leading N-by-N part of this array must +C contain the descriptor matrix E of the original system. +C If JOBE = 'I', then E is assumed to be the identity +C matrix and is not referenced. +C +C LDE INTEGER +C The leading dimension of the array E. +C LDE >= MAX(1,N), if JOBE = 'G'; +C LDE >= 1, if JOBE = 'I'. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input matrix B of the original system. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading M-by-N part of this array must contain the +C output matrix C of the original system. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,M). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading M-by-M part of this array must contain the +C feedthrough matrix D of the original system. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= MAX(1,M). +C +C AI (output) DOUBLE PRECISION array, dimension (LDAI,N+M) +C The leading (N+M)-by-(N+M) part of this array contains +C the state matrix Ai of the inverse system. +C If LDAI = LDA >= N+M, then AI and A can share the same +C storage locations. +C +C LDAI INTEGER +C The leading dimension of the array AI. +C LDAI >= MAX(1,N+M). +C +C EI (output) DOUBLE PRECISION array, dimension (LDEI,N+M) +C The leading (N+M)-by-(N+M) part of this array contains +C the descriptor matrix Ei of the inverse system. +C If LDEI = LDE >= N+M, then EI and E can share the same +C storage locations. +C +C LDEI INTEGER +C The leading dimension of the array EI. +C LDEI >= MAX(1,N+M). +C +C BI (output) DOUBLE PRECISION array, dimension (LDBI,M) +C The leading (N+M)-by-M part of this array contains +C the input matrix Bi of the inverse system. +C If LDBI = LDB >= N+M, then BI and B can share the same +C storage locations. +C +C LDBI INTEGER +C The leading dimension of the array BI. +C LDBI >= MAX(1,N+M). +C +C CI (output) DOUBLE PRECISION array, dimension (LDCI,N+M) +C The leading M-by-(N+M) part of this array contains +C the output matrix Ci of the inverse system. +C If LDCI = LDC, CI and C can share the same storage +C locations. +C +C LDCI INTEGER +C The leading dimension of the array CI. LDCI >= MAX(1,M). +C +C DI (output) DOUBLE PRECISION array, dimension (LDDI,M) +C The leading M-by-M part of this array contains +C the feedthrough matrix Di = 0 of the inverse system. +C DI and D can share the same storage locations. +C +C LDDI INTEGER +C The leading dimension of the array DI. LDDI >= MAX(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrices of the inverse system are computed with the formulas +C +C ( E 0 ) ( A B ) ( 0 ) +C Ei = ( ) , Ai = ( ) , Bi = ( ), +C ( 0 0 ) ( C D ) ( -I ) +C +C Ci = ( 0 I ), Di = 0. +C +C FURTHER COMMENTS +C +C The routine does not perform an invertibility test. This check can +C be performed by using the SLICOT routines AB08NX or AG08BY. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. +C +C KEYWORDS +C +C Descriptor system, inverse system, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBE + INTEGER INFO, LDA, LDAI, LDB, LDBI, LDC, LDCI, + $ LDD, LDDI, LDE, LDEI, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), AI(LDAI,*), B(LDB,*), BI(LDBI,*), + $ C(LDC,*), CI(LDCI,*), D(LDD,*), DI(LDDI,*), + $ E(LDE,*), EI(LDEI,*) +C .. Local Scalars .. + LOGICAL UNITE +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + UNITE = LSAME( JOBE, 'I' ) + IF( .NOT. ( LSAME( JOBE, 'G' ) .OR. UNITE ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDE.LT.1 .OR. ( .NOT.UNITE .AND. LDE.LT.N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF( LDAI.LT.MAX( 1, N+M ) ) THEN + INFO = -15 + ELSE IF( LDEI.LT.MAX( 1, N+M ) ) THEN + INFO = -17 + ELSE IF( LDBI.LT.MAX( 1, N+M ) ) THEN + INFO = -19 + ELSE IF( LDCI.LT.MAX( 1, M ) ) THEN + INFO = -21 + ELSE IF( LDDI.LT.MAX( 1, M ) ) THEN + INFO = -23 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AG07BD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C +C Form Ai. +C + CALL DLACPY( 'Full', N, N, A, LDA, AI, LDAI ) + CALL DLACPY( 'Full', M, N, C, LDC, AI(N+1,1), LDAI ) + CALL DLACPY( 'Full', N, M, B, LDB, AI(1,N+1), LDAI ) + CALL DLACPY( 'Full', M, M, D, LDD, AI(N+1,N+1), LDAI ) +C +C Form Ei. +C + IF( UNITE ) THEN + CALL DLASET( 'Full', N+M, N, ZERO, ONE, EI, LDEI ) + ELSE + CALL DLACPY( 'Full', N, N, E, LDE, EI, LDEI ) + CALL DLASET( 'Full', M, N, ZERO, ZERO, EI(N+1,1), LDEI ) + END IF + CALL DLASET( 'Full', N+M, M, ZERO, ZERO, EI(1,N+1), LDEI ) +C +C Form Bi. +C + CALL DLASET( 'Full', N, M, ZERO, ZERO, BI, LDBI ) + CALL DLASET( 'Full', M, M, ZERO, -ONE, BI(N+1,1), LDBI ) +C +C Form Ci. +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, CI, LDCI ) + CALL DLASET( 'Full', M, M, ZERO, ONE, CI(1,N+1), LDCI ) +C +C Set Di. +C + CALL DLASET( 'Full', M, M, ZERO, ZERO, DI, LDDI ) +C + RETURN +C *** Last line of AG07BD *** + END diff --git a/mex/sources/libslicot/AG08BD.f b/mex/sources/libslicot/AG08BD.f new file mode 100644 index 000000000..ff0cdcc81 --- /dev/null +++ b/mex/sources/libslicot/AG08BD.f @@ -0,0 +1,628 @@ + SUBROUTINE AG08BD( EQUIL, L, N, M, P, A, LDA, E, LDE, B, LDB, + $ C, LDC, D, LDD, NFZ, NRANK, NIZ, DINFZ, NKROR, + $ NINFE, NKROL, INFZ, KRONR, INFE, KRONL, + $ TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To extract from the system pencil +C +C ( A-lambda*E B ) +C S(lambda) = ( ) +C ( C D ) +C +C a regular pencil Af-lambda*Ef which has the finite Smith zeros of +C S(lambda) as generalized eigenvalues. The routine also computes +C the orders of the infinite Smith zeros and determines the singular +C and infinite Kronecker structure of system pencil, i.e., the right +C and left Kronecker indices, and the multiplicities of infinite +C eigenvalues. +C +C ARGUMENTS +C +C Mode Parameters +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to balance the system +C matrix as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A, B, and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A, E, and C. N >= 0. +C +C M (input) INTEGER +C The number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The number of rows of matrix C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A of the system. +C On exit, the leading NFZ-by-NFZ part of this array +C contains the matrix Af of the reduced pencil. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E of the system. +C On exit, the leading NFZ-by-NFZ part of this array +C contains the matrix Ef of the reduced pencil. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the input/state matrix B of the system. +C On exit, this matrix does not contain useful information. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,L) if M > 0; +C LDB >= 1 if M = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C of the system. +C On exit, this matrix does not contain useful information. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct transmission matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NFZ (output) INTEGER +C The number of finite zeros. +C +C NRANK (output) INTEGER +C The normal rank of the system pencil. +C +C NIZ (output) INTEGER +C The number of infinite zeros. +C +C DINFZ (output) INTEGER +C The maximal multiplicity of infinite Smith zeros. +C +C NKROR (output) INTEGER +C The number of right Kronecker indices. +C +C NINFE (output) INTEGER +C The number of elementary infinite blocks. +C +C NKROL (output) INTEGER +C The number of left Kronecker indices. +C +C INFZ (output) INTEGER array, dimension (N+1) +C The leading DINFZ elements of INFZ contain information +C on the infinite elementary divisors as follows: +C the system has INFZ(i) infinite elementary divisors of +C degree i in the Smith form, where i = 1,2,...,DINFZ. +C +C KRONR (output) INTEGER array, dimension (N+M+1) +C The leading NKROR elements of this array contain the +C right Kronecker (column) indices. +C +C INFE (output) INTEGER array, dimension (1+MIN(L+P,N+M)) +C The leading NINFE elements of INFE contain the +C multiplicities of infinite eigenvalues. +C +C KRONL (output) INTEGER array, dimension (L+P+1) +C The leading NKROL elements of this array contain the +C left Kronecker (row) indices. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C If the user sets TOL <= 0, then default tolerances are +C used instead, as follows: TOLDEF = L*N*EPS in TG01FD +C (to determine the rank of E) and TOLDEF = (L+P)*(N+M)*EPS +C in the rest, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH). TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension N+max(1,M) +C On output, IWORK(1) contains the normal rank of the +C transfer function matrix. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( 4*(L+N), LDW ), if EQUIL = 'S', +C LDWORK >= LDW, if EQUIL = 'N', where +C LDW = max(L+P,M+N)*(M+N) + max(1,5*max(L+P,M+N)). +C For optimum performance LDWORK should be larger. +C +C If LDWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C DWORK array, returns this value as the first entry of +C the DWORK array, and no error message related to LDWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine extracts from the system matrix of a descriptor +C system (A-lambda*E,B,C,D) a regular pencil Af-lambda*Ef which +C has the finite zeros of the system as generalized eigenvalues. +C The procedure has the following main computational steps: +C +C (a) construct the (L+P)-by-(N+M) system pencil +C +C S(lambda) = ( B A )-lambda*( 0 E ); +C ( D C ) ( 0 0 ) +C +C (b) reduce S(lambda) to S1(lambda) with the same finite +C zeros and right Kronecker structure but with E +C upper triangular and nonsingular; +C +C (c) reduce S1(lambda) to S2(lambda) with the same finite +C zeros and right Kronecker structure but with D of +C full row rank; +C +C (d) reduce S2(lambda) to S3(lambda) with the same finite zeros +C and with D square invertible; +C +C (e) perform a unitary transformation on the columns of +C +C S3(lambda) = (A-lambda*E B) in order to reduce it to +C ( C D) +C +C (Af-lambda*Ef X), with Y and Ef square invertible; +C ( 0 Y) +C +C (f) compute the right and left Kronecker indices of the system +C matrix, which together with the multiplicities of the +C finite and infinite eigenvalues constitute the +C complete set of structural invariants under strict +C equivalence transformations of a linear system. +C +C REFERENCES +C +C [1] P. Misra, P. Van Dooren and A. Varga. +C Computation of structural invariants of generalized +C state-space systems. +C Automatica, 30, pp. 1921-1936, 1994. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable (see [1]). +C +C FURTHER COMMENTS +C +C In order to compute the finite Smith zeros of the system +C explicitly, a call to this routine may be followed by a +C call to the LAPACK Library routines DGEGV or DGGEV. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, +C May 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999, +C Jan. 2009, Mar. 2009, Apr. 2009. +C A. Varga, DLR Oberpfaffenhofen, Nov. 1999, Feb. 2002, Mar. 2002. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, orthogonal transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL + INTEGER DINFZ, INFO, L, LDA, LDB, LDC, LDD, LDE, LDWORK, + $ M, N, NFZ, NINFE, NIZ, NKROL, NKROR, NRANK, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER INFE(*), INFZ(*), IWORK(*), KRONL(*), KRONR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), E(LDE,*) +C .. Local Scalars .. + LOGICAL LEQUIL, LQUERY + INTEGER I, I0, I1, II, IPD, ITAU, J, JWORK, KABCD, + $ LABCD2, LDABCD, LDW, MM, MU, N2, NB, NN, NSINFE, + $ NU, NUMU, PP, WRKOPT + DOUBLE PRECISION SVLMAX, TOLER +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL AG08BY, DLACPY, DLASET, DORMRZ, DTZRZF, MA02BD, + $ MA02CD, TB01XD, TG01AD, TG01FD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LDABCD = MAX( L+P, N+M ) + LABCD2 = LDABCD*( N+M ) + LEQUIL = LSAME( EQUIL, 'S' ) + LQUERY = ( LDWORK.EQ.-1 ) +C +C Test the input scalar arguments. +C + IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -1 + ELSE IF( L.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -7 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -27 + ELSE + I0 = MIN( L+P, M+N ) + I1 = MIN( L, N ) + II = MIN( M, P ) + LDW = LABCD2 + MAX( 1, 5*LDABCD ) + IF( LEQUIL ) + $ LDW = MAX( 4*( L + N ), LDW ) + IF( LQUERY ) THEN + CALL TG01FD( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, + $ LDB, C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, + $ IWORK, DWORK, -1, INFO ) + WRKOPT = MAX( LDW, INT( DWORK(1) ) ) + SVLMAX = ZERO + CALL AG08BY( .TRUE., I1, M+N, P+L, SVLMAX, DWORK, LDABCD+I1, + $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, + $ TOL, IWORK, DWORK, -1, INFO ) + WRKOPT = MAX( WRKOPT, LABCD2 + INT( DWORK(1) ) ) + CALL AG08BY( .FALSE., I1, II, M+N, SVLMAX, DWORK, LDABCD+I1, + $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, + $ TOL, IWORK, DWORK, -1, INFO ) + WRKOPT = MAX( WRKOPT, LABCD2 + INT( DWORK(1) ) ) + NB = ILAENV( 1, 'ZGERQF', ' ', II, I1+II, -1, -1 ) + WRKOPT = MAX( WRKOPT, LABCD2 + II + II*NB ) + NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RT', I1, I1+II, II, + $ -1 ) ) + WRKOPT = MAX( WRKOPT, LABCD2 + II + I1*NB ) + ELSE IF( LDWORK.LT.LDW ) THEN + INFO = -30 + END IF + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AG08BD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C + NIZ = 0 + NKROL = 0 + NKROR = 0 +C +C Quick return if possible. +C + IF( MAX( L, N, M, P ).EQ.0 ) THEN + NFZ = 0 + DINFZ = 0 + NINFE = 0 + NRANK = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + WRKOPT = 1 + KABCD = 1 + JWORK = KABCD + LABCD2 +C +C If required, balance the system pencil. +C Workspace: need 4*(L+N). +C + IF( LEQUIL ) THEN + CALL TG01AD( 'A', L, N, M, P, ZERO, A, LDA, E, LDE, B, LDB, + $ C, LDC, DWORK, DWORK(L+1), DWORK(L+N+1), INFO ) + WRKOPT = 4*(L+N) + END IF + SVLMAX = DLANGE( 'Frobenius', L, N, E, LDE, DWORK ) +C +C Reduce the system matrix to QR form, +C +C ( A11-lambda*E11 A12 B1 ) +C ( A21 A22 B2 ) , +C ( C1 C2 D ) +C +C with E11 invertible and upper triangular. +C Real workspace: need max( 1, N+P, min(L,N)+max(3*N-1,M,L) ); +C prefer larger. +C Integer workspace: N. +C + CALL TG01FD( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, LDB, + $ C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, IWORK, DWORK, + $ LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Construct the system pencil +C +C MM NN +C ( B1 A12 A11-lambda*E11 ) NN +C S1(lambda) = ( B2 A22 A21 ) L-NN +C ( D C2 C1 ) P +C +C of dimension (L+P)-by-(M+N). +C Workspace: need LABCD2 = max( L+P, N+M )*( N+M ). +C + N2 = N - NN + MM = M + N2 + PP = P + ( L - NN ) + CALL DLACPY( 'Full', L, M, B, LDB, DWORK(KABCD), LDABCD ) + CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KABCD+L), LDABCD ) + CALL DLACPY( 'Full', L, N2, A(1,NN+1), LDA, + $ DWORK(KABCD+LDABCD*M), LDABCD ) + CALL DLACPY( 'Full', P, N2, C(1,NN+1), LDC, + $ DWORK(KABCD+LDABCD*M+L), LDABCD ) + CALL DLACPY( 'Full', L, NN, A, LDA, + $ DWORK(KABCD+LDABCD*MM), LDABCD ) + CALL DLACPY( 'Full', P, NN, C, LDC, + $ DWORK(KABCD+LDABCD*MM+L), LDABCD ) +C +C If required, set tolerance. +C + TOLER = TOL + IF( TOLER.LE.ZERO ) THEN + TOLER = DBLE( ( L + P )*( M + N ) ) * DLAMCH( 'Precision' ) + END IF + SVLMAX = MAX( SVLMAX, + $ DLANGE( 'Frobenius', NN+PP, NN+MM, DWORK(KABCD), + $ LDABCD, DWORK(JWORK) ) ) +C +C Extract the reduced pencil S2(lambda) +C +C ( Bc Ac-lambda*Ec ) +C ( Dc Cc ) +C +C having the same finite Smith zeros as the system pencil +C S(lambda) but with Dc, a MU-by-MM full row rank +C left upper trapezoidal matrix, and Ec, an NU-by-NU +C upper triangular nonsingular matrix. +C +C Real workspace: need max( min(P+L,M+N)+max(min(L,N),3*(M+N)-1), +C 5*(P+L), 1 ) + LABCD2; +C prefer larger. +C Integer workspace: MM, MM <= M+N; PP <= P+L. +C + CALL AG08BY( .TRUE., NN, MM, PP, SVLMAX, DWORK(KABCD), LDABCD, + $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, + $ TOLER, IWORK, DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Set the number of simple (nondynamic) infinite eigenvalues +C and the normal rank of the system pencil. +C + NSINFE = MU + NRANK = NN + MU +C +C Pertranspose the system. +C + CALL TB01XD( 'D', NU, MM, MM, MAX( 0, NU-1 ), MAX( 0, NU-1 ), + $ DWORK(KABCD+LDABCD*MM), LDABCD, + $ DWORK(KABCD), LDABCD, + $ DWORK(KABCD+LDABCD*MM+NU), LDABCD, + $ DWORK(KABCD+NU), LDABCD, INFO ) + CALL MA02BD( 'Right', NU+MM, MM, DWORK(KABCD), LDABCD ) + CALL MA02BD( 'Left', MM, NU+MM, DWORK(KABCD+NU), LDABCD ) + CALL MA02CD( NU, 0, MAX( 0, NU-1 ), E, LDE ) +C + IF( MU.NE.MM ) THEN + NN = NU + PP = MM + MM = MU + KABCD = KABCD + ( PP - MM )*LDABCD +C +C Extract the reduced pencil S3(lambda), +C +C ( Br Ar-lambda*Er ) , +C ( Dr Cr ) +C +C having the same finite Smith zeros as the pencil S(lambda), +C but with Dr, an MU-by-MU invertible upper triangular matrix, +C and Er, an NU-by-NU upper triangular nonsingular matrix. +C +C Workspace: need max( 1, 5*(M+N) ) + LABCD2. +C prefer larger. +C No integer workspace necessary. +C + CALL AG08BY( .FALSE., NN, MM, PP, SVLMAX, DWORK(KABCD), LDABCD, + $ E, LDE, NU, MU, I0, I1, NKROR, IWORK, KRONR, + $ TOLER, IWORK, DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + END IF +C + IF( NU.NE.0 ) THEN +C +C Perform a unitary transformation on the columns of +C ( Br Ar-lambda*Er ) +C ( Dr Cr ) +C in order to reduce it to +C ( * Af-lambda*Ef ) +C ( Y 0 ) +C with Y and Ef square invertible. +C +C Compute Af by reducing ( Br Ar ) to ( * Af ) . +C ( Dr Cr ) ( Y 0 ) +C + NUMU = NU + MU + IPD = KABCD + NU + ITAU = JWORK + JWORK = ITAU + MU +C +C Workspace: need LABCD2 + 2*min(M,P); +C prefer LABCD2 + min(M,P) + min(M,P)*NB. +C + CALL DTZRZF( MU, NUMU, DWORK(IPD), LDABCD, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need LABCD2 + min(M,P) + min(L,N); +C prefer LABCD2 + min(M,P) + min(L,N)*NB. +C + CALL DORMRZ( 'Right', 'Transpose', NU, NUMU, MU, NU, + $ DWORK(IPD), LDABCD, DWORK(ITAU), DWORK(KABCD), + $ LDABCD, DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Save Af. +C + CALL DLACPY( 'Full', NU, NU, DWORK(KABCD+LDABCD*MU), LDABCD, A, + $ LDA ) +C +C Compute Ef by applying the saved transformations from previous +C reduction to ( 0 Er ) . +C + CALL DLASET( 'Full', NU, MU, ZERO, ZERO, DWORK(KABCD), LDABCD ) + CALL DLACPY( 'Full', NU, NU, E, LDE, DWORK(KABCD+LDABCD*MU), + $ LDABCD ) +C + CALL DORMRZ( 'Right', 'Transpose', NU, NUMU, MU, NU, + $ DWORK(IPD), LDABCD, DWORK(ITAU), DWORK(KABCD), + $ LDABCD, DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C +C Save Ef. +C + CALL DLACPY( 'Full', NU, NU, DWORK(KABCD+LDABCD*MU), LDABCD, E, + $ LDE ) + END IF +C + NFZ = NU +C +C Set right Kronecker indices (column indices). +C + DO 10 I = 1, NKROR + IWORK(I) = KRONR(I) + 10 CONTINUE +C + J = 0 + DO 30 I = 1, NKROR + DO 20 II = J + 1, J + IWORK(I) + KRONR(II) = I - 1 + 20 CONTINUE + J = J + IWORK(I) + 30 CONTINUE +C + NKROR = J +C +C Set left Kronecker indices (row indices). +C + DO 40 I = 1, NKROL + IWORK(I) = KRONL(I) + 40 CONTINUE +C + J = 0 + DO 60 I = 1, NKROL + DO 50 II = J + 1, J + IWORK(I) + KRONL(II) = I - 1 + 50 CONTINUE + J = J + IWORK(I) + 60 CONTINUE +C + NKROL = J +C +C Determine the number of simple infinite blocks +C as the difference between the number of infinite blocks +C of order greater than one and the order of Dr. +C + NINFE = 0 + DO 70 I = 1, DINFZ + NINFE = NINFE + INFZ(I) + 70 CONTINUE + NINFE = NSINFE - NINFE + DO 80 I = 1, NINFE + INFE(I) = 1 + 80 CONTINUE +C +C Set the structure of infinite eigenvalues. +C + DO 100 I = 1, DINFZ + DO 90 II = NINFE + 1, NINFE + INFZ(I) + INFE(II) = I + 1 + 90 CONTINUE + NINFE = NINFE + INFZ(I) + 100 CONTINUE +C + IWORK(1) = NSINFE + DWORK(1) = WRKOPT + RETURN +C *** Last line of AG08BD *** + END diff --git a/mex/sources/libslicot/AG08BY.f b/mex/sources/libslicot/AG08BY.f new file mode 100644 index 000000000..7e980bf87 --- /dev/null +++ b/mex/sources/libslicot/AG08BY.f @@ -0,0 +1,680 @@ + SUBROUTINE AG08BY( FIRST, N, M, P, SVLMAX, ABCD, LDABCD, E, LDE, + $ NR, PR, NINFZ, DINFZ, NKRONL, INFZ, KRONL, + $ TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To extract from the (N+P)-by-(M+N) descriptor system pencil +C +C S(lambda) = ( B A - lambda*E ) +C ( D C ) +C +C with E nonsingular and upper triangular a +C (NR+PR)-by-(M+NR) "reduced" descriptor system pencil +C +C ( Br Ar-lambda*Er ) +C Sr(lambda) = ( ) +C ( Dr Cr ) +C +C having the same finite Smith zeros as the pencil +C S(lambda) but with Dr, a PR-by-M full row rank +C left upper trapezoidal matrix, and Er, an NR-by-NR +C upper triangular nonsingular matrix. +C +C ARGUMENTS +C +C Mode Parameters +C +C FIRST LOGICAL +C Specifies if AG08BY is called first time or it is called +C for an already reduced system, with D full column rank +C with the last M rows in upper triangular form: +C FIRST = .TRUE., first time called; +C FIRST = .FALSE., not first time called. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of rows of matrix B, the number of columns of +C matrix C and the order of square matrices A and E. +C N >= 0. +C +C M (input) INTEGER +C The number of columns of matrices B and D. M >= 0. +C M <= P if FIRST = .FALSE. . +C +C P (input) INTEGER +C The number of rows of matrices C and D. P >= 0. +C +C SVLMAX (input) DOUBLE PRECISION +C During each reduction step, the rank-revealing QR +C factorization of a matrix stops when the estimated minimum +C singular value is smaller than TOL * MAX(SVLMAX,EMSV), +C where EMSV is the estimated maximum singular value. +C SVLMAX >= 0. +C +C ABCD (input/output) DOUBLE PRECISION array, dimension +C (LDABCD,M+N) +C On entry, the leading (N+P)-by-(M+N) part of this array +C must contain the compound matrix +C ( B A ) , +C ( D C ) +C where A is an N-by-N matrix, B is an N-by-M matrix, +C C is a P-by-N matrix and D is a P-by-M matrix. +C If FIRST = .FALSE., then D must be a full column +C rank matrix with the last M rows in upper triangular form. +C On exit, the leading (NR+PR)-by-(M+NR) part of ABCD +C contains the reduced compound matrix +C ( Br Ar ) , +C ( Dr Cr ) +C where Ar is an NR-by-NR matrix, Br is an NR-by-M matrix, +C Cr is a PR-by-NR matrix, Dr is a PR-by-M full row rank +C left upper trapezoidal matrix with the first PR columns +C in upper triangular form. +C +C LDABCD INTEGER +C The leading dimension of array ABCD. +C LDABCD >= MAX(1,N+P). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the upper triangular nonsingular matrix E. +C On exit, the leading NR-by-NR part contains the reduced +C upper triangular nonsingular matrix Er. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C NR (output) INTEGER +C The order of the reduced matrices Ar and Er; also the +C number of rows of the reduced matrix Br and the number +C of columns of the reduced matrix Cr. +C If Dr is invertible, NR is also the number of finite +C Smith zeros. +C +C PR (output) INTEGER +C The rank of the resulting matrix Dr; also the number of +C rows of reduced matrices Cr and Dr. +C +C NINFZ (output) INTEGER +C Number of infinite zeros. NINFZ = 0 if FIRST = .FALSE. . +C +C DINFZ (output) INTEGER +C The maximal multiplicity of infinite zeros. +C DINFZ = 0 if FIRST = .FALSE. . +C +C NKRONL (output) INTEGER +C The maximal dimension of left elementary Kronecker blocks. +C +C INFZ (output) INTEGER array, dimension (N) +C INFZ(i) contains the number of infinite zeros of +C degree i, where i = 1,2,...,DINFZ. +C INFZ is not referenced if FIRST = .FALSE. . +C +C KRONL (output) INTEGER array, dimension (N+1) +C KRONL(i) contains the number of left elementary Kronecker +C blocks of dimension i-by-(i-1), where i = 1,2,...,NKRONL. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C If the user sets TOL <= 0, then an implicitly computed, +C default tolerance TOLDEF = (N+P)*(N+M)*EPS, is used +C instead, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH). +C NOTE that when SVLMAX > 0, the estimated ranks could be +C less than those defined above (see SVLMAX). TOL <= 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C If FIRST = .FALSE., IWORK is not referenced. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 1, if P = 0; otherwise +C LDWORK >= MAX( 1, N+M-1, MIN(P,M) + MAX(3*M-1,N), 5*P ), +C if FIRST = .TRUE.; +C LDWORK >= MAX( 1, N+M-1, 5*P ), if FIRST = .FALSE. . +C The second term is not needed if M = 0. +C For optimum performance LDWORK should be larger. +C +C If LDWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C DWORK array, returns this value as the first entry of +C the DWORK array, and no error message related to LDWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The subroutine is based on the reduction algorithm of [1]. +C +C REFERENCES +C +C [1] P. Misra, P. Van Dooren and A. Varga. +C Computation of structural invariants of generalized +C state-space systems. +C Automatica, 30, pp. 1921-1936, 1994. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( (P+N)*(M+N)*N ) floating point operations. +C +C FURTHER COMMENTS +C +C The number of infinite zeros is computed as +C +C DINFZ +C NINFZ = Sum (INFZ(i)*i) . +C i=1 +C Note that each infinite zero of multiplicity k corresponds to +C an infinite eigenvalue of multiplicity k+1. +C The multiplicities of the infinite eigenvalues can be determined +C from PR, DINFZ and INFZ(i), i = 1, ..., DINFZ, as follows: +C +C DINFZ +C - there are PR - Sum (INFZ(i)) simple infinite eigenvalues; +C i=1 +C +C - there are INFZ(i) infinite eigenvalues with multiplicity i+1, +C for i = 1, ..., DINFZ. +C +C The left Kronecker indices are: +C +C [ 0 0 ... 0 | 1 1 ... 1 | .... | NKRONL ... NKRONL ] +C |<- KRONL(1) ->|<- KRONL(2) ->| |<- KRONL(NKRONL) ->| +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C May 1999. Based on the RASP routine SRISEP. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999, +C Jan. 2009, Apr. 2009. +C A. Varga, DLR Oberpfaffenhofen, March 2002. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, orthogonal transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ONE, P05, ZERO + PARAMETER ( ONE = 1.0D0, P05 = 0.05D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER DINFZ, INFO, LDABCD, LDE, LDWORK, M, N, NINFZ, + $ NKRONL, NR, P, PR + DOUBLE PRECISION SVLMAX, TOL + LOGICAL FIRST +C .. Array Arguments .. + INTEGER INFZ( * ), IWORK(*), KRONL( * ) + DOUBLE PRECISION ABCD( LDABCD, * ), DWORK( * ), E( LDE, * ) +C .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, ICOL, ILAST, IRC, IROW, ISMAX, ISMIN, ITAU, + $ J, JLAST, JWORK1, JWORK2, K, MN, MN1, MNR, + $ MNTAU, MP1, MPM, MUI, MUIM1, N1, NB, NBLCKS, + $ PN, RANK, RO, RO1, SIGMA, TAUI, WRKOPT + DOUBLE PRECISION C, C1, C2, RCOND, S, S1, S2, SMAX, SMAXPR, + $ SMIN, SMINPR, T, TT +C .. Local Arrays .. + DOUBLE PRECISION DUM(1), SVAL(3) +C .. External Functions .. + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL DLAMCH, DNRM2, IDAMAX, ILAENV +C .. External Subroutines .. + EXTERNAL DCOPY, DLAIC1, DLAPMT, DLARFG, DLARTG, DLASET, + $ DLATZM, DORMQR, DROT, DSWAP, MB03OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C +C Test the input parameters. +C + LQUERY = ( LDWORK.EQ.-1 ) + INFO = 0 + PN = P + N + MN = M + N + MPM = MIN( P, M ) + IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 .OR. ( .NOT.FIRST .AND. M.GT.P ) ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -5 + ELSE IF( LDABCD.LT.MAX( 1, PN ) ) THEN + INFO = -7 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( TOL.GT.ONE ) THEN + INFO = -17 + ELSE + WRKOPT = MAX( 1, 5*P ) + IF( P.GT.0 ) THEN + IF( M.GT.0 ) THEN + WRKOPT = MAX( WRKOPT, MN-1 ) + IF( FIRST ) THEN + WRKOPT = MAX( WRKOPT, MPM + MAX( 3*M-1, N ) ) + IF( LQUERY ) THEN + NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LT', P, N, + $ MPM, -1 ) ) + WRKOPT = MAX( WRKOPT, MPM + MAX( 1, N )*NB ) + END IF + END IF + END IF + END IF + IF( LDWORK.LT.WRKOPT .AND. .NOT.LQUERY ) THEN + INFO = -20 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'AG08BY', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C +C Initialize output variables. +C + PR = P + NR = N + DINFZ = 0 + NINFZ = 0 + NKRONL = 0 +C +C Quick return if possible. +C + IF( P.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF + IF( N.EQ.0 .AND. M.EQ.0 ) THEN + PR = 0 + NKRONL = 1 + KRONL(1) = P + DWORK(1) = ONE + RETURN + END IF +C + RCOND = TOL + IF( RCOND.LE.ZERO ) THEN +C +C Use the default tolerance in rank determination. +C + RCOND = DBLE( PN*MN )*DLAMCH( 'EPSILON' ) + END IF +C +C The D matrix is (RO+SIGMA)-by-M, where RO = P - SIGMA and +C SIGMA = 0 for FIRST = .TRUE. and SIGMA = M for FIRST = .FALSE.. +C The leading (RO+SIGMA)-by-SIGMA submatrix of D has full column +C rank, with the trailing SIGMA-by-SIGMA submatrix upper triangular. +C + IF( FIRST ) THEN + SIGMA = 0 + ELSE + SIGMA = M + END IF + RO = P - SIGMA + MP1 = M + 1 + MUI = 0 + DUM(1) = ZERO +C + ITAU = 1 + JWORK1 = ITAU + MPM + ISMIN = 2*P + 1 + ISMAX = ISMIN + P + JWORK2 = ISMAX + P + NBLCKS = 0 + WRKOPT = 1 +C + 10 IF( PR.EQ.0 ) GO TO 90 +C +C (NR+1,ICOL+1) points to the current position of matrix D. +C + RO1 = RO + MNR = M + NR + IF( M.GT.0 ) THEN +C +C Compress rows of D; first exploit the trapezoidal shape of the +C (RO+SIGMA)-by-SIGMA matrix in the first SIGMA columns of D; +C compress the first SIGMA columns without column pivoting: +C +C ( x x x x x ) ( x x x x x ) +C ( x x x x x ) ( 0 x x x x ) +C ( x x x x x ) - > ( 0 0 x x x ) +C ( 0 x x x x ) ( 0 0 0 x x ) +C ( 0 0 x x x ) ( 0 0 0 x x ) +C +C where SIGMA = 3 and RO = 2. +C Workspace: need maximum M+N-1. +C + IROW = NR + DO 20 ICOL = 1, SIGMA + IROW = IROW + 1 + CALL DLARFG( RO+1, ABCD(IROW,ICOL), ABCD(IROW+1,ICOL), 1, + $ T ) + CALL DLATZM( 'L', RO+1, MNR-ICOL, ABCD(IROW+1,ICOL), 1, T, + $ ABCD(IROW,ICOL+1), ABCD(IROW+1,ICOL+1), + $ LDABCD, DWORK ) + CALL DCOPY( PR-ICOL, DUM, 0, ABCD(IROW+1,ICOL), 1 ) + 20 CONTINUE + WRKOPT = MAX( WRKOPT, MN - 1 ) +C + IF( FIRST ) THEN +C +C Continue with Householder with column pivoting. +C +C ( x x x x x ) ( x x x x x ) +C ( 0 x x x x ) ( 0 x x x x ) +C ( 0 0 x x x ) - > ( 0 0 x x x ) +C ( 0 0 0 x x ) ( 0 0 0 x x ) +C ( 0 0 0 x x ) ( 0 0 0 0 0 ) +C +C Real workspace: need maximum min(P,M)+3*M-1; +C Integer workspace: need maximum M. +C + IROW = MIN( NR+SIGMA+1, PN ) + ICOL = MIN( SIGMA+1, M ) + CALL MB03OY( RO1, M-SIGMA, ABCD(IROW,ICOL), LDABCD, + $ RCOND, SVLMAX, RANK, SVAL, IWORK, DWORK(ITAU), + $ DWORK(JWORK1), INFO ) + WRKOPT = MAX( WRKOPT, JWORK1 + 3*M - 2 ) +C +C Apply the column permutations to B and part of D. +C + CALL DLAPMT( .TRUE., NR+SIGMA, M-SIGMA, ABCD(1,ICOL), + $ LDABCD, IWORK ) +C + IF( RANK.GT.0 ) THEN +C +C Apply the Householder transformations to the submatrix C. +C Workspace: need maximum min(P,M) + N; +C prefer maximum min(P,M) + N*NB. +C + CALL DORMQR( 'Left', 'Transpose', RO1, NR, RANK, + $ ABCD(IROW,ICOL), LDABCD, DWORK(ITAU), + $ ABCD(IROW,MP1), LDABCD, DWORK(JWORK1), + $ LDWORK-JWORK1+1, INFO ) + WRKOPT = MAX( WRKOPT, JWORK1 + INT( DWORK(JWORK1) ) - 1 ) + CALL DLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO, + $ ZERO, ABCD(MIN( IROW+1, PN ),ICOL), LDABCD ) + RO1 = RO1 - RANK + END IF + END IF +C +C Terminate if Dr has maximal row rank. +C + IF( RO1.EQ.0 ) GO TO 90 +C + END IF +C +C Update SIGMA. +C + SIGMA = PR - RO1 +C + NBLCKS = NBLCKS + 1 + TAUI = RO1 +C +C Compress the columns of current C to separate a TAUI-by-MUI +C full column rank block. +C + IF( NR.EQ.0 ) THEN +C +C Finish for zero state dimension. +C + PR = SIGMA + RANK = 0 + ELSE +C +C Perform RQ-decomposition with row pivoting on the current C +C while keeping E upper triangular. +C The current C is the TAUI-by-NR matrix delimited by rows +C IRC+1 to IRC+TAUI and columns M+1 to M+NR of ABCD. +C The rank of current C is computed in MUI. +C Workspace: need maximum 5*P. +C + IRC = NR + SIGMA + N1 = NR + IF( TAUI.GT.1 ) THEN +C +C Compute norms. +C + DO 30 I = 1, TAUI + DWORK(I) = DNRM2( NR, ABCD(IRC+I,MP1), LDABCD ) + DWORK(P+I) = DWORK(I) + 30 CONTINUE + END IF +C + RANK = 0 + MNTAU = MIN( TAUI, NR ) +C +C ICOL and IROW will point to the current pivot position in C. +C + ILAST = NR + PR + JLAST = M + NR + IROW = ILAST + ICOL = JLAST + I = TAUI + 40 IF( RANK.LT.MNTAU ) THEN + MN1 = M + N1 +C +C Pivot if necessary. +C + IF( I.NE.1 ) THEN + J = IDAMAX( I, DWORK, 1 ) + IF( J.NE.I ) THEN + DWORK(J) = DWORK(I) + DWORK(P+J) = DWORK(P+I) + CALL DSWAP( N1, ABCD(IROW,MP1), LDABCD, + $ ABCD(IRC+J,MP1), LDABCD ) + END IF + END IF +C +C Zero elements left to ABCD(IROW,ICOL). +C + DO 50 K = 1, N1-1 + J = M + K +C +C Rotate columns J, J+1 to zero ABCD(IROW,J). +C + T = ABCD(IROW,J+1) + CALL DLARTG( T, ABCD(IROW,J), C, S, ABCD(IROW,J+1) ) + ABCD(IROW,J) = ZERO + CALL DROT( IROW-1, ABCD(1,J+1), 1, ABCD(1,J), 1, C, S ) + CALL DROT( K+1, E(1,K+1), 1, E(1,K), 1, C, S ) +C +C Rotate rows K, K+1 to zero E(K+1,K). +C + T = E(K,K) + CALL DLARTG( T, E(K+1,K), C, S, E(K,K) ) + E(K+1,K) = ZERO + CALL DROT( N1-K, E(K,K+1), LDE, E(K+1,K+1), LDE, C, S ) + CALL DROT( MN1, ABCD(K,1), LDABCD, ABCD(K+1,1), LDABCD, + $ C, S ) + 50 CONTINUE +C + IF( RANK.EQ.0 ) THEN +C +C Initialize; exit if matrix is zero (RANK = 0). +C + SMAX = ABS( ABCD(ILAST,JLAST) ) + IF ( SMAX.EQ.ZERO ) GO TO 80 + SMIN = SMAX + SMAXPR = SMAX + SMINPR = SMIN + C1 = ONE + C2 = ONE + ELSE +C +C One step of incremental condition estimation. +C + CALL DCOPY( RANK, ABCD(IROW,ICOL+1), LDABCD, + $ DWORK(JWORK2), 1 ) + CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, + $ DWORK(JWORK2), ABCD(IROW,ICOL), SMINPR, S1, + $ C1 ) + CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, + $ DWORK(JWORK2), ABCD(IROW,ICOL), SMAXPR, S2, + $ C2 ) + WRKOPT = MAX( WRKOPT, 5*P ) + END IF +C +C Check the rank; finish the loop if rank loss occurs. +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN +C +C Finish the loop if last row. +C + IF( N1.EQ.0 ) THEN + RANK = RANK + 1 + GO TO 80 + END IF +C + IF( N1.GT.1 ) THEN +C +C Update norms. +C + IF( I-1.GT.1 ) THEN + DO 60 J = 1, I - 1 + IF( DWORK(J).NE.ZERO ) THEN + T = ONE - ( ABS( ABCD(IRC+J,ICOL) ) + $ /DWORK(J) )**2 + T = MAX( T, ZERO ) + TT = ONE + + $ P05*T*( DWORK(J)/DWORK(P+J) )**2 + IF( TT.NE.ONE ) THEN + DWORK(J) = DWORK(J)*SQRT( T ) + ELSE + DWORK(J) = DNRM2( N1-1, + $ ABCD(IRC+J,MP1), LDABCD ) + DWORK(P+J) = DWORK(J) + END IF + END IF + 60 CONTINUE + END IF + END IF +C + DO 70 J = 1, RANK + DWORK( ISMIN+J-1 ) = S1*DWORK( ISMIN+J-1 ) + DWORK( ISMAX+J-1 ) = S2*DWORK( ISMAX+J-1 ) + 70 CONTINUE +C + DWORK( ISMIN+RANK ) = C1 + DWORK( ISMAX+RANK ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + ICOL = ICOL - 1 + IROW = IROW - 1 + N1 = N1 - 1 + I = I - 1 + GO TO 40 + END IF + END IF + END IF + END IF + END IF +C + 80 CONTINUE + MUI = RANK + NR = NR - MUI + PR = SIGMA + MUI +C +C Set number of left Kronecker blocks of order (i-1)-by-i. +C + KRONL(NBLCKS) = TAUI - MUI +C +C Set number of infinite divisors of order i-1. +C + IF( FIRST .AND. NBLCKS.GT.1 ) + $ INFZ(NBLCKS-1) = MUIM1 - TAUI + MUIM1 = MUI + RO = MUI +C +C Continue reduction if rank of current C is positive. +C + IF( MUI.GT.0 ) + $ GO TO 10 +C +C Determine the maximal degree of infinite zeros and +C the number of infinite zeros. +C + 90 CONTINUE + IF( FIRST ) THEN + IF( MUI.EQ.0 ) THEN + DINFZ = MAX( 0, NBLCKS - 1 ) + ELSE + DINFZ = NBLCKS + INFZ(NBLCKS) = MUI + END IF + K = DINFZ + DO 100 I = K, 1, -1 + IF( INFZ(I).NE.0 ) GO TO 110 + DINFZ = DINFZ - 1 + 100 CONTINUE + 110 CONTINUE + DO 120 I = 1, DINFZ + NINFZ = NINFZ + INFZ(I)*I + 120 CONTINUE + END IF +C +C Determine the maximal order of left elementary Kronecker blocks. +C + NKRONL = NBLCKS + DO 130 I = NBLCKS, 1, -1 + IF( KRONL(I).NE.0 ) GO TO 140 + NKRONL = NKRONL - 1 + 130 CONTINUE + 140 CONTINUE +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of AG08BY *** + END diff --git a/mex/sources/libslicot/AG08BZ.f b/mex/sources/libslicot/AG08BZ.f new file mode 100644 index 000000000..6292b0554 --- /dev/null +++ b/mex/sources/libslicot/AG08BZ.f @@ -0,0 +1,641 @@ + SUBROUTINE AG08BZ( EQUIL, L, N, M, P, A, LDA, E, LDE, B, LDB, + $ C, LDC, D, LDD, NFZ, NRANK, NIZ, DINFZ, NKROR, + $ NINFE, NKROL, INFZ, KRONR, INFE, KRONL, + $ TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To extract from the system pencil +C +C ( A-lambda*E B ) +C S(lambda) = ( ) +C ( C D ) +C +C a regular pencil Af-lambda*Ef which has the finite Smith zeros of +C S(lambda) as generalized eigenvalues. The routine also computes +C the orders of the infinite Smith zeros and determines the singular +C and infinite Kronecker structure of system pencil, i.e., the right +C and left Kronecker indices, and the multiplicities of infinite +C eigenvalues. +C +C ARGUMENTS +C +C Mode Parameters +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to balance the system +C matrix as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A, B, and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A, E, and C. N >= 0. +C +C M (input) INTEGER +C The number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The number of rows of matrix C. P >= 0. +C +C A (input/output) COMPLEX*16 array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A of the system. +C On exit, the leading NFZ-by-NFZ part of this array +C contains the matrix Af of the reduced pencil. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) COMPLEX*16 array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E of the system. +C On exit, the leading NFZ-by-NFZ part of this array +C contains the matrix Ef of the reduced pencil. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) COMPLEX*16 array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the input/state matrix B of the system. +C On exit, this matrix does not contain useful information. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,L) if M > 0; +C LDB >= 1 if M = 0. +C +C C (input/output) COMPLEX*16 array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C of the system. +C On exit, this matrix does not contain useful information. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) COMPLEX*16 array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct transmission matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NFZ (output) INTEGER +C The number of finite zeros. +C +C NRANK (output) INTEGER +C The normal rank of the system pencil. +C +C NIZ (output) INTEGER +C The number of infinite zeros. +C +C DINFZ (output) INTEGER +C The maximal multiplicity of infinite Smith zeros. +C +C NKROR (output) INTEGER +C The number of right Kronecker indices. +C +C NINFE (output) INTEGER +C The number of elementary infinite blocks. +C +C NKROL (output) INTEGER +C The number of left Kronecker indices. +C +C INFZ (output) INTEGER array, dimension (N+1) +C The leading DINFZ elements of INFZ contain information +C on the infinite elementary divisors as follows: +C the system has INFZ(i) infinite elementary divisors of +C degree i in the Smith form, where i = 1,2,...,DINFZ. +C +C KRONR (output) INTEGER array, dimension (N+M+1) +C The leading NKROR elements of this array contain the +C right Kronecker (column) indices. +C +C INFE (output) INTEGER array, dimension (1+MIN(L+P,N+M)) +C The leading NINFE elements of INFE contain the +C multiplicities of infinite eigenvalues. +C +C KRONL (output) INTEGER array, dimension (L+P+1) +C The leading NKROL elements of this array contain the +C left Kronecker (row) indices. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C If the user sets TOL <= 0, then default tolerances are +C used instead, as follows: TOLDEF = L*N*EPS in TG01FZ +C (to determine the rank of E) and TOLDEF = (L+P)*(N+M)*EPS +C in the rest, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH). TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension N+max(1,M) +C On output, IWORK(1) contains the normal rank of the +C transfer function matrix. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C LDWORK >= max(4*(L+N), 2*max(L+P,M+N))), if EQUIL = 'S', +C LDWORK >= 2*max(L+P,M+N)), if EQUIL = 'N'. +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C On exit, if INFO = 0, ZWORK(1) returns the optimal value +C of LZWORK. +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK >= max( max(L+P,M+N)*(M+N) + +C max(min(L+P,M+N) + max(min(L,N),3*(M+N)-1), +C 3*(L+P), 1)) +C For optimum performance LZWORK should be larger. +C +C If LZWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C ZWORK array, returns this value as the first entry of +C the ZWORK array, and no error message related to LZWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine extracts from the system matrix of a descriptor +C system (A-lambda*E,B,C,D) a regular pencil Af-lambda*Ef which +C has the finite zeros of the system as generalized eigenvalues. +C The procedure has the following main computational steps: +C +C (a) construct the (L+P)-by-(N+M) system pencil +C +C S(lambda) = ( B A )-lambda*( 0 E ); +C ( D C ) ( 0 0 ) +C +C (b) reduce S(lambda) to S1(lambda) with the same finite +C zeros and right Kronecker structure but with E +C upper triangular and nonsingular; +C +C (c) reduce S1(lambda) to S2(lambda) with the same finite +C zeros and right Kronecker structure but with D of +C full row rank; +C +C (d) reduce S2(lambda) to S3(lambda) with the same finite zeros +C and with D square invertible; +C +C (e) perform a unitary transformation on the columns of +C +C S3(lambda) = (A-lambda*E B) in order to reduce it to +C ( C D) +C +C (Af-lambda*Ef X), with Y and Ef square invertible; +C ( 0 Y) +C +C (f) compute the right and left Kronecker indices of the system +C matrix, which together with the multiplicities of the +C finite and infinite eigenvalues constitute the +C complete set of structural invariants under strict +C equivalence transformations of a linear system. +C +C REFERENCES +C +C [1] P. Misra, P. Van Dooren and A. Varga. +C Computation of structural invariants of generalized +C state-space systems. +C Automatica, 30, pp. 1921-1936, 1994. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable (see [1]). +C +C FURTHER COMMENTS +C +C In order to compute the finite Smith zeros of the system +C explicitly, a call to this routine may be followed by a +C call to the LAPACK Library routines ZGEGV or ZGGEV. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, +C May 1999. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2009, +C Apr. 2009. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, unitary transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) +C .. Scalar Arguments .. + CHARACTER EQUIL + INTEGER DINFZ, INFO, L, LDA, LDB, LDC, LDD, LDE, LZWORK, + $ M, N, NFZ, NINFE, NIZ, NKROL, NKROR, NRANK, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER INFE(*), INFZ(*), IWORK(*), KRONL(*), KRONR(*) + DOUBLE PRECISION DWORK(*) + COMPLEX*16 A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ E(LDE,*), ZWORK(*) +C .. Local Scalars .. + LOGICAL LEQUIL, LQUERY + INTEGER I, I0, I1, II, IPD, ITAU, J, JWORK, KABCD, + $ LABCD2, LDABCD, LZW, MM, MU, N2, NB, NN, NSINFE, + $ NU, NUMU, PP, WRKOPT + DOUBLE PRECISION SVLMAX, TOLER +C .. Local Arrays .. + COMPLEX*16 DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL DLAMCH, ILAENV, LSAME, ZLANGE +C .. External Subroutines .. + EXTERNAL AG8BYZ, MA02BZ, MA02CZ, TB01XZ, TG01AZ, TG01FZ, + $ XERBLA, ZLACPY, ZLASET, ZTZRZF, ZUNMRZ +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LDABCD = MAX( L+P, N+M ) + LABCD2 = LDABCD*( N+M ) + LEQUIL = LSAME( EQUIL, 'S' ) + LQUERY = ( LZWORK.EQ.-1 ) +C +C Test the input scalar arguments. +C + IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -1 + ELSE IF( L.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -7 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -27 + ELSE + I0 = MIN( L+P, M+N ) + I1 = MIN( L, N ) + II = MIN( M, P ) + LZW = MAX( 1, LABCD2 + MAX( I0 + MAX( I1, 3*( M+N ) - 1 ), + $ 3*( L+P ) ) ) + IF( LQUERY ) THEN + CALL TG01FZ( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, + $ LDB, C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, + $ IWORK, DWORK, ZWORK, -1, INFO ) + WRKOPT = MAX( LZW, INT( ZWORK(1) ) ) + SVLMAX = ZERO + CALL AG8BYZ( .TRUE., I1, M+N, P+L, SVLMAX, ZWORK, LDABCD+I1, + $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, + $ TOL, IWORK, DWORK, ZWORK, -1, INFO ) + WRKOPT = MAX( WRKOPT, LABCD2 + INT( ZWORK(1) ) ) + CALL AG8BYZ( .FALSE., I1, II, M+N, SVLMAX, ZWORK, LDABCD+I1, + $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, + $ TOL, IWORK, DWORK, ZWORK, -1, INFO ) + WRKOPT = MAX( WRKOPT, LABCD2 + INT( ZWORK(1) ) ) + NB = ILAENV( 1, 'ZGERQF', ' ', II, I1+II, -1, -1 ) + WRKOPT = MAX( WRKOPT, LABCD2 + II + II*NB ) + NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', I1, I1+II, II, + $ -1 ) ) + WRKOPT = MAX( WRKOPT, LABCD2 + II + I1*NB ) + ELSE IF( LZWORK.LT.LZW ) THEN + INFO = -31 + END IF + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AG08BZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + ZWORK(1) = WRKOPT + RETURN + END IF +C + NIZ = 0 + NKROL = 0 + NKROR = 0 +C +C Quick return if possible. +C + IF( MAX( L, N, M, P ).EQ.0 ) THEN + NFZ = 0 + DINFZ = 0 + NINFE = 0 + NRANK = 0 + IWORK(1) = 0 + ZWORK(1) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "CWorkspace:", "RWorkspace:" +C and "IWorkspace:" describe the minimal amount of complex, real and +C integer workspace, respectively, needed at that point in the code, +C as well as the preferred amount for good performance.) +C + WRKOPT = 1 + KABCD = 1 + JWORK = KABCD + LABCD2 +C +C If required, balance the system pencil. +C RWorkspace: need 4*(L+N). +C + IF( LEQUIL ) THEN + CALL TG01AZ( 'A', L, N, M, P, ZERO, A, LDA, E, LDE, B, LDB, + $ C, LDC, DWORK, DWORK(L+1), DWORK(L+N+1), INFO ) + END IF + SVLMAX = ZLANGE( 'Frobenius', L, N, E, LDE, DWORK ) +C +C Reduce the system matrix to QR form, +C +C ( A11-lambda*E11 A12 B1 ) +C ( A21 A22 B2 ) , +C ( C1 C2 D ) +C +C with E11 invertible and upper triangular. +C IWorkspace: need N. +C RWorkspace: need 2*N. +C CWorkspace: need max( 1, N+P, min(L,N)+max(3*N-1,M,L) ); +C prefer larger. +C + CALL TG01FZ( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, LDB, + $ C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, IWORK, DWORK, + $ ZWORK, LZWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) +C +C Construct the system pencil +C +C MM NN +C ( B1 A12 A11-lambda*E11 ) NN +C S1(lambda) = ( B2 A22 A21 ) L-NN +C ( D C2 C1 ) P +C +C of dimension (L+P)-by-(M+N). +C CWorkspace: need LABCD2 = max( L+P, N+M )*( N+M ). +C + N2 = N - NN + MM = M + N2 + PP = P + ( L - NN ) + CALL ZLACPY( 'Full', L, M, B, LDB, ZWORK(KABCD), LDABCD ) + CALL ZLACPY( 'Full', P, M, D, LDD, ZWORK(KABCD+L), LDABCD ) + CALL ZLACPY( 'Full', L, N2, A(1,NN+1), LDA, + $ ZWORK(KABCD+LDABCD*M), LDABCD ) + CALL ZLACPY( 'Full', P, N2, C(1,NN+1), LDC, + $ ZWORK(KABCD+LDABCD*M+L), LDABCD ) + CALL ZLACPY( 'Full', L, NN, A, LDA, + $ ZWORK(KABCD+LDABCD*MM), LDABCD ) + CALL ZLACPY( 'Full', P, NN, C, LDC, + $ ZWORK(KABCD+LDABCD*MM+L), LDABCD ) +C +C If required, set tolerance. +C + TOLER = TOL + IF( TOLER.LE.ZERO ) THEN + TOLER = DBLE( ( L + P )*( M + N ) ) * DLAMCH( 'Precision' ) + END IF + SVLMAX = MAX( SVLMAX, + $ ZLANGE( 'Frobenius', NN+PP, NN+MM, ZWORK(KABCD), + $ LDABCD, DWORK ) ) +C +C Extract the reduced pencil S2(lambda) +C +C ( Bc Ac-lambda*Ec ) +C ( Dc Cc ) +C +C having the same finite Smith zeros as the system pencil +C S(lambda) but with Dc, a MU-by-MM full row rank +C left upper trapezoidal matrix, and Ec, an NU-by-NU +C upper triangular nonsingular matrix. +C +C IWorkspace: need MM, MM <= M+N; +C RWorkspace: need 2*max(MM,PP); PP <= P+L; +C CWorkspace: need max( min(P+L,M+N)+max(min(L,N),3*(M+N)-1), +C 3*(P+L), 1 ) + LABCD2; +C prefer larger. +C + CALL AG8BYZ( .TRUE., NN, MM, PP, SVLMAX, ZWORK(KABCD), LDABCD, + $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, + $ TOLER, IWORK, DWORK, ZWORK(JWORK), LZWORK-JWORK+1, + $ INFO ) +C + WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) +C +C Set the number of simple (nondynamic) infinite eigenvalues +C and the normal rank of the system pencil. +C + NSINFE = MU + NRANK = NN + MU +C +C Pertranspose the system. +C + CALL TB01XZ( 'D', NU, MM, MM, MAX( 0, NU-1 ), MAX( 0, NU-1 ), + $ ZWORK(KABCD+LDABCD*MM), LDABCD, + $ ZWORK(KABCD), LDABCD, + $ ZWORK(KABCD+LDABCD*MM+NU), LDABCD, + $ ZWORK(KABCD+NU), LDABCD, INFO ) + CALL MA02BZ( 'Right', NU+MM, MM, ZWORK(KABCD), LDABCD ) + CALL MA02BZ( 'Left', MM, NU+MM, ZWORK(KABCD+NU), LDABCD ) + CALL MA02CZ( NU, 0, MAX( 0, NU-1 ), E, LDE ) +C + IF( MU.NE.MM ) THEN + NN = NU + PP = MM + MM = MU + KABCD = KABCD + ( PP - MM )*LDABCD +C +C Extract the reduced pencil S3(lambda), +C +C ( Br Ar-lambda*Er ) , +C ( Dr Cr ) +C +C having the same finite Smith zeros as the pencil S(lambda), +C but with Dr, an MU-by-MU invertible upper triangular matrix, +C and Er, an NU-by-NU upper triangular nonsingular matrix. +C +C IWorkspace: need 0; +C RWorkspace: need 2*(M+N); +C CWorkspace: need max( 1, 3*(M+N) ) + LABCD2. +C prefer larger. +C + CALL AG8BYZ( .FALSE., NN, MM, PP, SVLMAX, ZWORK(KABCD), LDABCD, + $ E, LDE, NU, MU, I0, I1, NKROR, IWORK, KRONR, + $ TOLER, IWORK, DWORK, ZWORK(JWORK), LZWORK-JWORK+1, + $ INFO ) +C + WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) + END IF +C + IF( NU.NE.0 ) THEN +C +C Perform a unitary transformation on the columns of +C ( Br Ar-lambda*Er ) +C ( Dr Cr ) +C in order to reduce it to +C ( * Af-lambda*Ef ) +C ( Y 0 ) +C with Y and Ef square invertible. +C +C Compute Af by reducing ( Br Ar ) to ( * Af ) . +C ( Dr Cr ) ( Y 0 ) +C + NUMU = NU + MU + IPD = KABCD + NU + ITAU = JWORK + JWORK = ITAU + MU +C +C CWorkspace: need LABCD2 + 2*min(M,P); +C prefer LABCD2 + min(M,P) + min(M,P)*NB. +C + CALL ZTZRZF( MU, NUMU, ZWORK(IPD), LDABCD, ZWORK(ITAU), + $ ZWORK(JWORK), LZWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) +C +C CWorkspace: need LABCD2 + min(M,P) + min(L,N); +C prefer LABCD2 + min(M,P) + min(L,N)*NB. +C + CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, NUMU, MU, NU, + $ ZWORK(IPD), LDABCD, ZWORK(ITAU), ZWORK(KABCD), + $ LDABCD, ZWORK(JWORK), LZWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) +C +C Save Af. +C + CALL ZLACPY( 'Full', NU, NU, ZWORK(KABCD+LDABCD*MU), LDABCD, A, + $ LDA ) +C +C Compute Ef by applying the saved transformations from previous +C reduction to ( 0 Er ) . +C + CALL ZLASET( 'Full', NU, MU, CZERO, CZERO, ZWORK(KABCD), + $ LDABCD ) + CALL ZLACPY( 'Full', NU, NU, E, LDE, ZWORK(KABCD+LDABCD*MU), + $ LDABCD ) +C + CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, NUMU, MU, NU, + $ ZWORK(IPD), LDABCD, ZWORK(ITAU), ZWORK(KABCD), + $ LDABCD, ZWORK(JWORK), LZWORK-JWORK+1, INFO ) +C +C Save Ef. +C + CALL ZLACPY( 'Full', NU, NU, ZWORK(KABCD+LDABCD*MU), LDABCD, E, + $ LDE ) + END IF +C + NFZ = NU +C +C Set right Kronecker indices (column indices). +C + DO 10 I = 1, NKROR + IWORK(I) = KRONR(I) + 10 CONTINUE +C + J = 0 + DO 30 I = 1, NKROR + DO 20 II = J + 1, J + IWORK(I) + KRONR(II) = I - 1 + 20 CONTINUE + J = J + IWORK(I) + 30 CONTINUE +C + NKROR = J +C +C Set left Kronecker indices (row indices). +C + DO 40 I = 1, NKROL + IWORK(I) = KRONL(I) + 40 CONTINUE +C + J = 0 + DO 60 I = 1, NKROL + DO 50 II = J + 1, J + IWORK(I) + KRONL(II) = I - 1 + 50 CONTINUE + J = J + IWORK(I) + 60 CONTINUE +C + NKROL = J +C +C Determine the number of simple infinite blocks +C as the difference between the number of infinite blocks +C of order greater than one and the order of Dr. +C + NINFE = 0 + DO 70 I = 1, DINFZ + NINFE = NINFE + INFZ(I) + 70 CONTINUE + NINFE = NSINFE - NINFE + DO 80 I = 1, NINFE + INFE(I) = 1 + 80 CONTINUE +C +C Set the structure of infinite eigenvalues. +C + DO 100 I = 1, DINFZ + DO 90 II = NINFE + 1, NINFE + INFZ(I) + INFE(II) = I + 1 + 90 CONTINUE + NINFE = NINFE + INFZ(I) + 100 CONTINUE +C + IWORK(1) = NSINFE + ZWORK(1) = WRKOPT + RETURN +C *** Last line of AG08BZ *** + END diff --git a/mex/sources/libslicot/AG8BYZ.f b/mex/sources/libslicot/AG8BYZ.f new file mode 100644 index 000000000..c2dc7d5e4 --- /dev/null +++ b/mex/sources/libslicot/AG8BYZ.f @@ -0,0 +1,692 @@ + SUBROUTINE AG8BYZ( FIRST, N, M, P, SVLMAX, ABCD, LDABCD, E, LDE, + $ NR, PR, NINFZ, DINFZ, NKRONL, INFZ, KRONL, + $ TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To extract from the (N+P)-by-(M+N) descriptor system pencil +C +C S(lambda) = ( B A - lambda*E ) +C ( D C ) +C +C with E nonsingular and upper triangular a +C (NR+PR)-by-(M+NR) "reduced" descriptor system pencil +C +C ( Br Ar-lambda*Er ) +C Sr(lambda) = ( ) +C ( Dr Cr ) +C +C having the same finite Smith zeros as the pencil +C S(lambda) but with Dr, a PR-by-M full row rank +C left upper trapezoidal matrix, and Er, an NR-by-NR +C upper triangular nonsingular matrix. +C +C ARGUMENTS +C +C Mode Parameters +C +C FIRST LOGICAL +C Specifies if AG8BYZ is called first time or it is called +C for an already reduced system, with D full column rank +C with the last M rows in upper triangular form: +C FIRST = .TRUE., first time called; +C FIRST = .FALSE., not first time called. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of rows of matrix B, the number of columns of +C matrix C and the order of square matrices A and E. +C N >= 0. +C +C M (input) INTEGER +C The number of columns of matrices B and D. M >= 0. +C M <= P if FIRST = .FALSE. . +C +C P (input) INTEGER +C The number of rows of matrices C and D. P >= 0. +C +C SVLMAX (input) DOUBLE PRECISION +C During each reduction step, the rank-revealing QR +C factorization of a matrix stops when the estimated minimum +C singular value is smaller than TOL * MAX(SVLMAX,EMSV), +C where EMSV is the estimated maximum singular value. +C SVLMAX >= 0. +C +C ABCD (input/output) COMPLEX*16 array, dimension (LDABCD,M+N) +C On entry, the leading (N+P)-by-(M+N) part of this array +C must contain the compound matrix +C ( B A ) , +C ( D C ) +C where A is an N-by-N matrix, B is an N-by-M matrix, +C C is a P-by-N matrix and D is a P-by-M matrix. +C If FIRST = .FALSE., then D must be a full column +C rank matrix with the last M rows in upper triangular form. +C On exit, the leading (NR+PR)-by-(M+NR) part of ABCD +C contains the reduced compound matrix +C ( Br Ar ) , +C ( Dr Cr ) +C where Ar is an NR-by-NR matrix, Br is an NR-by-M matrix, +C Cr is a PR-by-NR matrix, Dr is a PR-by-M full row rank +C left upper trapezoidal matrix with the first PR columns +C in upper triangular form. +C +C LDABCD INTEGER +C The leading dimension of array ABCD. +C LDABCD >= MAX(1,N+P). +C +C E (input/output) COMPLEX*16 array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the upper triangular nonsingular matrix E. +C On exit, the leading NR-by-NR part contains the reduced +C upper triangular nonsingular matrix Er. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C NR (output) INTEGER +C The order of the reduced matrices Ar and Er; also the +C number of rows of the reduced matrix Br and the number +C of columns of the reduced matrix Cr. +C If Dr is invertible, NR is also the number of finite +C Smith zeros. +C +C PR (output) INTEGER +C The rank of the resulting matrix Dr; also the number of +C rows of reduced matrices Cr and Dr. +C +C NINFZ (output) INTEGER +C Number of infinite zeros. NINFZ = 0 if FIRST = .FALSE. . +C +C DINFZ (output) INTEGER +C The maximal multiplicity of infinite zeros. +C DINFZ = 0 if FIRST = .FALSE. . +C +C NKRONL (output) INTEGER +C The maximal dimension of left elementary Kronecker blocks. +C +C INFZ (output) INTEGER array, dimension (N) +C INFZ(i) contains the number of infinite zeros of +C degree i, where i = 1,2,...,DINFZ. +C INFZ is not referenced if FIRST = .FALSE. . +C +C KRONL (output) INTEGER array, dimension (N+1) +C KRONL(i) contains the number of left elementary Kronecker +C blocks of dimension i-by-(i-1), where i = 1,2,...,NKRONL. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C If the user sets TOL <= 0, then an implicitly computed, +C default tolerance TOLDEF = (N+P)*(N+M)*EPS, is used +C instead, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH). +C NOTE that when SVLMAX > 0, the estimated ranks could be +C less than those defined above (see SVLMAX). TOL <= 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C If FIRST = .FALSE., IWORK is not referenced. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C LDWORK >= 2*MAX(M,P), if FIRST = .TRUE.; +C LDWORK >= 2*P, if FIRST = .FALSE. . +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C On exit, if INFO = 0, ZWORK(1) returns the optimal value +C of LZWORK. +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK >= 1, if P = 0; otherwise +C LZWORK >= MAX( 1, N+M-1, MIN(P,M) + MAX(3*M-1,N), 3*P ), +C if FIRST = .TRUE.; +C LZWORK >= MAX( 1, N+M-1, 3*P ), if FIRST = .FALSE. . +C The second term is not needed if M = 0. +C For optimum performance LZWORK should be larger. +C +C If LZWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C ZWORK array, returns this value as the first entry of +C the ZWORK array, and no error message related to LZWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The subroutine is based on the reduction algorithm of [1]. +C +C REFERENCES +C +C [1] P. Misra, P. Van Dooren and A. Varga. +C Computation of structural invariants of generalized +C state-space systems. +C Automatica, 30, pp. 1921-1936, 1994. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( (P+N)*(M+N)*N ) floating point operations. +C +C FURTHER COMMENTS +C +C The number of infinite zeros is computed as +C +C DINFZ +C NINFZ = Sum (INFZ(i)*i) . +C i=1 +C Note that each infinite zero of multiplicity k corresponds to +C an infinite eigenvalue of multiplicity k+1. +C The multiplicities of the infinite eigenvalues can be determined +C from PR, DINFZ and INFZ(i), i = 1, ..., DINFZ, as follows: +C +C DINFZ +C - there are PR - Sum (INFZ(i)) simple infinite eigenvalues; +C i=1 +C +C - there are INFZ(i) infinite eigenvalues with multiplicity i+1, +C for i = 1, ..., DINFZ. +C +C The left Kronecker indices are: +C +C [ 0 0 ... 0 | 1 1 ... 1 | .... | NKRONL ... NKRONL ] +C |<- KRONL(1) ->|<- KRONL(2) ->| |<- KRONL(NKRONL) ->| +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C May 1999. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, unitary transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ONE, P05, ZERO + PARAMETER ( ONE = 1.0D0, P05 = 0.05D0, ZERO = 0.0D0 ) + COMPLEX*16 CONE, CZERO + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), + $ CZERO = ( 0.0D+0, 0.0D+0 ) ) +C .. Scalar Arguments .. + INTEGER DINFZ, INFO, LDABCD, LDE, LZWORK, M, N, NINFZ, + $ NKRONL, NR, P, PR + DOUBLE PRECISION SVLMAX, TOL + LOGICAL FIRST +C .. Array Arguments .. + INTEGER INFZ( * ), IWORK(*), KRONL( * ) + DOUBLE PRECISION DWORK( * ) + COMPLEX*16 ABCD( LDABCD, * ), E( LDE, * ), ZWORK( * ) +C .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, ICOL, ILAST, IRC, IROW, ISMAX, ISMIN, ITAU, + $ J, JLAST, JWORK1, JWORK2, K, MN, MN1, MNR, + $ MNTAU, MP1, MPM, MUI, MUIM1, N1, NB, NBLCKS, + $ PN, RANK, RO, RO1, SIGMA, TAUI, WRKOPT + DOUBLE PRECISION C, RCOND, SMAX, SMAXPR, SMIN, SMINPR, T, TT + COMPLEX*16 C1, C2, S, S1, S2, TC +C .. Local Arrays .. + DOUBLE PRECISION SVAL(3) + COMPLEX*16 DUM(1) +C .. External Functions .. + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DZNRM2 + EXTERNAL DLAMCH, DZNRM2, IDAMAX, ILAENV +C .. External Subroutines .. + EXTERNAL MB3OYZ, XERBLA, ZCOPY, ZLAIC1, ZLAPMT, ZLARFG, + $ ZLARTG, ZLASET, ZLATZM, ZROT, ZSWAP, ZUNMQR +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C +C Test the input parameters. +C + LQUERY = ( LZWORK.EQ.-1 ) + INFO = 0 + PN = P + N + MN = M + N + MPM = MIN( P, M ) + IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 .OR. ( .NOT.FIRST .AND. M.GT.P ) ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -5 + ELSE IF( LDABCD.LT.MAX( 1, PN ) ) THEN + INFO = -7 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( TOL.GT.ONE ) THEN + INFO = -17 + ELSE + WRKOPT = MAX( 1, 3*P ) + IF( P.GT.0 ) THEN + IF( M.GT.0 ) THEN + WRKOPT = MAX( WRKOPT, MN-1 ) + IF( FIRST ) THEN + WRKOPT = MAX( WRKOPT, MPM + MAX( 3*M-1, N ) ) + IF( LQUERY ) THEN + NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', P, N, + $ MPM, -1 ) ) + WRKOPT = MAX( WRKOPT, MPM + MAX( 1, N )*NB ) + END IF + END IF + END IF + END IF + IF( LZWORK.LT.WRKOPT .AND. .NOT.LQUERY ) THEN + INFO = -21 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'AG8BYZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + ZWORK(1) = WRKOPT + RETURN + END IF +C +C Initialize output variables. +C + PR = P + NR = N + DINFZ = 0 + NINFZ = 0 + NKRONL = 0 +C +C Quick return if possible. +C + IF( P.EQ.0 ) THEN + ZWORK(1) = CONE + RETURN + END IF + IF( N.EQ.0 .AND. M.EQ.0 ) THEN + PR = 0 + NKRONL = 1 + KRONL(1) = P + ZWORK(1) = CONE + RETURN + END IF +C + RCOND = TOL + IF( RCOND.LE.ZERO ) THEN +C +C Use the default tolerance in rank determination. +C + RCOND = DBLE( PN*MN )*DLAMCH( 'EPSILON' ) + END IF +C +C The D matrix is (RO+SIGMA)-by-M, where RO = P - SIGMA and +C SIGMA = 0 for FIRST = .TRUE. and SIGMA = M for FIRST = .FALSE.. +C The leading (RO+SIGMA)-by-SIGMA submatrix of D has full column +C rank, with the trailing SIGMA-by-SIGMA submatrix upper triangular. +C + IF( FIRST ) THEN + SIGMA = 0 + ELSE + SIGMA = M + END IF + RO = P - SIGMA + MP1 = M + 1 + MUI = 0 + DUM(1) = CZERO +C + ITAU = 1 + JWORK1 = ITAU + MPM + ISMIN = 1 + ISMAX = ISMIN + P + JWORK2 = ISMAX + P + NBLCKS = 0 + WRKOPT = 1 +C + 10 IF( PR.EQ.0 ) GO TO 90 +C +C (NR+1,ICOL+1) points to the current position of matrix D. +C + RO1 = RO + MNR = M + NR + IF( M.GT.0 ) THEN +C +C Compress rows of D; first exploit the trapezoidal shape of the +C (RO+SIGMA)-by-SIGMA matrix in the first SIGMA columns of D; +C compress the first SIGMA columns without column pivoting: +C +C ( x x x x x ) ( x x x x x ) +C ( x x x x x ) ( 0 x x x x ) +C ( x x x x x ) - > ( 0 0 x x x ) +C ( 0 x x x x ) ( 0 0 0 x x ) +C ( 0 0 x x x ) ( 0 0 0 x x ) +C +C where SIGMA = 3 and RO = 2. +C Complex workspace: need maximum M+N-1. +C + IROW = NR + DO 20 ICOL = 1, SIGMA + IROW = IROW + 1 + CALL ZLARFG( RO+1, ABCD(IROW,ICOL), ABCD(IROW+1,ICOL), 1, + $ TC ) + CALL ZLATZM( 'L', RO+1, MNR-ICOL, ABCD(IROW+1,ICOL), 1, + $ DCONJG( TC ), ABCD(IROW,ICOL+1), + $ ABCD(IROW+1,ICOL+1), LDABCD, ZWORK ) + CALL ZCOPY( PR-ICOL, DUM, 0, ABCD(IROW+1,ICOL), 1 ) + 20 CONTINUE + WRKOPT = MAX( WRKOPT, MN - 1 ) +C + IF( FIRST ) THEN +C +C Continue with Householder with column pivoting. +C +C ( x x x x x ) ( x x x x x ) +C ( 0 x x x x ) ( 0 x x x x ) +C ( 0 0 x x x ) - > ( 0 0 x x x ) +C ( 0 0 0 x x ) ( 0 0 0 x x ) +C ( 0 0 0 x x ) ( 0 0 0 0 0 ) +C +C Real workspace: need maximum 2*M; +C Complex workspace: need maximum min(P,M)+3*M-1; +C Integer workspace: need maximum M. +C + IROW = MIN( NR+SIGMA+1, PN ) + ICOL = MIN( SIGMA+1, M ) + CALL MB3OYZ( RO1, M-SIGMA, ABCD(IROW,ICOL), LDABCD, + $ RCOND, SVLMAX, RANK, SVAL, IWORK, ZWORK(ITAU), + $ DWORK, ZWORK(JWORK1), INFO ) + WRKOPT = MAX( WRKOPT, JWORK1 + 3*M - 2 ) +C +C Apply the column permutations to B and part of D. +C + CALL ZLAPMT( .TRUE., NR+SIGMA, M-SIGMA, ABCD(1,ICOL), + $ LDABCD, IWORK ) +C + IF( RANK.GT.0 ) THEN +C +C Apply the Householder transformations to the submatrix C. +C Complex workspace: need maximum min(P,M) + N; +C prefer maximum min(P,M) + N*NB. +C + CALL ZUNMQR( 'Left', 'ConjTranspose', RO1, NR, RANK, + $ ABCD(IROW,ICOL), LDABCD, ZWORK(ITAU), + $ ABCD(IROW,MP1), LDABCD, ZWORK(JWORK1), + $ LZWORK-JWORK1+1, INFO ) + WRKOPT = MAX( WRKOPT, JWORK1 + INT( ZWORK(JWORK1) ) - 1 ) + CALL ZLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), CZERO, + $ CZERO, ABCD(MIN( IROW+1, PN ),ICOL), + $ LDABCD ) + RO1 = RO1 - RANK + END IF + END IF +C +C Terminate if Dr has maximal row rank. +C + IF( RO1.EQ.0 ) GO TO 90 +C + END IF +C +C Update SIGMA. +C + SIGMA = PR - RO1 +C + NBLCKS = NBLCKS + 1 + TAUI = RO1 +C +C Compress the columns of current C to separate a TAUI-by-MUI +C full column rank block. +C + IF( NR.EQ.0 ) THEN +C +C Finish for zero state dimension. +C + PR = SIGMA + RANK = 0 + ELSE +C +C Perform RQ-decomposition with row pivoting on the current C +C while keeping E upper triangular. +C The current C is the TAUI-by-NR matrix delimited by rows +C IRC+1 to IRC+TAUI and columns M+1 to M+NR of ABCD. +C The rank of current C is computed in MUI. +C Real workspace: need maximum 2*P; +C Complex workspace: need maximum 3*P. +C + IRC = NR + SIGMA + N1 = NR + IF( TAUI.GT.1 ) THEN +C +C Compute norms. +C + DO 30 I = 1, TAUI + DWORK(I) = DZNRM2( NR, ABCD(IRC+I,MP1), LDABCD ) + DWORK(P+I) = DWORK(I) + 30 CONTINUE + END IF +C + RANK = 0 + MNTAU = MIN( TAUI, NR ) +C +C ICOL and IROW will point to the current pivot position in C. +C + ILAST = NR + PR + JLAST = M + NR + IROW = ILAST + ICOL = JLAST + I = TAUI + 40 IF( RANK.LT.MNTAU ) THEN + MN1 = M + N1 +C +C Pivot if necessary. +C + IF( I.NE.1 ) THEN + J = IDAMAX( I, DWORK, 1 ) + IF( J.NE.I ) THEN + DWORK(J) = DWORK(I) + DWORK(P+J) = DWORK(P+I) + CALL ZSWAP( N1, ABCD(IROW,MP1), LDABCD, + $ ABCD(IRC+J,MP1), LDABCD ) + END IF + END IF +C +C Zero elements left to ABCD(IROW,ICOL). +C + DO 50 K = 1, N1-1 + J = M + K +C +C Rotate columns J, J+1 to zero ABCD(IROW,J). +C + TC = ABCD(IROW,J+1) + CALL ZLARTG( TC, ABCD(IROW,J), C, S, ABCD(IROW,J+1) ) + ABCD(IROW,J) = CZERO + CALL ZROT( IROW-1, ABCD(1,J+1), 1, ABCD(1,J), 1, C, S ) + CALL ZROT( K+1, E(1,K+1), 1, E(1,K), 1, C, S ) +C +C Rotate rows K, K+1 to zero E(K+1,K). +C + TC = E(K,K) + CALL ZLARTG( TC, E(K+1,K), C, S, E(K,K) ) + E(K+1,K) = CZERO + CALL ZROT( N1-K, E(K,K+1), LDE, E(K+1,K+1), LDE, C, S ) + CALL ZROT( MN1, ABCD(K,1), LDABCD, ABCD(K+1,1), LDABCD, + $ C, S ) + 50 CONTINUE +C + IF( RANK.EQ.0 ) THEN +C +C Initialize; exit if matrix is zero (RANK = 0). +C + SMAX = ABS( ABCD(ILAST,JLAST) ) + IF ( SMAX.EQ.ZERO ) GO TO 80 + SMIN = SMAX + SMAXPR = SMAX + SMINPR = SMIN + C1 = CONE + C2 = CONE + ELSE +C +C One step of incremental condition estimation. +C Complex workspace: need maximum 3*P. +C + CALL ZCOPY( RANK, ABCD(IROW,ICOL+1), LDABCD, + $ ZWORK(JWORK2), 1 ) + CALL ZLAIC1( IMIN, RANK, ZWORK(ISMIN), SMIN, + $ ZWORK(JWORK2), ABCD(IROW,ICOL), SMINPR, S1, + $ C1 ) + CALL ZLAIC1( IMAX, RANK, ZWORK(ISMAX), SMAX, + $ ZWORK(JWORK2), ABCD(IROW,ICOL), SMAXPR, S2, + $ C2 ) + WRKOPT = MAX( WRKOPT, 3*P ) + END IF +C +C Check the rank; finish the loop if rank loss occurs. +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN +C +C Finish the loop if last row. +C + IF( N1.EQ.0 ) THEN + RANK = RANK + 1 + GO TO 80 + END IF +C + IF( N1.GT.1 ) THEN +C +C Update norms. +C + IF( I-1.GT.1 ) THEN + DO 60 J = 1, I - 1 + IF( DWORK(J).NE.ZERO ) THEN + T = ONE - ( ABS( ABCD(IRC+J,ICOL) ) + $ /DWORK(J) )**2 + T = MAX( T, ZERO ) + TT = ONE + + $ P05*T*( DWORK(J)/DWORK(P+J) )**2 + IF( TT.NE.ONE ) THEN + DWORK(J) = DWORK(J)*SQRT( T ) + ELSE + DWORK(J) = DZNRM2( N1-1, + $ ABCD(IRC+J,MP1), LDABCD ) + DWORK(P+J) = DWORK(J) + END IF + END IF + 60 CONTINUE + END IF + END IF +C + DO 70 J = 1, RANK + ZWORK(ISMIN+J-1) = S1*ZWORK(ISMIN+J-1) + ZWORK(ISMAX+J-1) = S2*ZWORK(ISMAX+J-1) + 70 CONTINUE +C + ZWORK(ISMIN+RANK) = C1 + ZWORK(ISMAX+RANK) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + ICOL = ICOL - 1 + IROW = IROW - 1 + N1 = N1 - 1 + I = I - 1 + GO TO 40 + END IF + END IF + END IF + END IF + END IF +C + 80 CONTINUE + MUI = RANK + NR = NR - MUI + PR = SIGMA + MUI +C +C Set number of left Kronecker blocks of order (i-1)-by-i. +C + KRONL(NBLCKS) = TAUI - MUI +C +C Set number of infinite divisors of order i-1. +C + IF( FIRST .AND. NBLCKS.GT.1 ) + $ INFZ(NBLCKS-1) = MUIM1 - TAUI + MUIM1 = MUI + RO = MUI +C +C Continue reduction if rank of current C is positive. +C + IF( MUI.GT.0 ) + $ GO TO 10 +C +C Determine the maximal degree of infinite zeros and +C the number of infinite zeros. +C + 90 CONTINUE + IF( FIRST ) THEN + IF( MUI.EQ.0 ) THEN + DINFZ = MAX( 0, NBLCKS - 1 ) + ELSE + DINFZ = NBLCKS + INFZ(NBLCKS) = MUI + END IF + K = DINFZ + DO 100 I = K, 1, -1 + IF( INFZ(I).NE.0 ) GO TO 110 + DINFZ = DINFZ - 1 + 100 CONTINUE + 110 CONTINUE + DO 120 I = 1, DINFZ + NINFZ = NINFZ + INFZ(I)*I + 120 CONTINUE + END IF +C +C Determine the maximal order of left elementary Kronecker blocks. +C + NKRONL = NBLCKS + DO 130 I = NBLCKS, 1, -1 + IF( KRONL(I).NE.0 ) GO TO 140 + NKRONL = NKRONL - 1 + 130 CONTINUE + 140 CONTINUE +C + ZWORK(1) = WRKOPT + RETURN +C *** Last line of AG8BYZ *** + END diff --git a/mex/sources/libslicot/BB01AD.f b/mex/sources/libslicot/BB01AD.f new file mode 100644 index 000000000..8eafe1f32 --- /dev/null +++ b/mex/sources/libslicot/BB01AD.f @@ -0,0 +1,1286 @@ + SUBROUTINE BB01AD(DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P, + 1 A, LDA, B, LDB, C, LDC, G, LDG, Q, LDQ, X, LDX, + 2 DWORK, LDWORK, INFO) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate the benchmark examples for the numerical solution of +C continuous-time algebraic Riccati equations (CAREs) of the form +C +C 0 = Q + A'X + XA - XGX +C +C corresponding to the Hamiltonian matrix +C +C ( A G ) +C H = ( T ). +C ( Q -A ) +C +C A,G,Q,X are real N-by-N matrices, Q and G are symmetric and may +C be given in factored form +C +C -1 T T +C (I) G = B R B , (II) Q = C W C . +C +C Here, C is P-by-N, W P-by-P, B N-by-M, and R M-by-M, where W +C and R are symmetric. In linear-quadratic optimal control problems, +C usually W is positive semidefinite and R positive definite. The +C factorized form can be used if the CARE is solved using the +C deflating subspaces of the extended Hamiltonian pencil +C +C ( A 0 B ) ( I 0 0 ) +C ( T ) ( ) +C H - s K = ( Q A 0 ) - s ( 0 -I 0 ) , +C ( T ) ( ) +C ( 0 B R ) ( 0 0 0 ) +C +C where I and 0 denote the identity and zero matrix, respectively, +C of appropriate dimensions. +C +C NOTE: the formulation of the CARE and the related matrix (pencils) +C used here does not include CAREs as they arise in robust +C control (H_infinity optimization). +C +C ARGUMENTS +C +C Mode Parameters +C +C DEF CHARACTER +C This parameter specifies if the default parameters are +C to be used or not. +C = 'N' or 'n' : The parameters given in the input vectors +C xPAR (x = 'D', 'I', 'B', 'CH') are used. +C = 'D' or 'd' : The default parameters for the example +C are used. +C This parameter is not meaningful if NR(1) = 1. +C +C Input/Output Parameters +C +C NR (input) INTEGER array, dimension (2) +C This array determines the example for which CAREX returns +C data. NR(1) is the group of examples. +C NR(1) = 1 : parameter-free problems of fixed size. +C NR(1) = 2 : parameter-dependent problems of fixed size. +C NR(1) = 3 : parameter-free problems of scalable size. +C NR(1) = 4 : parameter-dependent problems of scalable size. +C NR(2) is the number of the example in group NR(1). +C Let NEXi be the number of examples in group i. Currently, +C NEX1 = 6, NEX2 = 9, NEX3 = 2, NEX4 = 4. +C 1 <= NR(1) <= 4; +C 1 <= NR(2) <= NEXi , where i = NR(1). +C +C DPAR (input/output) DOUBLE PRECISION array, dimension (7) +C Double precision parameter vector. For explanation of the +C parameters see [1]. +C DPAR(1) : defines the parameters +C 'delta' for NR(1) = 3, +C 'q' for NR(1).NR(2) = 4.1, +C 'a' for NR(1).NR(2) = 4.2, and +C 'mu' for NR(1).NR(2) = 4.3. +C DPAR(2) : defines parameters +C 'r' for NR(1).NR(2) = 4.1, +C 'b' for NR(1).NR(2) = 4.2, and +C 'delta' for NR(1).NR(2) = 4.3. +C DPAR(3) : defines parameters +C 'c' for NR(1).NR(2) = 4.2 and +C 'kappa' for NR(1).NR(2) = 4.3. +C DPAR(j), j=4,5,6,7: These arguments are only used to +C generate Example 4.2 and define in +C consecutive order the intervals +C ['beta_1', 'beta_2'], +C ['gamma_1', 'gamma_2']. +C NOTE that if DEF = 'D' or 'd', the values of DPAR entries +C on input are ignored and, on output, they are overwritten +C with the default parameters. +C +C IPAR (input/output) INTEGER array, dimension (3) +C On input, IPAR(1) determines the actual state dimension, +C i.e., the order of the matrix A as follows, where +C NO = NR(1).NR(2). +C NR(1) = 1 or 2.1-2.8: IPAR(1) is ignored. +C NO = 2.9 : IPAR(1) = 1 generates the CARE for +C optimal state feedback (default); +C IPAR(1) = 2 generates the Kalman +C filter CARE. +C NO = 3.1 : IPAR(1) is the number of vehicles +C (parameter 'l' in the description +C in [1]). +C NO = 3.2, 4.1 or 4.2: IPAR(1) is the order of the matrix +C A. +C NO = 4.3 or 4.4 : IPAR(1) determines the dimension of +C the second-order system, i.e., the +C order of the stiffness matrix for +C Examples 4.3 and 4.4 (parameter 'l' +C in the description in [1]). +C +C The order of the output matrix A is N = 2*IPAR(1) for +C Example 4.3 and N = 2*IPAR(1)-1 for Examples 3.1 and 4.4. +C NOTE that IPAR(1) is overwritten for Examples 1.1-2.8. For +C the other examples, IPAR(1) is overwritten if the default +C parameters are to be used. +C On output, IPAR(1) contains the order of the matrix A. +C +C On input, IPAR(2) is the number of colums in the matrix B +C in (I) (in control problems, the number of inputs of the +C system). Currently, IPAR(2) is fixed or determined by +C IPAR(1) for all examples and thus is not referenced on +C input. +C On output, IPAR(2) is the number of columns of the +C matrix B from (I). +C NOTE that currently IPAR(2) is overwritten and that +C rank(G) <= IPAR(2). +C +C On input, IPAR(3) is the number of rows in the matrix C +C in (II) (in control problems, the number of outputs of the +C system). Currently, IPAR(3) is fixed or determined by +C IPAR(1) for all examples and thus is not referenced on +C input. +C On output, IPAR(3) contains the number of rows of the +C matrix C in (II). +C NOTE that currently IPAR(3) is overwritten and that +C rank(Q) <= IPAR(3). +C +C BPAR (input) BOOLEAN array, dimension (6) +C This array defines the form of the output of the examples +C and the storage mode of the matrices G and Q. +C BPAR(1) = .TRUE. : G is returned. +C BPAR(1) = .FALSE. : G is returned in factored form, i.e., +C B and R from (I) are returned. +C BPAR(2) = .TRUE. : The matrix returned in array G (i.e., +C G if BPAR(1) = .TRUE. and R if +C BPAR(1) = .FALSE.) is stored as full +C matrix. +C BPAR(2) = .FALSE. : The matrix returned in array G is +C provided in packed storage mode. +C BPAR(3) = .TRUE. : If BPAR(2) = .FALSE., the matrix +C returned in array G is stored in upper +C packed mode, i.e., the upper triangle +C of a symmetric n-by-n matrix is stored +C by columns, e.g., the matrix entry +C G(i,j) is stored in the array entry +C G(i+j*(j-1)/2) for i <= j. +C Otherwise, this entry is ignored. +C BPAR(3) = .FALSE. : If BPAR(2) = .FALSE., the matrix +C returned in array G is stored in lower +C packed mode, i.e., the lower triangle +C of a symmetric n-by-n matrix is stored +C by columns, e.g., the matrix entry +C G(i,j) is stored in the array entry +C G(i+(2*n-j)*(j-1)/2) for j <= i. +C Otherwise, this entry is ignored. +C BPAR(4) = .TRUE. : Q is returned. +C BPAR(4) = .FALSE. : Q is returned in factored form, i.e., +C C and W from (II) are returned. +C BPAR(5) = .TRUE. : The matrix returned in array Q (i.e., +C Q if BPAR(4) = .TRUE. and W if +C BPAR(4) = .FALSE.) is stored as full +C matrix. +C BPAR(5) = .FALSE. : The matrix returned in array Q is +C provided in packed storage mode. +C BPAR(6) = .TRUE. : If BPAR(5) = .FALSE., the matrix +C returned in array Q is stored in upper +C packed mode (see above). +C Otherwise, this entry is ignored. +C BPAR(6) = .FALSE. : If BPAR(5) = .FALSE., the matrix +C returned in array Q is stored in lower +C packed mode (see above). +C Otherwise, this entry is ignored. +C NOTE that there are no default values for BPAR. If all +C entries are declared to be .TRUE., then matrices G and Q +C are returned in conventional storage mode, i.e., as +C N-by-N arrays where the array element Z(I,J) contains the +C matrix entry Z_{i,j}. +C +C CHPAR (input/output) CHARACTER*255 +C On input, this is the name of a data file supplied by the +C user. +C In the current version, only Example 4.4 allows a +C user-defined data file. This file must contain +C consecutively DOUBLE PRECISION vectors mu, delta, gamma, +C and kappa. The length of these vectors is determined by +C the input value for IPAR(1). +C If on entry, IPAR(1) = L, then mu and delta must each +C contain L DOUBLE PRECISION values, and gamma and kappa +C must each contain L-1 DOUBLE PRECISION values. +C On output, this string contains short information about +C the chosen example. +C +C VEC (output) LOGICAL array, dimension (9) +C Flag vector which displays the availability of the output +C data: +C VEC(j), j=1,2,3, refer to N, M, and P, respectively, and +C are always .TRUE. +C VEC(4) refers to A and is always .TRUE. +C VEC(5) is .TRUE. if BPAR(1) = .FALSE., i.e., the factors B +C and R from (I) are returned. +C VEC(6) is .TRUE. if BPAR(4) = .FALSE., i.e., the factors C +C and W from (II) are returned. +C VEC(7) refers to G and is always .TRUE. +C VEC(8) refers to Q and is always .TRUE. +C VEC(9) refers to X and is .TRUE. if the exact solution +C matrix is available. +C NOTE that VEC(i) = .FALSE. for i = 1 to 9 if on exit +C INFO .NE. 0. +C +C N (output) INTEGER +C The order of the matrices A, X, G if BPAR(1) = .TRUE., and +C Q if BPAR(4) = .TRUE. +C +C M (output) INTEGER +C The number of columns in the matrix B (or the dimension of +C the control input space of the underlying dynamical +C system). +C +C P (output) INTEGER +C The number of rows in the matrix C (or the dimension of +C the output space of the underlying dynamical system). +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the +C coefficient matrix A of the CARE. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C If (BPAR(1) = .FALSE.), then the leading N-by-M part of +C this array contains the matrix B of the factored form (I) +C of G. Otherwise, B is used as workspace. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= N. +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C If (BPAR(4) = .FALSE.), then the leading P-by-N part of +C this array contains the matrix C of the factored form (II) +C of Q. Otherwise, C is used as workspace. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= P, where P is the number of rows of the matrix C, +C i.e., the output value of IPAR(3). (For all examples, +C P <= N, where N equals the output value of the argument +C IPAR(1), i.e., LDC >= LDA is always safe.) +C +C G (output) DOUBLE PRECISION array, dimension (NG) +C If (BPAR(2) = .TRUE.) then NG = LDG*N. +C If (BPAR(2) = .FALSE.) then NG = N*(N+1)/2. +C If (BPAR(1) = .TRUE.), then array G contains the +C coefficient matrix G of the CARE. +C If (BPAR(1) = .FALSE.), then array G contains the 'control +C weighting matrix' R of G's factored form as in (I). (For +C all examples, M <= N.) The symmetric matrix contained in +C array G is stored according to BPAR(2) and BPAR(3). +C +C LDG INTEGER +C If conventional storage mode is used for G, i.e., +C BPAR(2) = .TRUE., then G is stored like a 2-dimensional +C array with leading dimension LDG. If packed symmetric +C storage mode is used, then LDG is not referenced. +C LDG >= N if BPAR(2) = .TRUE.. +C +C Q (output) DOUBLE PRECISION array, dimension (NQ) +C If (BPAR(5) = .TRUE.) then NQ = LDQ*N. +C If (BPAR(5) = .FALSE.) then NQ = N*(N+1)/2. +C If (BPAR(4) = .TRUE.), then array Q contains the +C coefficient matrix Q of the CARE. +C If (BPAR(4) = .FALSE.), then array Q contains the 'output +C weighting matrix' W of Q's factored form as in (II). +C The symmetric matrix contained in array Q is stored +C according to BPAR(5) and BPAR(6). +C +C LDQ INTEGER +C If conventional storage mode is used for Q, i.e., +C BPAR(5) = .TRUE., then Q is stored like a 2-dimensional +C array with leading dimension LDQ. If packed symmetric +C storage mode is used, then LDQ is not referenced. +C LDQ >= N if BPAR(5) = .TRUE.. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,IPAR(1)) +C If an exact solution is available (NR = 1.1, 1.2, 2.1, +C 2.3-2.6, 3.2), then the leading N-by-N part of this array +C contains the solution matrix X in conventional storage +C mode. Otherwise, X is not referenced. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= 1, and +C LDX >= N if NR = 1.1, 1.2, 2.1, 2.3-2.6, 3.2. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= N*MAX(4,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0 : successful exit; +C < 0 : if INFO = -i, the i-th argument had an illegal +C value; +C = 1 : data file could not be opened or had wrong format; +C = 2 : division by zero; +C = 3 : G can not be computed as in (I) due to a singular R +C matrix. +C +C REFERENCES +C +C [1] Abels, J. and Benner, P. +C CAREX - A Collection of Benchmark Examples for Continuous-Time +C Algebraic Riccati Equations (Version 2.0). +C SLICOT Working Note 1999-14, November 1999. Available from +C http://www.win.tue.nl/niconet/NIC2/reports.html. +C +C This is an updated and extended version of +C +C [2] Benner, P., Laub, A.J., and Mehrmann, V. +C A Collection of Benchmark Examples for the Numerical Solution +C of Algebraic Riccati Equations I: Continuous-Time Case. +C Technical Report SPC 95_22, Fak. f. Mathematik, +C TU Chemnitz-Zwickau (Germany), October 1995. +C +C NUMERICAL ASPECTS +C +C If the original data as taken from the literature is given via +C matrices G and Q, but factored forms are requested as output, then +C these factors are obtained from Cholesky or LDL' decompositions of +C G and Q, i.e., the output data will be corrupted by roundoff +C errors. +C +C FURTHER COMMENTS +C +C Some benchmark examples read data from the data files provided +C with the collection. +C +C CONTRIBUTOR +C +C Peter Benner (Universitaet Bremen), November 15, 1999. +C +C For questions concerning the collection or for the submission of +C test examples, please send e-mail to benner@math.uni-bremen.de. +C +C REVISIONS +C +C 1999, December 23 (V. Sima). +C +C KEYWORDS +C +C Algebraic Riccati equation, Hamiltonian matrix. +C +C ****************************************************************** +C +C .. Parameters .. +C . # of examples available , # of examples with fixed size. . + INTEGER NEX1, NEX2, NEX3, NEX4, NMAX + PARAMETER ( NMAX = 9, NEX1 = 6, NEX2 = 9, NEX3 = 2, + 1 NEX4 = 4 ) + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, PI + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + 1 THREE = 3.0D0, FOUR = 4.0D0, + 2 PI = .3141592653589793D1 ) +C +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDG, LDQ, LDWORK, LDX, M, N, + $ P + CHARACTER DEF +C +C .. Array Arguments .. + INTEGER IPAR(3), NR(2) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DPAR(*), DWORK(*), + 1 G(*), Q(*), X(LDX,*) + CHARACTER CHPAR*255 + LOGICAL BPAR(6), VEC(9) +C +C .. Local Scalars .. + INTEGER GDIMM, I, IOS, ISYMM, J, K, L, MSYMM, NSYMM, POS, + 1 PSYMM, QDIMM + DOUBLE PRECISION APPIND, B1, B2, C1, C2, SUM, TEMP, TTEMP +C +C ..Local Arrays .. + INTEGER MDEF(2,NMAX), NDEF(4,NMAX), NEX(4), PDEF(2,NMAX) + DOUBLE PRECISION PARDEF(4,NMAX) + CHARACTER IDENT*4 + CHARACTER*255 NOTES(4,NMAX) +C +C .. External Functions .. +C . BLAS . + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C . LAPACK . + LOGICAL LSAME + DOUBLE PRECISION DLAPY2 + EXTERNAL LSAME, DLAPY2 +C +C .. External Subroutines .. +C . BLAS . + EXTERNAL DCOPY, DGEMV, DSCAL, DSPMV, DSPR, DSYMM, DSYRK +C . LAPACK . + EXTERNAL DLASET, DPPTRF, DPPTRI, DPTTRF, DPTTRS, XERBLA +C . SLICOT . + EXTERNAL MA02DD, MA02ED +C +C .. Intrinsic Functions .. + INTRINSIC COS, MAX, MIN, MOD, SQRT +C +C .. Data Statements .. +C . default values for dimensions . + DATA (NEX(I), I = 1, 4) /NEX1, NEX2, NEX3, NEX4/ + DATA (NDEF(1,I), I = 1, NEX1) /2, 2, 4, 8, 9, 30/ + DATA (NDEF(2,I), I = 1, NEX2) /2, 2, 2, 2, 2, 3, 4, 4, 55/ + DATA (NDEF(3,I), I = 1, NEX3) /20, 64/ + DATA (NDEF(4,I), I = 1, NEX4) /21, 100, 30, 211/ + DATA (MDEF(1,I), I = 1, NEX1) /1, 1, 2, 2, 3, 3/ + DATA (MDEF(2,I), I = 1, NEX2) /1, 2, 1, 2, 1, 3, 1, 1, 2/ + DATA (PDEF(1,I), I = 1, NEX1) /2, 2, 4, 8, 9, 5/ + DATA (PDEF(2,I), I = 1, NEX2) /1, 1, 2, 2, 2, 3, 2, 1, 10/ +C . default values for parameters . + DATA (PARDEF(1,I), I = 1, NEX1) /ZERO, ZERO, ZERO, ZERO, ZERO, + 1 ZERO/ + DATA (PARDEF(2,I), I = 1, NEX2) /.1D-5, .1D-7, .1D7, .1D-6, ZERO, + 1 .1D7, .1D-5, .1D-5, .1D1/ + DATA (PARDEF(3,I), I = 1, NEX3) /ZERO, ZERO/ + DATA (PARDEF(4,I), I = 1, NEX4) /ONE, .1D-1, FOUR, ZERO/ +C . comments on examples . + DATA (NOTES(1,I), I = 1, NEX1) / + 1'Laub 1979, Ex.1', 'Laub 1979, Ex.2: uncontrollable-unobservable d + 2ata', 'Beale/Shafai 1989: model of L-1011 aircraft', 'Bhattacharyy + 3a et al. 1983: binary distillation column', 'Patnaik et al. 1980: + 4tubular ammonia reactor', 'Davison/Gesing 1978: J-100 jet engine'/ + DATA (NOTES(2,I), I = 1, NEX2) / + 1'Arnold/Laub 1984, Ex.1: (A,B) unstabilizable as EPS -> 0', 'Arnol + 2d/Laub 1984, Ex.3: control weighting matrix singular as EPS -> 0', + 3'Kenney/Laub/Wette 1989, Ex.2: ARE ill conditioned for EPS -> oo', + 4'Bai/Qian 1994: ill-conditioned Hamiltonian for EPS -> 0', 'Laub 1 + 5992: H-infinity problem, eigenvalues +/- EPS +/- i', 'Petkov et a + 6l. 1987: increasingly badly scaled Hamiltonian as EPS -> oo', 'Cho + 7w/Kokotovic 1976: magnetic tape control system', 'Arnold/Laub 1984 + 8, Ex.2: poor sep. of closed-loop spectrum as EPS -> 0', 'IFAC Benc + 9hmark Problem #90-06: LQG design for modified Boing B-767 at flutt + 1er condition'/ + DATA (NOTES(3,I), I = 1, NEX3) / + 1'Laub 1979, Ex.4: string of high speed vehicles', 'Laub 1979, Ex.5 + 2: circulant matrices'/ + DATA (NOTES(4,I), I = 1, NEX4) / + 1'Laub 1979, Ex.6: ill-conditioned Riccati equation', 'Rosen/Wang 1 + 2992: lq control of 1-dimensional heat flow','Hench et al. 1995: co + 3upled springs, dashpots and masses','Lang/Penzl 1994: rotating axl + 4e' / +C +C .. Executable Statements .. +C + INFO = 0 + DO 5 I = 1, 9 + VEC(I) = .FALSE. + 5 CONTINUE +C + IF ((NR(1) .NE. 1) .AND. (.NOT. (LSAME(DEF,'N') + 1 .OR. LSAME(DEF,'D')))) THEN + INFO = -1 + ELSE IF ((NR(1) .LT. 1) .OR. (NR(2) .LT. 1) .OR. + 1 (NR(1) .GT. 4) .OR. (NR(2) .GT. NEX(NR(1)))) THEN + INFO = -2 + ELSE IF (NR(1) .GT. 2) THEN + IF (.NOT. LSAME(DEF,'N')) IPAR(1) = NDEF(NR(1),NR(2)) + IF (NR(1) .EQ. 3) THEN + IF (NR(2) .EQ. 1) THEN + IPAR(2) = IPAR(1) + IPAR(3) = IPAR(1) - 1 + IPAR(1) = 2*IPAR(1) - 1 + ELSE IF (NR(2) .EQ. 2) THEN + IPAR(2) = IPAR(1) + IPAR(3) = IPAR(1) + ELSE + IPAR(2) = 1 + IPAR(3) = 1 + END IF + ELSE IF (NR(1) .EQ. 4) THEN + IF (NR(2) .EQ. 3) THEN + L = IPAR(1) + IPAR(2) = 2 + IPAR(3) = 2*L + IPAR(1) = 2*L + ELSE IF (NR(2) .EQ. 4) THEN + L = IPAR(1) + IPAR(2) = L + IPAR(3) = L + IPAR(1) = 2*L-1 + ELSE + IPAR(2) = 1 + IPAR(3) = 1 + END IF + END IF + ELSE IF ((NR(1) .EQ. 2) .AND. (NR(2) .EQ. 9) .AND. + 1 (IPAR(1) . EQ. 2)) THEN + IPAR(1) = NDEF(NR(1),NR(2)) + IPAR(2) = MDEF(NR(1),NR(2)) + IPAR(3) = 3 + ELSE + IPAR(1) = NDEF(NR(1),NR(2)) + IPAR(2) = MDEF(NR(1),NR(2)) + IPAR(3) = PDEF(NR(1),NR(2)) + END IF + IF (INFO .NE. 0) GOTO 7 +C + IF (IPAR(1) .LT. 1) THEN + INFO = -4 + ELSE IF (IPAR(1) .GT. LDA) THEN + INFO = -12 + ELSE IF (IPAR(1) .GT. LDB) THEN + INFO = -14 + ELSE IF (IPAR(3) .GT. LDC) THEN + INFO = -16 + ELSE IF (BPAR(2) .AND. (IPAR(1).GT. LDG)) THEN + INFO = -18 + ELSE IF (BPAR(5) .AND. (IPAR(1).GT. LDQ)) THEN + INFO = -20 + ELSE IF (LDX.LT.1) THEN + INFO = -22 + ELSE IF ((NR(1) .EQ. 1) .AND. + $ ((NR(2) .EQ. 1) .OR. (NR(2) .EQ.2))) THEN + IF (IPAR(1) .GT. LDX) INFO = -22 + ELSE IF ((NR(1) .EQ. 2) .AND. (NR(2) .EQ. 1)) THEN + IF (IPAR(1) .GT. LDX) INFO = -22 + ELSE IF ((NR(1) .EQ. 2) .AND. ((NR(2) .GE. 3) .AND. + 1 (NR(2) .LE. 6))) THEN + IF (IPAR(1) .GT. LDX) INFO = -22 + ELSE IF ((NR(1) .EQ. 3) .AND. (NR(2) .EQ. 2)) THEN + IF (IPAR(1) .GT. LDX) INFO = -22 + ELSE IF (LDWORK .LT. N*(MAX(4,N))) THEN + INFO = -24 + END IF +C + 7 CONTINUE + IF (INFO .NE. 0) THEN + CALL XERBLA( 'BB01AD', -INFO ) + RETURN + END IF +C + NSYMM = (IPAR(1)*(IPAR(1)+1))/2 + MSYMM = (IPAR(2)*(IPAR(2)+1))/2 + PSYMM = (IPAR(3)*(IPAR(3)+1))/2 + IF (.NOT. LSAME(DEF,'N')) DPAR(1) = PARDEF(NR(1),NR(2)) +C + CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, A, LDA) + CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ZERO, B, LDB) + CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ZERO, C, LDC) + CALL DLASET('L', MSYMM, 1, ZERO, ZERO, G, 1) + CALL DLASET('L', PSYMM, 1, ZERO, ZERO, Q, 1) +C + IF (NR(1) .EQ. 1) THEN + IF (NR(2) .EQ. 1) THEN + A(1,2) = ONE + B(2,1) = ONE + Q(1) = ONE + Q(3) = TWO + IDENT = '0101' + CALL DLASET('A', IPAR(1), IPAR(1), ONE, TWO, X, LDX) +C + ELSE IF (NR(2) .EQ. 2) THEN + A(1,1) = FOUR + A(2,1) = -.45D1 + A(1,2) = THREE + A(2,2) = -.35D1 + CALL DLASET('A', IPAR(1), IPAR(2), -ONE, ONE, B, LDB) + Q(1) = 9.0D0 + Q(2) = 6.0D0 + Q(3) = FOUR + IDENT = '0101' + TEMP = ONE + SQRT(TWO) + CALL DLASET('A', IPAR(1), IPAR(1), 6.0D0*TEMP, FOUR*TEMP, X, + 1 LDX) + X(1,1) = 9.0D0*TEMP +C + ELSE IF ((NR(2) .GE. 3) .AND. (NR(2) .LE. 6)) THEN + WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') 'BB01', NR(1), '0', + 1 NR(2) , '.dat' + IF ((NR(2) .EQ. 3) .OR. (NR(2) .EQ. 4)) THEN + IDENT = '0101' + ELSE IF (NR(2) .EQ. 5) THEN + IDENT = '0111' + ELSE IF (NR(2) .EQ. 6) THEN + IDENT = '0011' + END IF + OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) + IF (IOS .NE. 0) THEN + INFO = 1 + ELSE IF (NR(2) .LE. 6) THEN + DO 10 I = 1, IPAR(1) + READ (1, FMT = *, IOSTAT = IOS) + 1 (A(I,J), J = 1, IPAR(1)) + IF (IOS .NE. 0) INFO = 1 + 10 CONTINUE + DO 20 I = 1, IPAR(1) + READ (1, FMT = *, IOSTAT = IOS) + 1 (B(I,J), J = 1, IPAR(2)) + IF (IOS .NE. 0) INFO = 1 + 20 CONTINUE + IF (NR(2) .LE. 4) THEN + DO 30 I = 1, IPAR(1) + POS = (I-1)*IPAR(1) + READ (1, FMT = *, IOSTAT = IOS) (DWORK(POS+J), + 1 J = 1,IPAR(1)) + 30 CONTINUE + IF (IOS .NE. 0) THEN + INFO = 1 + ELSE + CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), Q) + END IF + ELSE IF (NR(2) .EQ. 6) THEN + DO 35 I = 1, IPAR(3) + READ (1, FMT = *, IOSTAT = IOS) + 1 (C(I,J), J = 1, IPAR(1)) + IF (IOS .NE. 0) INFO = 1 + 35 CONTINUE + END IF + CLOSE(1) + END IF + END IF +C + ELSE IF (NR(1) .EQ. 2) THEN + IF (NR(2) .EQ. 1) THEN + A(1,1) = ONE + A(2,2) = -TWO + B(1,1) = DPAR(1) + CALL DLASET('U', IPAR(3), IPAR(1), ONE, ONE, C, LDC) + IDENT = '0011' + IF (DPAR(1) .NE. ZERO) THEN + TEMP = DLAPY2(ONE, DPAR(1)) + X(1,1) = (ONE + TEMP)/DPAR(1)/DPAR(1) + X(2,1) = ONE/(TWO + TEMP) + X(1,2) = X(2,1) + TTEMP = DPAR(1)*X(1,2) + TEMP = (ONE - TTEMP) * (ONE + TTEMP) + X(2,2) = TEMP / FOUR + ELSE + INFO = 2 + END IF +C + ELSE IF (NR(2) .EQ. 2) THEN + A(1,1) = -.1D0 + A(2,2) = -.2D-1 + B(1,1) = .1D0 + B(2,1) = .1D-2 + B(2,2) = .1D-1 + CALL DLASET('L', MSYMM, 1, ONE, ONE, G, MSYMM) + G(1) = G(1) + DPAR(1) + C(1,1) = .1D2 + C(1,2) = .1D3 + IDENT = '0010' +C + ELSE IF (NR(2) .EQ. 3) THEN + A(1,2) = DPAR(1) + B(2,1) = ONE + IDENT = '0111' + IF (DPAR(1) .NE. ZERO) THEN + TEMP = SQRT(ONE + TWO*DPAR(1)) + CALL DLASET('A', IPAR(1), IPAR(1), ONE, TEMP, X, LDX) + X(1,1) = X(1,1)/DPAR(1) + ELSE + INFO = 2 + END IF +C + ELSE IF (NR(2) .EQ. 4) THEN + TEMP = DPAR(1) + ONE + CALL DLASET('A', IPAR(1), IPAR(1), ONE, TEMP, A, LDA) + Q(1) = DPAR(1)**2 + Q(3) = Q(1) + IDENT = '1101' + X(1,1) = TWO*TEMP + SQRT(TWO)*(SQRT(TEMP**2 + ONE) + DPAR(1)) + X(1,1) = X(1,1)/TWO + X(2,2) = X(1,1) + TTEMP = X(1,1) - TEMP + IF (TTEMP .NE. ZERO) THEN + X(2,1) = X(1,1) / TTEMP + X(1,2) = X(2,1) + ELSE + INFO = 2 + END IF +C + ELSE IF (NR(2) .EQ. 5) THEN + A(1,1) = THREE - DPAR(1) + A(2,1) = FOUR + A(1,2) = ONE + A(2,2) = TWO - DPAR(1) + CALL DLASET('L', IPAR(1), IPAR(2), ONE, ONE, B, LDB) + Q(1) = FOUR*DPAR(1) - 11.0D0 + Q(2) = TWO*DPAR(1) - 5.0D0 + Q(3) = TWO*DPAR(1) - TWO + IDENT = '0101' + CALL DLASET('A', IPAR(1), IPAR(1), ONE, ONE, X, LDX) + X(1,1) = TWO +C + ELSE IF (NR(2) .EQ. 6) THEN + IF (DPAR(1) .NE. ZERO) THEN + A(1,1) = DPAR(1) + A(2,2) = DPAR(1)*TWO + A(3,3) = DPAR(1)*THREE +C .. set C = V .. + TEMP = TWO/THREE + CALL DLASET('A', IPAR(3), IPAR(1), -TEMP, ONE - TEMP, + 1 C, LDC) + CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, A, LDA, + 1 ZERO, DWORK, IPAR(1)) + CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, + 1 IPAR(1), ZERO, A, LDA) +C .. G = R ! .. + G(1) = DPAR(1) + G(4) = DPAR(1) + G(6) = DPAR(1) + Q(1) = ONE/DPAR(1) + Q(4) = ONE + Q(6) = DPAR(1) + IDENT = '1000' + CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, X, LDX) + TEMP = DPAR(1)**2 + X(1,1) = TEMP + SQRT(TEMP**2 + ONE) + X(2,2) = TEMP*TWO + SQRT(FOUR*TEMP**2 + DPAR(1)) + X(3,3) = TEMP*THREE + DPAR(1)*SQRT(9.0D0*TEMP + ONE) + CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, X, LDX, + 1 ZERO, DWORK, IPAR(1)) + CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, + 1 IPAR(1), ZERO, X, LDX) + ELSE + INFO = 2 + END IF +C + ELSE IF (NR(2) .EQ. 7) THEN + IF (DPAR(1) .NE. ZERO) THEN + A(1,2) = .400D0 + A(2,3) = .345D0 + A(3,2) = -.524D0/DPAR(1) + A(3,3) = -.465D0/DPAR(1) + A(3,4) = .262D0/DPAR(1) + A(4,4) = -ONE/DPAR(1) + B(4,1) = ONE/DPAR(1) + C(1,1) = ONE + C(2,3) = ONE + IDENT = '0011' + ELSE + INFO = 2 + END IF +C + ELSE IF (NR(2) .EQ. 8) THEN + A(1,1) = -DPAR(1) + A(2,1) = -ONE + A(1,2) = ONE + A(2,2) = -DPAR(1) + A(3,3) = DPAR(1) + A(4,3) = -ONE + A(3,4) = ONE + A(4,4) = DPAR(1) + CALL DLASET('L', IPAR(1), IPAR(2), ONE, ONE, B, LDB) + CALL DLASET('U', IPAR(3), IPAR(1), ONE, ONE, C, LDC) + IDENT = '0011' +C + ELSE IF (NR(2) .EQ. 9) THEN + IF (IPAR(3) .EQ. 10) THEN +C .. read LQR CARE ... + WRITE (CHPAR(1:12), '(A,I1,A,I1,A)') 'BB01', NR(1), '0', + 1 NR(2), '1.dat' + OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:12)) + IF (IOS .NE. 0) THEN + INFO = 1 + ELSE + DO 36 I = 1, 27, 2 + READ (1, FMT = *, IOSTAT = IOS) + 1 ((A(I+J,I+K), K = 0, 1), J = 0, 1) + IF (IOS .NE. 0) INFO = 1 + 36 CONTINUE + DO 37 I = 30, 44, 2 + READ (1, FMT = *, IOSTAT = IOS) + 1 ((A(I+J,I+K), K = 0, 1), J = 0, 1) + IF (IOS .NE. 0) INFO = 1 + 37 CONTINUE + DO 38 I = 1, IPAR(1) + READ (1, FMT = *, IOSTAT = IOS) + 1 (A(I,J), J = 46, IPAR(1)) + IF (IOS .NE. 0) INFO = 1 + 38 CONTINUE + A(29,29) = -.5301D1 + B(48,1) = .8D06 + B(51,2) = .8D06 + G(1) = .3647D03 + G(3) = .1459D02 + DO 39 I = 1,6 + READ (1, FMT = *, IOSTAT = IOS) + 1 (C(I,J), J = 1,45) + IF (IOS .NE. 0) INFO = 1 + 39 CONTINUE + C(7,47) = ONE + C(8,46) = ONE + C(9,50) = ONE + C(10,49) = ONE + Q(11) = .376D-13 + Q(20) = .120D-12 + Q(41) = .245D-11 + END IF + ELSE +C .. read Kalman filter CARE .. + WRITE (CHPAR(1:12), '(A,I1,A,I1,A)') 'BB01', NR(1), '0', + 1 NR(2), '2.dat' + OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:12)) + IF (IOS .NE. 0) THEN + INFO = 1 + ELSE + DO 40 I = 1, 27, 2 + READ (1, FMT = *, IOSTAT = IOS) + 1 ((A(I+K,I+J), K = 0, 1), J = 0, 1) + IF (IOS .NE. 0) INFO = 1 + 40 CONTINUE + DO 41 I = 30, 44, 2 + READ (1, FMT = *, IOSTAT = IOS) + 1 ((A(I+K,I+J), K = 0, 1), J = 0, 1) + IF (IOS .NE. 0) INFO = 1 + 41 CONTINUE + DO 42 I = 1, IPAR(1) + READ (1, FMT = *, IOSTAT = IOS) + 1 (A(J,I), J = 46, IPAR(1)) + IF (IOS .NE. 0) INFO = 1 + 42 CONTINUE + A(29,29) = -.5301D1 + DO 43 J = 1, IPAR(2) + READ (1, FMT = *, IOSTAT = IOS) + 1 (B(I,J), I = 1, IPAR(1)) + IF (IOS .NE. 0) INFO = 1 + 43 CONTINUE + G(1) = .685D-5 + G(3) = .373D3 + C(1,52) = .3713 + C(1,53) = .1245D1 + C(2,48) = .8D6 + C(2,54) = ONE + C(3,51) = .8D6 + C(3,55) = ONE + Q(1) = .28224D5 + Q(4) = .2742D-4 + Q(6) = .6854D-3 + END IF + END IF + CLOSE(1) + IDENT = '0000' + END IF +C + ELSE IF (NR(1) .EQ. 3) THEN + IF (NR(2) .EQ. 1) THEN + DO 45 I = 1, IPAR(1) + IF (MOD(I,2) .EQ. 1) THEN + A(I,I) = -ONE + B(I,(I+1)/2) = ONE + ELSE + A(I,I-1) = ONE + A(I,I+1) = -ONE + C(I/2,I) = ONE + END IF + 45 CONTINUE + ISYMM = 1 + DO 50 I = IPAR(3), 1, -1 + Q(ISYMM) = 10.0D0 + ISYMM = ISYMM + I + 50 CONTINUE + IDENT = '0001' +C + ELSE IF (NR(2) .EQ. 2) THEN + DO 60 I = 1, IPAR(1) + A(I,I) = -TWO + IF (I .LT. IPAR(1)) THEN + A(I,I+1) = ONE + A(I+1,I) = ONE + END IF + 60 CONTINUE + A(1,IPAR(1)) = ONE + A(IPAR(1),1) = ONE + IDENT = '1111' + TEMP = TWO * PI / DBLE(IPAR(1)) + DO 70 I = 1, IPAR(1) + DWORK(I) = COS(TEMP*DBLE(I-1)) + DWORK(IPAR(1)+I) = -TWO + TWO*DWORK(I) + + 1 SQRT(5.0D0 + FOUR*DWORK(I)*(DWORK(I) - TWO)) + 70 CONTINUE + DO 90 J = 1, IPAR(1) + DO 80 I = 1, IPAR(1) + DWORK(2*IPAR(1)+I) = COS(TEMP*DBLE(I-1)*DBLE(J-1)) + 80 CONTINUE + X(J,1) = DDOT(IPAR(1), DWORK(IPAR(1)+1), 1, + 1 DWORK(2*IPAR(1)+1), 1)/DBLE(IPAR(1)) + 90 CONTINUE +C .. set up circulant solution matrix .. + DO 100 I = 2, IPAR(1) + CALL DCOPY(IPAR(1)-I+1, X(1,1), 1, X(I,I), 1) + CALL DCOPY(I-1, X(IPAR(1)-I+2,1), 1, X(1,I), 1) + 100 CONTINUE + END IF +C + ELSE IF (NR(1) .EQ. 4) THEN + IF (NR(2) .EQ. 1) THEN +C .. set up remaining parameter .. + IF (.NOT. LSAME(DEF,'N')) THEN + DPAR(1) = ONE + DPAR(2) = ONE + END IF + CALL DLASET('A', IPAR(1)-1, IPAR(1)-1, ZERO, ONE, A(1,2), LDA) + B(IPAR(1),1) = ONE + C(1,1) = ONE + Q(1) = DPAR(1) + G(1) = DPAR(2) + IDENT = '0000' +C + ELSE IF (NR(2) .EQ. 2) THEN +C .. set up remaining parameters .. + APPIND = DBLE(IPAR(1) + 1) + IF (.NOT. LSAME(DEF,'N')) THEN + DPAR(1) = PARDEF(NR(1), NR(2)) + DPAR(2) = ONE + DPAR(3) = ONE + DPAR(4) = .2D0 + DPAR(5) = .3D0 + DPAR(6) = .2D0 + DPAR(7) = .3D0 + END IF +C .. set up stiffness matrix .. + TEMP = -DPAR(1)*APPIND + CALL DLASET('A', IPAR(1), IPAR(1), ZERO, TWO*TEMP, A, LDA) + DO 110 I = 1, IPAR(1) - 1 + A(I+1,I) = -TEMP + A(I,I+1) = -TEMP + 110 CONTINUE +C .. set up Gramian, stored by diagonals .. + TEMP = ONE/(6.0D0*APPIND) + CALL DLASET('L', IPAR(1), 1, FOUR*TEMP, FOUR*TEMP, DWORK, + 1 IPAR(1)) + CALL DLASET('L', IPAR(1)-1, 1, TEMP, TEMP, DWORK(IPAR(1)+1), + 1 IPAR(1)) + CALL DPTTRF(IPAR(1), DWORK(1), DWORK(IPAR(1)+1), INFO) +C .. A = (inverse of Gramian) * (stiffness matrix) .. + CALL DPTTRS(IPAR(1), IPAR(1), DWORK(1), DWORK(IPAR(1)+1), + 1 A, LDA, INFO) +C .. compute B, C .. + DO 120 I = 1, IPAR(1) + B1 = MAX(DBLE(I-1)/APPIND, DPAR(4)) + B2 = MIN(DBLE(I+1)/APPIND, DPAR(5)) + C1 = MAX(DBLE(I-1)/APPIND, DPAR(6)) + C2 = MIN(DBLE(I+1)/APPIND, DPAR(7)) + IF (B1 .GE. B2) THEN + B(I,1) = ZERO + ELSE + B(I,1) = B2 - B1 + TEMP = MIN(B2, DBLE(I)/APPIND) + IF (B1 .LT. TEMP) THEN + B(I,1) = B(I,1) + APPIND*(TEMP**2 - B1**2)/TWO + B(I,1) = B(I,1) + DBLE(I)*(B1 - TEMP) + END IF + TEMP = MAX(B1, DBLE(I)/APPIND) + IF (TEMP .LT. B2) THEN + B(I,1) = B(I,1) - APPIND*(B2**2 - TEMP**2)/TWO + B(I,1) = B(I,1) - DBLE(I)*(TEMP - B2) + END IF + END IF + IF (C1 .GE. C2) THEN + C(1,I) = ZERO + ELSE + C(1,I) = C2 - C1 + TEMP = MIN(C2, DBLE(I)/APPIND) + IF (C1 .LT. TEMP) THEN + C(1,I) = C(1,I) + APPIND*(TEMP**2 - C1**2)/TWO + C(1,I) = C(1,I) + DBLE(I)*(C1 - TEMP) + END IF + TEMP = MAX(C1, DBLE(I)/APPIND) + IF (TEMP .LT. C2) THEN + C(1,I) = C(1,I) - APPIND*(C2**2 - TEMP**2)/TWO + C(1,I) = C(1,I) - DBLE(I)*(TEMP - C2) + END IF + END IF + 120 CONTINUE + CALL DSCAL(IPAR(1), DPAR(2), B(1,1), 1) + CALL DSCAL(IPAR(1), DPAR(3), C(1,1), LDC) + CALL DPTTRS(IPAR(1), 1, DWORK(1), DWORK(IPAR(1)+1), B, LDB, + 1 INFO) + IDENT = '0011' +C + ELSE IF (NR(2) .EQ. 3) THEN +C .. set up remaining parameters .. + IF (.NOT. LSAME(DEF,'N')) THEN + DPAR(1) = PARDEF(NR(1),NR(2)) + DPAR(2) = FOUR + DPAR(3) = ONE + END IF + IF (DPAR(1) . NE. 0) THEN + CALL DLASET('A', L, L, ZERO, ONE, A(1,L+1), LDA) + TEMP = DPAR(3) / DPAR(1) + A(L+1,1) = -TEMP + A(L+1,2) = TEMP + A(IPAR(1),L-1) = TEMP + A(IPAR(1),L) = -TEMP + TTEMP = TWO*TEMP + DO 130 I = 2, L-1 + A(L+I,I) = -TTEMP + A(L+I,I+1) = TEMP + A(L+I,I-1) = TEMP + 130 CONTINUE + CALL DLASET('A', L, L, ZERO, -DPAR(2)/DPAR(1), A(L+1,L+1), + 1 LDA) + B(L+1,1) = ONE / DPAR(1) + B(IPAR(1),IPAR(2)) = -ONE / DPAR(1) + IDENT = '0111' + ELSE + INFO = 2 + END IF +C + ELSE IF (NR(2) .EQ. 4) THEN + IF (.NOT. LSAME(DEF,'N')) WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') + 1 'BB01', NR(1), '0', NR(2), '.dat' + OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) + IF (IOS .NE. 0) THEN + INFO = 1 + ELSE + READ (1, FMT = *, IOSTAT = IOS) (DWORK(I), I = 1, 4*L-2) + IF (IOS .NE. 0) INFO = 1 + END IF + CLOSE(1) + IF (INFO .EQ. 0) THEN + CALL DLASET('A', L-1, L-1, ZERO, ONE, A(L+1,2), LDA) + POS = 2*L + 1 + A(1,2) = - DWORK(POS) / DWORK(1) + DO 140 I = 2, L + TEMP = DWORK(POS) / DWORK(I-1) + TTEMP = DWORK(POS) / DWORK(I) + IF (I .GT. 2) A(I-1,I) = TEMP + A(I,I) = -(TEMP + TTEMP) + IF (I .LT. L) A(I+1,I) = TTEMP + POS = POS + 1 + 140 CONTINUE + POS = L + TEMP = DWORK(POS+1) / DWORK(1) + A(1,1) = -TEMP + DO 160 I = 2, L + TTEMP = TEMP + TEMP = DWORK(POS+I) / DWORK(I) + SUM = TTEMP - TEMP + A(I,1) = -SUM + A(I,I) = A(I,I) - TEMP + DO 150 J = 2, I-2 + A(I,J) = SUM + 150 CONTINUE + IF (I .GT. 2) A(I,I-1) = A(I,I-1) + SUM + 160 CONTINUE + POS = 3*L + A(1,L+1) = -DWORK(3*L)/DWORK(1) + DO 170 I = 2, L + TEMP = DWORK(POS) / DWORK(I-1) + TTEMP = DWORK(POS) / DWORK(I) + IF (I .GT. 2) A(I-1,L+I-1) = TEMP + A(I,L+I-1) = -(TEMP + TTEMP) + IF (I .LT. L) A(I+1,L+I-1) = TTEMP + POS = POS + 1 + 170 CONTINUE + B(1,1) = ONE/DWORK(1) + DO 180 I = 1, L + TEMP = ONE/DWORK(I) + IF (I .GT. 1) B(I,I) = -TEMP + IF (I .LT. L) B(I+1,I) = TEMP + 180 CONTINUE + C(1,1) = ONE + Q(1) = ONE + POS = 2*L - 1 + ISYMM = L + 1 + DO 190 I = 2, L + TEMP = DWORK(POS+I) + TTEMP = DWORK(POS+L+I-1) + C(I,I) = TEMP + C(I,L+I-1) = TTEMP + Q(ISYMM) = ONE / (TEMP*TEMP + TTEMP*TTEMP) + ISYMM = ISYMM + L - I + 1 + 190 CONTINUE + IDENT = '0001' + END IF + END IF + END IF +C + IF (INFO .NE. 0) GOTO 2001 +C .. set up data in required format .. +C + IF (BPAR(1)) THEN +C .. G is to be returned in product form .. + GDIMM = IPAR(1) + IF (IDENT(4:4) .EQ. '0') THEN +C .. invert R using Cholesky factorization, store in G .. + CALL DPPTRF('L', IPAR(2), G, INFO) + IF (INFO .EQ. 0) THEN + CALL DPPTRI('L', IPAR(2), G, INFO) + IF (IDENT(1:1) .EQ. '0') THEN +C .. B is not identity matrix .. + DO 200 I = 1, IPAR(1) + CALL DSPMV('L', IPAR(2), ONE, G, B(I,1), LDB, ZERO, + 1 DWORK((I-1)*IPAR(1)+1), 1) + 200 CONTINUE + CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), + 1 B(1,1), LDB, ZERO, G, 1) + ISYMM = IPAR(1) + 1 + DO 210 I = 2, IPAR(1) + CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), + 1 B(I,1), LDB, ZERO, B(1,1), LDB) + CALL DCOPY(IPAR(1) - I + 1, B(1,I), LDB, G(ISYMM), 1) + ISYMM = ISYMM + (IPAR(1) - I + 1) + 210 CONTINUE + END IF + ELSE + IF (INFO .GT. 0) THEN + INFO = 3 + GOTO 2001 + END IF + END IF + ELSE +C .. R = identity .. + IF (IDENT(1:1) .EQ. '0') THEN +C .. B is not identity matrix .. + IF (IPAR(2) .EQ. 1) THEN + CALL DLASET('L', NSYMM, 1, ZERO, ZERO, G, 1) + CALL DSPR('L', IPAR(1), ONE, B, 1, G) + ELSE + CALL DSYRK('L', 'N', IPAR(1), IPAR(2), ONE, + 1 B, LDB, ZERO, DWORK, IPAR(1)) + CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), G) + END IF + ELSE +C .. B = R = identity .. + ISYMM = 1 + DO 220 I = IPAR(1), 1, -1 + G(ISYMM) = ONE + ISYMM = ISYMM + I + 220 CONTINUE + END IF + END IF + ELSE + GDIMM = IPAR(2) + IF (IDENT(1:1) .EQ. '1') + 1 CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ONE, B, LDB) + IF (IDENT(4:4) .EQ. '1') THEN + ISYMM = 1 + DO 230 I = IPAR(2), 1, -1 + G(ISYMM) = ONE + ISYMM = ISYMM + I + 230 CONTINUE + END IF + END IF +C + IF (BPAR(4)) THEN +C .. Q is to be returned in product form .. + QDIMM = IPAR(1) + IF (IDENT(3:3) .EQ. '0') THEN + IF (IDENT(2:2) .EQ. '0') THEN +C .. C is not identity matrix .. + DO 240 I = 1, IPAR(1) + CALL DSPMV('L', IPAR(3), ONE, Q, C(1,I), 1, ZERO, + 1 DWORK((I-1)*IPAR(1)+1), 1) + 240 CONTINUE +C .. use Q(1:IPAR(1)) as workspace and compute the first column +C of Q in the end .. + ISYMM = IPAR(1) + 1 + DO 250 I = 2, IPAR(1) + CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), + 1 C(1,I), 1, ZERO, Q(1), 1) + CALL DCOPY(IPAR(1) - I + 1, Q(I), 1, Q(ISYMM), 1) + ISYMM = ISYMM + (IPAR(1) - I + 1) + 250 CONTINUE + CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), + 1 C(1,1), 1, ZERO, Q, 1) + END IF + ELSE +C .. Q = identity .. + IF (IDENT(2:2) .EQ. '0') THEN +C .. C is not identity matrix .. + IF (IPAR(3) .EQ. 1) THEN + CALL DLASET('L', NSYMM, 1, ZERO, ZERO, Q, 1) + CALL DSPR('L', IPAR(1), ONE, C, LDC, Q) + ELSE + CALL DSYRK('L', 'T', IPAR(1), IPAR(3), ONE, C, LDC, + 1 ZERO, DWORK, IPAR(1)) + CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), Q) + END IF + ELSE +C .. C = Q = identity .. + ISYMM = 1 + DO 260 I = IPAR(1), 1, -1 + Q(ISYMM) = ONE + ISYMM = ISYMM + I + 260 CONTINUE + END IF + END IF + ELSE + QDIMM = IPAR(3) + IF (IDENT(2:2) .EQ. '1') + 1 CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ONE, C, LDC) + IF (IDENT(3:3) .EQ. '1') THEN + ISYMM = 1 + DO 270 I = IPAR(3), 1, -1 + Q(ISYMM) = ONE + ISYMM = ISYMM + I + 270 CONTINUE + END IF + END IF +C +C .. unpack symmetric matrices if desired .. + IF (BPAR(2)) THEN + ISYMM = (GDIMM * (GDIMM + 1)) / 2 + CALL DCOPY(ISYMM, G, 1, DWORK, 1) + CALL MA02DD('Unpack', 'Lower', GDIMM, G, LDG, DWORK) + CALL MA02ED('Lower', GDIMM, G, LDG) + ELSE IF (BPAR(3)) THEN + CALL MA02DD('Unpack', 'Lower', GDIMM, DWORK, GDIMM, G) + CALL MA02ED('Lower', GDIMM, DWORK, GDIMM) + CALL MA02DD('Pack', 'Upper', GDIMM, DWORK, GDIMM, G) + END IF + IF (BPAR(5)) THEN + ISYMM = (QDIMM * (QDIMM + 1)) / 2 + CALL DCOPY(ISYMM, Q, 1, DWORK, 1) + CALL MA02DD('Unpack', 'Lower', QDIMM, Q, LDQ, DWORK) + CALL MA02ED('Lower', QDIMM, Q, LDQ) + ELSE IF (BPAR(6)) THEN + CALL MA02DD('Unpack', 'Lower', QDIMM, DWORK, QDIMM, Q) + CALL MA02ED('Lower', QDIMM, DWORK, QDIMM) + CALL MA02DD('Pack', 'Upper', QDIMM, DWORK, QDIMM, Q) + END IF +C +C ...set VEC... + VEC(1) = .TRUE. + VEC(2) = .TRUE. + VEC(3) = .TRUE. + VEC(4) = .TRUE. + VEC(5) = .NOT. BPAR(1) + VEC(6) = .NOT. BPAR(4) + VEC(7) = .TRUE. + VEC(8) = .TRUE. + IF (NR(1) .EQ. 1) THEN + IF ((NR(2) .EQ. 1) .OR. (NR(2) .EQ. 2)) VEC(9) = .TRUE. + ELSE IF (NR(1) .EQ. 2) THEN + IF ((NR(2) .EQ. 1) .OR. ((NR(2) .GE. 3) .AND. (NR(2) .LE. 6))) + 1 VEC(9) = .TRUE. + ELSE IF (NR(1) .EQ. 3) THEN + IF (NR(2) .EQ. 2) VEC(9) = .TRUE. + END IF + CHPAR = NOTES(NR(1),NR(2)) + N = IPAR(1) + M = IPAR(2) + P = IPAR(3) + 2001 CONTINUE + RETURN +C *** Last line of BB01AD *** + END diff --git a/mex/sources/libslicot/BB02AD.f b/mex/sources/libslicot/BB02AD.f new file mode 100644 index 000000000..b9edfa346 --- /dev/null +++ b/mex/sources/libslicot/BB02AD.f @@ -0,0 +1,1017 @@ + SUBROUTINE BB02AD(DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P, + 1 A, LDA, B, LDB, C, LDC, Q, LDQ, R, LDR, S, LDS, + 2 X, LDX, DWORK, LDWORK, INFO) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate the benchmark examples for the numerical solution of +C discrete-time algebraic Riccati equations (DAREs) of the form +C +C T T T -1 T T +C 0 = A X A - X - (A X B + S) (R + B X B) (B X A + S ) + Q +C +C as presented in [1]. Here, A,Q,X are real N-by-N matrices, B,S are +C N-by-M, and R is M-by-M. The matrices Q and R are symmetric and Q +C may be given in factored form +C +C T +C (I) Q = C Q0 C . +C +C Here, C is P-by-N and Q0 is P-by-P. If R is nonsingular and S = 0, +C the DARE can be rewritten equivalently as +C +C T -1 +C 0 = X - A X (I_n + G X) A - Q, +C +C where I_n is the N-by-N identity matrix and +C +C -1 T +C (II) G = B R B . +C +C ARGUMENTS +C +C Mode Parameters +C +C DEF CHARACTER +C This parameter specifies if the default parameters are +C to be used or not. +C = 'N' or 'n' : The parameters given in the input vectors +C xPAR (x = 'D', 'I', 'B', 'CH') are used. +C = 'D' or 'd' : The default parameters for the example +C are used. +C This parameter is not meaningful if NR(1) = 1. +C +C Input/Output Parameters +C +C NR (input) INTEGER array, dimension (2) +C This array determines the example for which DAREX returns +C data. NR(1) is the group of examples. +C NR(1) = 1 : parameter-free problems of fixed size. +C NR(1) = 2 : parameter-dependent problems of fixed size. +C NR(1) = 3 : parameter-free problems of scalable size. +C NR(1) = 4 : parameter-dependent problems of scalable size. +C NR(2) is the number of the example in group NR(1). +C Let NEXi be the number of examples in group i. Currently, +C NEX1 = 13, NEX2 = 5, NEX3 = 0, NEX4 = 1. +C 1 <= NR(1) <= 4; +C 0 <= NR(2) <= NEXi, where i = NR(1). +C +C DPAR (input/output) DOUBLE PRECISION array, dimension (4) +C Double precision parameter vector. For explanation of the +C parameters see [1]. +C DPAR(1) defines the parameter 'epsilon' for +C examples NR = 2.2,2.3,2.4, the parameter 'tau' +C for NR = 2.5, and the 1-by-1 matrix R for NR = 2.1,4.1. +C For Example 2.5, DPAR(2) - DPAR(4) define in +C consecutive order 'D', 'K', and 'r'. +C NOTE that DPAR is overwritten with default values +C if DEF = 'D' or 'd'. +C +C IPAR (input/output) INTEGER array, dimension (3) +C On input, IPAR(1) determines the actual state dimension, +C i.e., the order of the matrix A as follows: +C NR(1) = 1, NR(1) = 2 : IPAR(1) is ignored. +C NR = NR(1).NR(2) = 4.1 : IPAR(1) determines the order of +C the output matrix A. +C NOTE that IPAR(1) is overwritten for Examples 1.1-2.3. For +C the other examples, IPAR(1) is overwritten if the default +C parameters are to be used. +C On output, IPAR(1) contains the order of the matrix A. +C +C On input, IPAR(2) is the number of colums in the matrix B +C and the order of the matrix R (in control problems, the +C number of inputs of the system). Currently, IPAR(2) is +C fixed for all examples and thus is not referenced on +C input. +C On output, IPAR(2) is the number of columns of the +C matrix B from (I). +C +C On input, IPAR(3) is the number of rows in the matrix C +C (in control problems, the number of outputs of the +C system). Currently, IPAR(3) is fixed for all examples +C and thus is not referenced on input. +C On output, IPAR(3) is the number of rows of the matrix C +C from (I). +C +C NOTE that IPAR(2) and IPAR(3) are overwritten and +C IPAR(2) <= IPAR(1) and IPAR(3) <= IPAR(1) for all +C examples. +C +C BPAR (input) LOGICAL array, dimension (7) +C This array defines the form of the output of the examples +C and the storage mode of the matrices Q, G or R. +C BPAR(1) = .TRUE. : Q is returned. +C BPAR(1) = .FALSE. : Q is returned in factored form, i.e., +C Q0 and C from (I) are returned. +C BPAR(2) = .TRUE. : The matrix returned in array Q (i.e., +C Q if BPAR(1) = .TRUE. and Q0 if +C BPAR(1) = .FALSE.) is stored as full +C matrix. +C BPAR(2) = .FALSE. : The matrix returned in array Q is +C provided in packed storage mode. +C BPAR(3) = .TRUE. : If BPAR(2) = .FALSE., the matrix +C returned in array Q is stored in upper +C packed mode, i.e., the upper triangle +C of a symmetric n-by-n matrix is stored +C by columns, e.g., the matrix entry +C Q(i,j) is stored in the array entry +C Q(i+j*(j-1)/2) for i <= j. +C Otherwise, this entry is ignored. +C BPAR(3) = .FALSE. : If BPAR(2) = .FALSE., the matrix +C returned in array Q is stored in lower +C packed mode, i.e., the lower triangle +C of a symmetric n-by-n matrix is stored +C by columns, e.g., the matrix entry +C Q(i,j) is stored in the array entry +C Q(i+(2*n-j)*(j-1)/2) for j <= i. +C Otherwise, this entry is ignored. +C BPAR(4) = .TRUE. : The product G in (II) is returned. +C BPAR(4) = .FALSE. : G is returned in factored form, i.e., +C B and R from (II) are returned. +C BPAR(5) = .TRUE. : The matrix returned in array R (i.e., +C G if BPAR(4) = .TRUE. and R if +C BPAR(4) = .FALSE.) is stored as full +C matrix. +C BPAR(5) = .FALSE. : The matrix returned in array R is +C provided in packed storage mode. +C BPAR(6) = .TRUE. : If BPAR(5) = .FALSE., the matrix +C returned in array R is stored in upper +C packed mode (see above). +C Otherwise, this entry is ignored. +C BPAR(6) = .FALSE. : If BPAR(5) = .FALSE., the matrix +C returned in array R is stored in lower +C packed mode (see above). +C Otherwise, this entry is ignored. +C BPAR(7) = .TRUE. : The coefficient matrix S of the DARE +C is returned in array S. +C BPAR(7) = .FALSE. : The coefficient matrix S of the DARE +C is not returned. +C NOTE that there are no default values for BPAR. If all +C entries are declared to be .TRUE., then matrices Q, G or R +C are returned in conventional storage mode, i.e., as +C N-by-N or M-by-M arrays where the array element Z(I,J) +C contains the matrix entry Z_{i,j}. +C +C CHPAR (output) CHARACTER*255 +C On output, this string contains short information about +C the chosen example. +C +C VEC (output) LOGICAL array, dimension (10) +C Flag vector which displays the availability of the output +C data: +C VEC(j), j=1,2,3, refer to N, M, and P, respectively, and +C are always .TRUE. +C VEC(4) refers to A and is always .TRUE. +C VEC(5) is .TRUE. if BPAR(4) = .FALSE., i.e., the factors B +C and R from (II) are returned. +C VEC(6) is .TRUE. if BPAR(1) = .FALSE., i.e., the factors C +C and Q0 from (I) are returned. +C VEC(7) refers to Q and is always .TRUE. +C VEC(8) refers to R and is always .TRUE. +C VEC(9) is .TRUE. if BPAR(7) = .TRUE., i.e., the matrix S +C is returned. +C VEC(10) refers to X and is .TRUE. if the exact solution +C matrix is available. +C NOTE that VEC(i) = .FALSE. for i = 1 to 10 if on exit +C INFO .NE. 0. +C +C N (output) INTEGER +C The order of the matrices A, X, G if BPAR(4) = .TRUE., and +C Q if BPAR(1) = .TRUE. +C +C M (output) INTEGER +C The number of columns in the matrix B (or the dimension of +C the control input space of the underlying dynamical +C system). +C +C P (output) INTEGER +C The number of rows in the matrix C (or the dimension of +C the output space of the underlying dynamical system). +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the +C coefficient matrix A of the DARE. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C If (BPAR(4) = .FALSE.), then the leading N-by-M part +C of this array contains the coefficient matrix B of +C the DARE. Otherwise, B is used as workspace. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= N. +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C If (BPAR(1) = .FALSE.), then the leading P-by-N part +C of this array contains the matrix C of the factored +C form (I) of Q. Otherwise, C is used as workspace. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= P. +C +C Q (output) DOUBLE PRECISION array, dimension (NQ) +C If (BPAR(1) = .TRUE.) and (BPAR(2) = .TRUE.), then +C NQ = LDQ*N. +C IF (BPAR(1) = .TRUE.) and (BPAR(2) = .FALSE.), then +C NQ = N*(N+1)/2. +C If (BPAR(1) = .FALSE.) and (BPAR(2) = .TRUE.), then +C NQ = LDQ*P. +C IF (BPAR(1) = .FALSE.) and (BPAR(2) = .FALSE.), then +C NQ = P*(P+1)/2. +C The symmetric matrix contained in array Q is stored +C according to BPAR(2) and BPAR(3). +C +C LDQ INTEGER +C If conventional storage mode is used for Q, i.e., +C BPAR(2) = .TRUE., then Q is stored like a 2-dimensional +C array with leading dimension LDQ. If packed symmetric +C storage mode is used, then LDQ is irrelevant. +C LDQ >= N if BPAR(1) = .TRUE.; +C LDQ >= P if BPAR(1) = .FALSE.. +C +C R (output) DOUBLE PRECISION array, dimension (MR) +C If (BPAR(4) = .TRUE.) and (BPAR(5) = .TRUE.), then +C MR = LDR*N. +C IF (BPAR(4) = .TRUE.) and (BPAR(5) = .FALSE.), then +C MR = N*(N+1)/2. +C If (BPAR(4) = .FALSE.) and (BPAR(5) = .TRUE.), then +C MR = LDR*M. +C IF (BPAR(4) = .FALSE.) and (BPAR(5) = .FALSE.), then +C MR = M*(M+1)/2. +C The symmetric matrix contained in array R is stored +C according to BPAR(5) and BPAR(6). +C +C LDR INTEGER +C If conventional storage mode is used for R, i.e., +C BPAR(5) = .TRUE., then R is stored like a 2-dimensional +C array with leading dimension LDR. If packed symmetric +C storage mode is used, then LDR is irrelevant. +C LDR >= N if BPAR(4) = .TRUE.; +C LDR >= M if BPAR(4) = .FALSE.. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,M) +C If (BPAR(7) = .TRUE.), then the leading N-by-M part of +C this array contains the coefficient matrix S of the DARE. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= 1, and +C LDS >= N if BPAR(7) = .TRUE.. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,NX) +C If an exact solution is available (NR = 1.1,1.3,1.4,2.1, +C 2.3,2.4,2.5,4.1), then NX = N and the leading N-by-N part +C of this array contains the solution matrix X. +C Otherwise, X is not referenced. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= 1, and +C LDX >= N if an exact solution is available. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= N*N. +C +C Error Indicator +C +C INFO INTEGER +C = 0 : successful exit; +C < 0 : if INFO = -i, the i-th argument had an illegal +C value; +C = 1 : data file could not be opened or had wrong format; +C = 2 : division by zero; +C = 3 : G can not be computed as in (II) due to a singular R +C matrix. This error can only occur if +C BPAR(4) = .TRUE.. +C +C REFERENCES +C +C [1] Abels, J. and Benner, P. +C DAREX - A Collection of Benchmark Examples for Discrete-Time +C Algebraic Riccati Equations (Version 2.0). +C SLICOT Working Note 1999-16, November 1999. Available from +C http://www.win.tue.nl/niconet/NIC2/reports.html. +C +C This is an updated and extended version of +C +C [2] Benner, P., Laub, A.J., and Mehrmann, V. +C A Collection of Benchmark Examples for the Numerical Solution +C of Algebraic Riccati Equations II: Discrete-Time Case. +C Technical Report SPC 95_23, Fak. f. Mathematik, +C TU Chemnitz-Zwickau (Germany), December 1995. +C +C FURTHER COMMENTS +C +C Some benchmark examples read data from the data files provided +C with the collection. +C +C CONTRIBUTOR +C +C Peter Benner (Universitaet Bremen), November 25, 1999. +C +C For questions concerning the collection or for the submission of +C test examples, please send e-mail to benner@math.uni-bremen.de. +C +C REVISIONS +C +C 1999, December 23 (V. Sima). +C +C KEYWORDS +C +C Discrete-time algebraic Riccati equation. +C +C ****************************************************************** +C +C .. Parameters .. +C . # of examples available , # of examples with fixed size. . + INTEGER NEX1, NEX2, NEX3, NEX4, NMAX + PARAMETER ( NEX1 = 13, NEX2 = 5, NEX3 = 0, NEX4 = 1 ) + PARAMETER ( NMAX = 13 ) + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, FIVE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + 1 THREE = 3.0D0, FOUR = 4.0D0, FIVE = 5.0D0 ) +C +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDQ, LDR, LDS, LDWORK, LDX, + $ M, N, P + CHARACTER DEF +C +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DPAR(*), DWORK(*), + 1 Q(*), R(*), S(LDS,*), X(LDX,*) + INTEGER IPAR(3), NR(2) + CHARACTER CHPAR*255 + LOGICAL BPAR(7), VEC(10) +C +C .. Local Scalars .. + INTEGER I, IOS, ISYMM, J, MSYMM, NSYMM, PSYMM, QDIMM, + 1 RDIMM + DOUBLE PRECISION ALPHA, BETA, TEMP +C +C ..Local Arrays .. + INTEGER MDEF(2,NMAX), NDEF(4,NMAX), NEX(4), PDEF(2,NMAX) + CHARACTER IDENT*4 + CHARACTER*255 NOTES(4,NMAX) +C +C .. External Functions .. +C . LAPACK . + LOGICAL LSAME + EXTERNAL LSAME +C +C .. External Subroutines .. +C . BLAS . + EXTERNAL DCOPY, DGEMV, DSPMV, DSPR, DSYMM, DSYRK +C . LAPACK . + EXTERNAL DLASET, DPPTRF, DPPTRI, DRSCL, XERBLA +C . SLICOT . + EXTERNAL MA02DD, MA02ED +C +C .. Intrinsic Functions .. + INTRINSIC SQRT +C +C .. Data Statements .. +C . default values for dimensions . + DATA NEX /NEX1, NEX2, NEX3, NEX4/ + DATA (NDEF(1,I), I = 1, NEX1) /2, 2, 2, 3, 4, 4, 4, 5, 6, 9, + 1 11, 13, 26/ + DATA (NDEF(2,I), I = 1, NEX2) /2, 2, 2, 3, 4/ + DATA (NDEF(4,I), I = 1, NEX4) /100/ + DATA (MDEF(1,I), I = 1, NEX1) /1, 2, 1, 2, 2, 2, 4, 2, 2, 3, + 1 2, 2, 6/ + DATA (MDEF(2,I), I = 1, NEX2) /1, 2, 1, 3, 1/ + DATA (PDEF(1,I), I = 1, NEX1) /1, 2, 2, 3, 4, 4, 4, 5, 2, 2, + 1 4, 4, 12/ + DATA (PDEF(2,I), I = 1, NEX2) /2, 2, 2, 3, 1/ +C . comments on examples . + DATA (NOTES(1,I), I = 1, 10) / + 1'Van Dooren 1981, Ex. II: singular R matrix', 'Ionescu/Weiss 1992 + 2: singular R matrix, nonzero S matrix', 'Jonckheere 1981: (A,B) co + 3ntrollable, no solution X <= 0', 'Sun 1998: R singular, Q non-defi + 4nite', 'Ackerson/Fu 1970 : satellite control problem', 'Litkouhi 1 + 5983 : system with slow and fast modes', 'Lu/Lin 1993, Ex. 4.3', 'G + 6ajic/Shen 1993, Section 2.7.4: chemical plant', 'Davison/Wang 1974 + 7: nonzero S matrix', 'Patnaik et al. 1980: tubular ammonia reactor + 8'/ + DATA (NOTES(1,I), I = 11, NEX1) / + 1'Sima 1996, Sec. 1.2.2: paper machine model error integrators', 'S + 2ima 1996, Ex. 2.6: paper machine model with with disturbances', 'P + 3ower plant model, Katayama et al., 1985'/ + DATA (NOTES(2,I), I = 1, NEX2) / + 1'Laub 1979, Ex. 2: uncontrollable-unobservable data', 'Laub 1979, + 2Ex. 3: increasingly ill-conditioned R-matrix', 'increasingly bad s + 3caled system as eps -> oo','Petkov et. al. 1989 : increasingly bad + 4 scaling as eps -> oo', 'Pappas et al. 1980: process control of pa + 5per machine'/ + DATA (NOTES(4,I), I = 1, NEX4) /'Pappas et al. 1980, Ex. 3'/ +C +C .. Executable Statements .. +C + INFO = 0 + DO 1 I = 1, 10 + VEC(I) = .FALSE. + 1 CONTINUE +C + IF (NR(1) .GE. 3) THEN + IF (LSAME(DEF, 'D')) IPAR(1) = NDEF(NR(1),NR(2)) + IPAR(2) = 1 + IPAR(3) = IPAR(1) + ELSE + IPAR(1) = NDEF(NR(1),NR(2)) + IPAR(2) = MDEF(NR(1),NR(2)) + IPAR(3) = PDEF(NR(1),NR(2)) + END IF +C + IF ((NR(1) .GE. 2) .AND. .NOT. ((LSAME(DEF,'D')) .OR. + $ (LSAME(DEF,'N')))) THEN + INFO = -1 + ELSE IF ((NR(1) .LT. 1) .OR. (NR(1) .GT. 4) .OR. (NR(2) .LT. 0) + 1 .OR. (NR(2) .GT. NEX(NR(1)))) THEN + INFO = -2 + ELSE IF (IPAR(1) .LT. 1) THEN + INFO = -4 + ELSE IF (IPAR(1) .GT. LDA) THEN + INFO = -12 + ELSE IF (IPAR(1) .GT. LDB) THEN + INFO = -14 + ELSE IF (IPAR(3) .GT. LDC) THEN + INFO = -16 + ELSE IF (BPAR(2) .AND. (((.NOT. BPAR(1)) .AND. + 1 (IPAR(3) .GT. LDQ)) .OR. (BPAR(1) .AND. + 2 (IPAR(1) .GT. LDQ)))) THEN + INFO = -18 + ELSE IF (BPAR(5) .AND. ((BPAR(4) .AND. (IPAR(1) .GT. LDR)) .OR. + 1 ((.NOT. BPAR(4)) .AND. (IPAR(2) .GT. LDR)))) THEN + INFO = -20 + ELSE IF (LDS .LT. 1 .OR. (BPAR(7) .AND. (IPAR(1) .GT. LDS))) THEN + INFO = -22 + ELSE IF (LDX .LT. 1) THEN + INFO = -24 + ELSE IF (((NR(1) .EQ. 1) .AND. ((NR(2) .EQ. 1) .OR. + 1 (NR(2) .EQ. 3) .OR. (NR(2) .EQ. 4))) .OR. + 2 ((NR(1) .EQ. 2) .AND. ((NR(2). EQ. 1) .OR. + 3 (NR(2) .GE. 3))) .OR. (NR(1) .EQ. 4)) THEN +C .. solution X available .. + IF (IPAR(1) .GT. LDX) THEN + INFO = -24 + ELSE + CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, X, LDX) + END IF + ELSE IF (LDWORK .LT. N*N) THEN + INFO = -26 + END IF + IF (INFO .NE. 0) THEN + CALL XERBLA( 'BB02AD', -INFO ) + RETURN + END IF +C + NSYMM = (IPAR(1)*(IPAR(1)+1))/2 + MSYMM = (IPAR(2)*(IPAR(2)+1))/2 + PSYMM = (IPAR(3)*(IPAR(3)+1))/2 +C + CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, A, LDA) + CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ZERO, B, LDB) + CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ZERO, C, LDC) + CALL DLASET('L', PSYMM, 1, ZERO, ZERO, Q, 1) + CALL DLASET('L', MSYMM, 1, ZERO, ZERO, R, 1) + IF (BPAR(7)) CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ZERO, + 1 S, LDS) +C + IF(NR(1) .EQ. 1) THEN +C + IF (NR(2) .EQ. 1) THEN + A(1,1) = TWO + A(2,1) = ONE + A(1,2) = -ONE + B(1,1) = ONE + Q(1) = ONE + C(1,2) = ONE + R(1) = ZERO + CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ONE, X, LDX) + IDENT = '0000' +C + ELSE IF (NR(2) .EQ. 2) THEN + A(1,2) = ONE + A(2,2) = -ONE + B(1,1) = ONE + B(2,1) = TWO + B(2,2) = ONE + R(1) = 9.0D0 + R(2) = THREE + R(3) = ONE + CALL DLASET('A', PSYMM, 1, -FOUR, -FOUR, Q, PSYMM) + Q(3) = 7.0D0 + CALL DRSCL(MSYMM, 11.0D0, Q, 1) + IF (BPAR(7)) THEN + S(1,1) = THREE + S(2,1) = -ONE + S(1,2) = ONE + S(2,2) = 7.0D0 + END IF + IDENT = '0100' +C + ELSE IF (NR(2) .EQ. 3) THEN + A(1,2) = ONE + B(2,1) = ONE + Q(1) = ONE + Q(2) = TWO + Q(3) = FOUR + X(1,1) = ONE + X(2,1) = TWO + X(1,2) = TWO + X(2,2) = TWO + SQRT(FIVE) + IDENT = '0101' +C + ELSE IF (NR(2) .EQ. 4) THEN + A(1,2) = .1000D+00 + A(2,3) = .0100D+00 + B(1,1) = ONE + B(3,2) = ONE + R(3) = ONE + Q(1) = .1D+06 + Q(4) = .1D+04 + Q(6) = -.1D+02 + X(1,1) = .1D+06 + X(2,2) = .1D+04 + IDENT = '0100' +C + ELSE IF (((NR(2) .GE. 5) .AND. (NR(2) .LE. 8)) .OR. + 1 (NR(2) .EQ. 10) .OR. (NR(2) .EQ. 11) .OR. + 2 (NR(2) .EQ. 13)) THEN + IF (NR(2) .LT. 10) THEN + WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') + 1 'BB02', NR(1), '0', NR(2), '.dat' + OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) + ELSE + WRITE (CHPAR(1:11), '(A,I1,I2,A)') + 1 'BB02', NR(1), NR(2), '.dat' + OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) + END IF + IF (IOS .NE. 0) THEN + INFO = 1 + ELSE + IF (.NOT. (NR(2) .EQ. 13)) THEN + DO 10 I = 1, IPAR(1) + READ (1, FMT = *, IOSTAT = IOS) (A(I,J), J = 1, IPAR(1)) + IF (IOS .NE. 0) INFO = 1 + 10 CONTINUE + DO 20 I = 1, IPAR(1) + READ (1, FMT = *, IOSTAT = IOS) (B(I,J), J = 1, IPAR(2)) + IF (IOS .NE. 0) INFO = 1 + 20 CONTINUE + END IF + IF (NR(2) .EQ. 5) THEN + Q(1) = .187D1 + Q(4) = -.244D0 + Q(5) = .744D0 + Q(6) = .205D0 + Q(8) = .589D0 + Q(10) = .1048D1 + ELSE IF (NR(2) .EQ. 6) THEN + Q(1) = .1D-1 + Q(5) = .1D-1 + Q(8) = .1D-1 + Q(10) = .1D-1 + ELSE IF (NR(2) .EQ. 7) THEN + CALL DLASET('U', IPAR(3), IPAR(1), ONE, ONE, C, LDC) + C(1,3) = TWO + C(1,4) = FOUR + C(2,4) = TWO + Q(1) = TWO + Q(2) = -ONE + Q(5) = TWO + Q(6) = -ONE + Q(8) = TWO + ELSE IF (NR(2) .EQ. 10) THEN + C(1,1) = ONE + C(2,5) = ONE + Q(1) = 50.0D0 + Q(3) = 50.0D0 + ELSE IF (NR(2) .EQ. 11) THEN + A(10,10) = ONE + A(11,11) = ONE + C(1,6) = 15.0D0 + C(2,7) = 7.0D0 + C(2,8) = -.5357D+01 + C(2,9) = -.3943D+01 + C(3,10) = ONE + C(4,11) = ONE + Q(1) = 0.5D0 + Q(5) = 5.0D0 + Q(8) = 0.5D0 + Q(10) = 5.0D0 + R(1) = 400.0D0 + R(3) = 700.0D0 + IDENT = '0000' +C + ELSE IF (NR(2) .EQ. 13) THEN + DO 24 I = 1, IPAR(1)-6 + READ (1, FMT = *, IOSTAT = IOS) + 1 (A(I,J), J = 1, IPAR(1)-6) + IF (IOS .NE. 0) INFO = 1 + 24 CONTINUE + DO 25 I = 1, IPAR(1)-6 + READ (1, FMT = *, IOSTAT = IOS) + 1 (B(I,J), J = 1, IPAR(2)) + IF (IOS .NE. 0) INFO = 1 + 25 CONTINUE + DO 26 I = 1, IPAR(2) + READ (1, FMT = *, IOSTAT = IOS) + 1 (C(I,J), J = 1, IPAR(1)-6) + IF (IOS .NE. 0) INFO = 1 + 26 CONTINUE + DO 27 I = 1, 6 + A(20+I,20+I) = ONE + C(6+I,20+I) = ONE + 27 CONTINUE + J = 58 + DO 28 I = 7, 12 + READ (1, FMT = *, IOSTAT = IOS) Q(J) + IF (IOS .NE. 0) INFO = 1 + J = J + (13 - I) + 28 CONTINUE + J = 1 + DO 29 I = 1, 6 + READ (1, FMT = *, IOSTAT = IOS) R(J) + IF (IOS .NE. 0) INFO = 1 + J = J + (7 - I) + 29 CONTINUE + DO 31 I = 1, 6 + DO 30 J = 1, 20 + A(I+20,J) = -C(I,J) + 30 CONTINUE + 31 CONTINUE + IDENT = '0000' + END IF + END IF + CLOSE(1) + IF ((NR(2) .EQ. 5) .OR. (NR(2) .EQ. 6)) THEN + IDENT = '0101' + ELSE IF ((NR(2) .EQ. 7) .OR. (NR(2) .EQ. 10)) THEN + IDENT = '0001' + ELSE IF (NR(2) .EQ. 8) THEN + IDENT = '0111' + END IF +C + ELSE IF (NR(2). EQ. 9) THEN + A(1,2) = ONE + A(2,3) = ONE + A(4,5) = ONE + A(5,6) = ONE + B(3,1) = ONE + B(6,2) = ONE + C(1,1) = ONE + C(1,2) = ONE + C(2,4) = ONE + C(2,5) = -ONE + R(1) = THREE + R(3) = ONE + IF (BPAR(7)) THEN + S(1,1) = ONE + S(2,1) = ONE + S(4,1) = ONE + S(5,1) = -ONE + END IF + IDENT = '0010' + ELSE IF (NR(2) .EQ. 12) THEN + DO 32 I = 1, 10 + A(I,I+1) = ONE + 32 CONTINUE + A(6,7) = ZERO + A(8,9) = ZERO + A(12,12) = ONE + A(13,13) = ONE + A(12,1) = -.3318D+01 + A(13,1) = -.15484D+01 + A(6,6) = .7788D+00 + A(8,7) = -.4724D+00 + A(13,7) = .3981D+00 + A(8,8) = .13746D+01 + A(13,8) = .5113D+00 + A(13,9) = .57865D+01 + A(11,11) = .8071D+00 + B(6,1) = ONE + B(8,2) = ONE + C(1,1) = .3318D+01 + C(2,1) = .15484D+01 + C(2,7) = -.3981D+00 + C(2,8) = -.5113D+00 + C(2,9) = -.57865D+01 + C(3,12) = ONE + C(4,13) = ONE + Q(1) = 0.5D0 + Q(5) = 5.0D0 + Q(8) = 0.5D0 + Q(10) = 5.0D0 + R(1) = 400.0D0 + R(3) = 700.0D0 + IDENT = '0000' + END IF +C + ELSE IF (NR(1) .EQ. 2) THEN + IF (NR(2) .EQ. 1) THEN + IF (LSAME(DEF, 'D')) DPAR(1) = .1D+07 + A(1,1) = FOUR + A(2,1) = -.45D1 + A(1,2) = THREE + A(2,2) = -.35D1 + CALL DLASET('A', IPAR(1), IPAR(2), -ONE, ONE, B, LDB) + R(1) = DPAR(1) + Q(1) = 9.0D0 + Q(2) = 6.0D0 + Q(3) = FOUR + TEMP = (ONE + SQRT(ONE+FOUR*DPAR(1))) / TWO + X(1,1) = TEMP*Q(1) + X(2,1) = TEMP*Q(2) + X(1,2) = X(2,1) + X(2,2) = TEMP*Q(3) + IDENT = '0100' +C + ELSE IF (NR(2) .EQ. 2) THEN + IF (LSAME(DEF, 'D')) DPAR(1) = .1D+07 + IF (DPAR(1) .EQ. ZERO) THEN + INFO = 2 + ELSE + A(1,1) = .9512D0 + A(2,2) = .9048D0 + CALL DLASET('A', 1, IPAR(2), .4877D1, .4877D1, B, LDB) + B(2,1) = -.11895D1 + B(2,2) = .3569D1 + R(1) = ONE / (THREE*DPAR(1)) + R(3) = THREE*DPAR(1) + Q(1) = .5D-2 + Q(3) = .2D-1 + IDENT = '0100' + END IF +C + ELSE IF (NR(2) .EQ. 3) THEN + IF (LSAME(DEF,'D')) DPAR(1) = .1D7 + A(1,2) = DPAR(1) + B(2,1) = ONE + X(1,1) = ONE + X(2,2) = ONE + DPAR(1)*DPAR(1) + IDENT = '0111' +C + ELSE IF (NR(2) .EQ. 4) THEN + IF (LSAME(DEF,'D')) DPAR(1) = .1D7 + A(2,2) = ONE + A(3,3) = THREE + R(1) = DPAR(1) + R(4) = DPAR(1) + R(6) = DPAR(1) +C .. set C = V .. + TEMP = TWO/THREE + CALL DLASET('A', IPAR(3), IPAR(1), -TEMP, ONE - TEMP, C, LDC) +C .. and compute A <- C' A C + CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, A, LDA, + 1 ZERO, DWORK, IPAR(1)) + CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, + 1 IPAR(1), ZERO, A, LDA) + Q(1) = DPAR(1) + Q(4) = DPAR(1) + Q(6) = DPAR(1) + X(1,1) = DPAR(1) + X(2,2) = DPAR(1) * (ONE + SQRT(FIVE)) / TWO + X(3,3) = DPAR(1) * (9.0D0 + SQRT(85.0D0)) / TWO + CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, X, LDX, + 1 ZERO, DWORK, IPAR(1)) + CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, + 1 IPAR(1), ZERO, X, LDX) + IDENT = '1000' +C + ELSE IF (NR(2) .EQ. 5) THEN + IF (LSAME(DEF, 'D')) THEN + DPAR(4) = .25D0 + DPAR(3) = ONE + DPAR(2) = ONE + DPAR(1) = .1D9 + END IF + IF (DPAR(1) .EQ. ZERO) THEN + INFO = 2 + ELSE + TEMP = DPAR(2) / DPAR(1) + BETA = DPAR(3) * TEMP + ALPHA = ONE - TEMP + A(1,1) = ALPHA + CALL DLASET('A', IPAR(1)-1, IPAR(1)-1, ZERO, ONE, A(2,1), + 1 LDA) + B(1,1) = BETA + C(1,4) = ONE + R(1) = DPAR(4) + IF (BETA .EQ. ZERO) THEN + INFO = 2 + ELSE + CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ONE, X, LDX) + BETA = BETA * BETA + TEMP = DPAR(4) * (ALPHA + ONE) * (ALPHA - ONE) + BETA + X(1,1) = (TEMP + SQRT(TEMP*TEMP + FOUR*BETA*DPAR(4))) + X(1,1) = X(1,1) / TWO / BETA + END IF + IDENT = '0010' + END IF + END IF +C + ELSE IF (NR(1) .EQ. 4) THEN + IF (NR(2) .EQ. 1) THEN + IF (LSAME(DEF,'D')) DPAR(1) = ONE + CALL DLASET('A', IPAR(1)-1, IPAR(1)-1, ZERO, ONE, A(1,2), LDA) + B(IPAR(1),1) = ONE + R(1) = DPAR(1) + DO 40 I = 1, IPAR(1) + X(I,I) = DBLE(I) + 40 CONTINUE + IDENT = '0110' + END IF + END IF +C + IF (INFO .NE. 0) GOTO 2001 +C .. set up data in required format .. +C + IF (BPAR(4)) THEN +C .. G is to be returned in product form .. + RDIMM = IPAR(1) + IF (IDENT(4:4) .EQ. '0') THEN +C .. invert R using Cholesky factorization, .. + CALL DPPTRF('L', IPAR(2), R, INFO) + IF (INFO .EQ. 0) THEN + CALL DPPTRI('L', IPAR(2), R, INFO) + IF (IDENT(1:1) .EQ. '0') THEN +C .. B is not identity matrix .. + DO 100 I = 1, IPAR(1) + CALL DSPMV('L', IPAR(2), ONE, R, B(I,1), LDB, ZERO, + 1 DWORK((I-1)*IPAR(1)+1), 1) + 100 CONTINUE + CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), + 1 B(1,1), LDB, ZERO, R, 1) + ISYMM = IPAR(1) + 1 + DO 110 I = 2, IPAR(1) + CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), + 1 B(I,1), LDB, ZERO, B(1,1), LDB) + CALL DCOPY(IPAR(1) - I + 1, B(1,I), LDB, R(ISYMM), 1) + ISYMM = ISYMM + (IPAR(1) - I + 1) + 110 CONTINUE + END IF + ELSE + IF (INFO .GT. 0) THEN + INFO = 3 + GOTO 2001 + END IF + END IF + ELSE +C .. R = identity .. + IF (IDENT(1:1) .EQ. '0') THEN +C .. B not identity matrix .. + IF (IPAR(2) .EQ. 1) THEN + CALL DLASET('L', NSYMM, 1, ZERO, ZERO, R, 1) + CALL DSPR('L', IPAR(1), ONE, B, 1, R) + ELSE + CALL DSYRK('L', 'N', IPAR(1), IPAR(2), ONE, B, LDB, ZERO, + 1 DWORK, IPAR(1)) + CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), R) + END IF + ELSE +C .. B = R = identity .. + ISYMM = 1 + DO 120 I = IPAR(1), 1, -1 + R(ISYMM) = ONE + ISYMM = ISYMM + I + 120 CONTINUE + END IF + END IF + ELSE + RDIMM = IPAR(2) + IF (IDENT(1:1) .EQ. '1') + 1 CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ONE, B, LDB) + IF (IDENT(4:4) .EQ. '1') THEN + ISYMM = 1 + DO 130 I = IPAR(2), 1, -1 + R(ISYMM) = ONE + ISYMM = ISYMM + I + 130 CONTINUE + END IF + END IF +C + IF (BPAR(1)) THEN +C .. Q is to be returned in product form .. + QDIMM = IPAR(1) + IF (IDENT(3:3) .EQ. '0') THEN + IF (IDENT(2:2) .EQ. '0') THEN +C .. C is not identity matrix .. + DO 140 I = 1, IPAR(1) + CALL DSPMV('L', IPAR(3), ONE, Q, C(1,I), 1, ZERO, + 1 DWORK((I-1)*IPAR(1)+1), 1) + 140 CONTINUE +C .. use Q(1:IPAR(1)) as workspace and compute the first column +C of Q at the end .. + ISYMM = IPAR(1) + 1 + DO 150 I = 2, IPAR(1) + CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), + 1 C(1,I), 1, ZERO, Q(1), 1) + CALL DCOPY(IPAR(1) - I + 1, Q(I), 1, Q(ISYMM), 1) + ISYMM = ISYMM + (IPAR(1) - I + 1) + 150 CONTINUE + CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), + 1 C(1,1), 1, ZERO, Q, 1) + END IF + ELSE +C .. Q = identity .. + IF (IDENT(2:2) .EQ. '0') THEN +C .. C is not identity matrix .. + IF (IPAR(3) .EQ. 1) THEN + CALL DLASET('L', NSYMM, 1, ZERO, ZERO, Q, 1) + CALL DSPR('L', IPAR(1), ONE, C, LDC, Q) + ELSE + CALL DSYRK('L', 'T', IPAR(1), IPAR(3), ONE, C, LDC, ZERO, + 1 DWORK, IPAR(1)) + CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), Q) + END IF + ELSE +C .. C = Q = identity .. + ISYMM = 1 + DO 160 I = IPAR(1), 1, -1 + Q(ISYMM) = ONE + ISYMM = ISYMM + I + 160 CONTINUE + END IF + END IF + ELSE + QDIMM = IPAR(3) + IF (IDENT(2:2) .EQ. '1') + 1 CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ONE, C, LDC) + IF (IDENT(3:3) .EQ. '1') THEN + ISYMM = 1 + DO 170 I = IPAR(3), 1, -1 + Q(ISYMM) = ONE + ISYMM = ISYMM + I + 170 CONTINUE + END IF + END IF +C +C .. unpack symmetric matrices if required .. + IF (BPAR(2)) THEN + ISYMM = (QDIMM * (QDIMM + 1)) / 2 + CALL DCOPY(ISYMM, Q, 1, DWORK, 1) + CALL MA02DD('Unpack', 'Lower', QDIMM, Q, LDQ, DWORK) + CALL MA02ED('Lower', QDIMM, Q, LDQ) + ELSE IF (BPAR(3)) THEN + CALL MA02DD('Unpack', 'Lower', QDIMM, DWORK, QDIMM, Q) + CALL MA02ED('Lower', QDIMM, DWORK, QDIMM) + CALL MA02DD('Pack', 'Upper', QDIMM, DWORK, QDIMM, Q) + END IF + IF (BPAR(5)) THEN + ISYMM = (RDIMM * (RDIMM + 1)) / 2 + CALL DCOPY(ISYMM, R, 1, DWORK, 1) + CALL MA02DD('Unpack', 'Lower', RDIMM, R, LDR, DWORK) + CALL MA02ED('Lower', RDIMM, R, LDR) + ELSE IF (BPAR(6)) THEN + CALL MA02DD('Unpack', 'Lower', RDIMM, DWORK, RDIMM, R) + CALL MA02ED('Lower', RDIMM, DWORK, RDIMM) + CALL MA02DD('Pack', 'Upper', RDIMM, DWORK, RDIMM, R) + END IF +C +C ...set VEC... + VEC(1) = .TRUE. + VEC(2) = .TRUE. + VEC(3) = .TRUE. + VEC(4) = .TRUE. + VEC(5) = .NOT. BPAR(4) + VEC(6) = .NOT. BPAR(1) + VEC(7) = .TRUE. + VEC(8) = .TRUE. + VEC(9) = BPAR(7) + IF (((NR(1) .EQ. 1) .AND. ((NR(2) .EQ. 1) .OR. + 1 (NR(2) .EQ. 3) .OR. (NR(2) .EQ. 4))) .OR. + 2 ((NR(1) .EQ. 2) .AND. ((NR(2). EQ. 1) .OR. + 3 (NR(2) .GE. 3))) .OR. (NR(1) .EQ. 4)) THEN + VEC(10) = .TRUE. + END IF + CHPAR = NOTES(NR(1),NR(2)) + N = IPAR(1) + M = IPAR(2) + P = IPAR(3) +C + 2001 CONTINUE + RETURN +C *** Last line of BB02AD *** + END diff --git a/mex/sources/libslicot/BB03AD.f b/mex/sources/libslicot/BB03AD.f new file mode 100644 index 000000000..d19c19105 --- /dev/null +++ b/mex/sources/libslicot/BB03AD.f @@ -0,0 +1,490 @@ + SUBROUTINE BB03AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA, + 1 Y, LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK, + 2 LDWORK, INFO) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate benchmark examples of (generalized) continuous-time +C Lyapunov equations +C +C T T +C A X E + E X A = Y . +C +C In some examples, the right hand side has the form +C +C T +C Y = - B B +C +C and the solution can be represented as a product of Cholesky +C factors +C +C T +C X = U U . +C +C E, A, Y, X, and U are real N-by-N matrices, and B is M-by-N. Note +C that E can be the identity matrix. For some examples, B, X, or U +C are not provided. +C +C This routine is an implementation of the benchmark library +C CTLEX (Version 1.0) described in [1]. +C +C ARGUMENTS +C +C Mode Parameters +C +C DEF CHARACTER*1 +C Specifies the kind of values used as parameters when +C generating parameter-dependent and scalable examples +C (i.e., examples with NR(1) = 2, 3, or 4): +C DEF = 'D' or 'd': Default values are used. +C DEF = 'N' or 'n': Values set in DPAR and IPAR are used. +C This parameter is not referenced if NR(1) = 1. +C Note that the scaling parameter of examples with +C NR(1) = 3 or 4 is considered as a regular parameter in +C this context. +C +C Input/Output Parameters +C +C NR (input) INTEGER array, dimension 2 +C Specifies the index of the desired example according +C to [1]. +C NR(1) defines the group: +C 1 : parameter-free problems of fixed size +C 2 : parameter-dependent problems of fixed size +C 3 : parameter-free problems of scalable size +C 4 : parameter-dependent problems of scalable size +C NR(2) defines the number of the benchmark example +C within a certain group according to [1]. +C +C DPAR (input/output) DOUBLE PRECISION array, dimension 2 +C On entry, if DEF = 'N' or 'n' and the desired example +C depends on real parameters, then the array DPAR must +C contain the values for these parameters. +C For an explanation of the parameters see [1]. +C For Example 4.1, DPAR(1) and DPAR(2) define 'r' and 's', +C respectively. +C For Example 4.2, DPAR(1) and DPAR(2) define 'lambda' and +C 's', respectively. +C For Examples 4.3 and 4.4, DPAR(1) defines the parameter +C 't'. +C On exit, if DEF = 'D' or 'd' and the desired example +C depends on real parameters, then the array DPAR is +C overwritten by the default values given in [1]. +C +C IPAR (input/output) INTEGER array of DIMENSION at least 1 +C On entry, if DEF = 'N' or 'n' and the desired example +C depends on integer parameters, then the array IPAR must +C contain the values for these parameters. +C For an explanation of the parameters see [1]. +C For Examples 4.1, 4.2, and 4.3, IPAR(1) defines 'n'. +C For Example 4.4, IPAR(1) defines 'q'. +C On exit, if DEF = 'D' or 'd' and the desired example +C depends on integer parameters, then the array IPAR is +C overwritten by the default values given in [1]. +C +C VEC (output) LOGICAL array, dimension 8 +C Flag vector which displays the availability of the output +C data: +C VEC(1) and VEC(2) refer to N and M, respectively, and are +C always .TRUE. +C VEC(3) is .TRUE. iff E is NOT the identity matrix. +C VEC(4) and VEC(5) refer to A and Y, respectively, and are +C always .TRUE. +C VEC(6) is .TRUE. iff B is provided. +C VEC(7) is .TRUE. iff the solution matrix X is provided. +C VEC(8) is .TRUE. iff the Cholesky factor U is provided. +C +C N (output) INTEGER +C The actual state dimension, i.e., the order of the +C matrices E and A. +C +C M (output) INTEGER +C The number of rows in the matrix B. If B is not provided +C for the desired example, M = 0 is returned. +C +C E (output) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N part of this array contains the +C matrix E. +C NOTE that this array is overwritten (by the identity +C matrix), if VEC(3) = .FALSE. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= N. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the +C matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,N) +C The leading N-by-N part of this array contains the +C matrix Y. +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= N. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,N) +C The leading M-by-N part of this array contains the +C matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= M. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array contains the +C matrix X. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= N. +C +C U (output) DOUBLE PRECISION array, dimension (LDU,N) +C The leading N-by-N part of this array contains the +C matrix U. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= N. +C +C NOTE (output) CHARACTER*70 +C String containing short information about the chosen +C example. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C For Examples 4.1 and 4.2., LDWORK >= 2*IPAR(1) is +C required. +C For the other examples, no workspace is needed, i.e., +C LDWORK >= 1. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; in particular, INFO = -3 or -4 indicates +C that at least one of the parameters in DPAR or +C IPAR, respectively, has an illegal value. +C +C REFERENCES +C +C [1] D. Kressner, V. Mehrmann, and T. Penzl. +C CTLEX - a Collection of Benchmark Examples for Continuous- +C Time Lyapunov Equations. +C SLICOT Working Note 1999-6, 1999. +C +C NUMERICAL ASPECTS +C +C None +C +C CONTRIBUTOR +C +C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) +C +C For questions concerning the collection or for the submission of +C test examples, please contact Volker Mehrmann +C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). +C +C REVISIONS +C +C June 1999, V. Sima. +C +C KEYWORDS +C +C continuous-time Lyapunov equations +C +C ******************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR + PARAMETER (ZERO = .0D0, ONE = .1D1, TWO = .2D1, + 1 THREE = .3D1, FOUR = .4D1) +C .. Scalar Arguments .. + CHARACTER DEF + CHARACTER*70 NOTE + INTEGER INFO, LDA, LDB, LDE, LDU, LDWORK, LDX, LDY, M, N +C .. Array Arguments .. + LOGICAL VEC(8) + INTEGER IPAR(*), NR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), DPAR(*), DWORK(LDWORK), + 1 E(LDE,*), U(LDU,*), X(LDX,*), Y(LDY,*) +C .. Local Scalars .. + INTEGER I, J, K + DOUBLE PRECISION TEMP, TTM1, TTP1, TWOBYN +C .. Local Arrays .. + LOGICAL VECDEF(8) +C .. External Functions .. +C . BLAS . + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C . LAPACK . + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. +C . BLAS . + EXTERNAL DGEMV, DGER, DAXPY +C . LAPACK . + EXTERNAL DLASET +C .. Intrinsic Functions .. + INTRINSIC DBLE, MIN, MOD +C .. Data Statements .. +C . default values for availabilities . + DATA VECDEF /.TRUE., .TRUE., .FALSE., .TRUE., + 1 .TRUE., .FALSE., .FALSE., .FALSE./ +C +C .. Executable Statements .. +C + INFO = 0 + DO 10 I = 1, 8 + VEC(I) = VECDEF(I) + 10 CONTINUE +C + IF (NR(1) .EQ. 4) THEN + IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN + INFO = -1 + RETURN + END IF +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'CTLEX: Example 4.1' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 10 + DPAR(1) = .15D1 + DPAR(2) = .15D1 + END IF + IF ((DPAR(1) .LE. ONE) .OR. (DPAR(2) .LE. ONE)) INFO = -3 + IF (IPAR(1) .LT. 2) INFO = -4 + N = IPAR(1) + M = 1 + IF (LDE .LT. N) INFO = -9 + IF (LDA .LT. N) INFO = -11 + IF (LDY .LT. N) INFO = -13 + IF (LDB .LT. M) INFO = -15 + IF (LDX .LT. N) INFO = -17 + IF (LDWORK .LT. N*2) INFO = -22 + IF (INFO .NE. 0) RETURN +C + VEC(6) = .TRUE. + VEC(7) = .TRUE. + TWOBYN = TWO / DBLE( N ) + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) + CALL DLASET('A', M, N, ZERO, ZERO, B, LDB) + CALL DLASET('A', N, N, ZERO, ZERO, X, LDX) + DO 30 J = 1, N + TEMP = DPAR(1) ** (J-1) + A(J,J) = -TEMP + DWORK(J) = ONE + DO 20 I = 1, N + X(I,J) = DBLE( I*J ) / (TEMP + DPAR(1)**(I-1)) + 20 CONTINUE + 30 CONTINUE +C H1 * A + CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) +C A * H1 + CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) +C H1 * X + CALL DGEMV('T', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, X, LDX) +C X * H1 + CALL DGEMV('N', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, X, LDX) +C S A INV(S), INV(S) X INV(S), B INV(S) + DO 50 J = 1, N + B(1,J) = DBLE( J-N-1 ) / (DPAR(2)**(J-1)) + DO 40 I = 1, N + X(I,J) = X(I,J) / (DPAR(2)**(I+J-2)) + A(I,J) = A(I,J) * (DPAR(2)**(I-J)) + 40 CONTINUE + DWORK(J) = ONE - TWO * MOD(J,2) + 50 CONTINUE +C H2 * A + CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) +C A * H2 + CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) +C H2 * X + CALL DGEMV('T', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, X, LDX) +C X * H2 + CALL DGEMV('N', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, X, LDX) +C B * H2 + CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, + 1 B, LDB) +C Y = -B' * B + CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) +C + ELSE IF (NR(2) .EQ. 2) THEN + NOTE = 'CTLEX: Example 4.2' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 10 + DPAR(1) = -.5D0 + DPAR(2) = .15D1 + END IF + IF ((DPAR(1) .GE. ZERO) .OR. (DPAR(2) .LE. ONE)) INFO = -3 + IF (IPAR(1) .LT. 2) INFO = -4 + N = IPAR(1) + M = 1 + IF (LDE .LT. N) INFO = -9 + IF (LDA .LT. N) INFO = -11 + IF (LDY .LT. N) INFO = -13 + IF (LDB .LT. M) INFO = -15 + IF (LDWORK .LT. N*2) INFO = -22 + IF (INFO .NE. 0) RETURN +C + VEC(6) = .TRUE. + TWOBYN = TWO / DBLE( N ) + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, DPAR(1), A, LDA) + CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) + CALL DLASET('A', M, N, -TWOBYN, ONE - TWOBYN, B, LDB) + DO 60 I = 1, N-1 + DWORK(I) = ONE + A(I,I+1) = ONE + 60 CONTINUE + DWORK(N) = ONE +C H1 * A + CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) +C A * H1 + CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) +C S A INV(S), B INV(S) + DO 80 J = 1, N + B(1,J) = B(1,J) / (DPAR(2)**(J-1)) + DO 70 I = 1, N + A(I,J) = A(I,J) * (DPAR(2)**(I-J)) + 70 CONTINUE + DWORK(J) = ONE - TWO * MOD(J,2) + 80 CONTINUE +C H2 * A + CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) +C A * H2 + CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) +C B * H2 + CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, + 1 B, LDB) +C Y = -B' * B + CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) +C + ELSE IF (NR(2) .EQ. 3) THEN + NOTE = 'CTLEX: Example 4.3' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 10 + DPAR(1) = .1D2 + END IF + IF (DPAR(1) .LT. ZERO) INFO = -3 + IF (IPAR(1) .LT. 2) INFO = -4 + N = IPAR(1) + M = 0 + IF (LDE .LT. N) INFO = -9 + IF (LDA .LT. N) INFO = -11 + IF (LDY .LT. N) INFO = -13 + IF (LDX .LT. N) INFO = -17 + IF (INFO .NE. 0) RETURN +C + VEC(3) = .TRUE. + VEC(7) = .TRUE. + TEMP = TWO ** (-DPAR(1)) + CALL DLASET('U', N, N, ZERO, ZERO, E, LDE) + CALL DLASET('L', N, N, TEMP, ONE, E, LDE) + CALL DLASET('L', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('U', N, N, ONE, ZERO, A, LDA) + CALL DLASET('A', N, N, ONE, ONE, X, LDX) + DO 90 I = 1, N + A(I,I) = DBLE( I - 1 ) + TEMP + 90 CONTINUE + Y(1,1) = TWO * TEMP + TWO * DBLE( N-1 ) * TEMP**2 + TTP1 = TWO * DBLE( N+1 ) * TEMP + TWO - TEMP**2 + TTM1 = TWO * DBLE( N-1 ) * TEMP + TWO - TEMP**2 + DO 100 I = 2, N + Y(I,1) = Y(1,1) + DBLE( I-1 ) * TTM1 + 100 CONTINUE + DO 120 J = 2, N + DO 110 I = 1, N + Y(I,J) = Y(I,1) + DBLE( J-1 ) * (TTP1 - FOUR * I * TEMP) + 110 CONTINUE + 120 CONTINUE +C + ELSE IF (NR(2) .EQ. 4) THEN + NOTE = 'CTLEX: Example 4.4' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 10 + DPAR(1) = .15D1 + END IF + IF (DPAR(1) .LT. ONE) INFO = -3 + IF (IPAR(1) .LT. 1) INFO = -4 + N = IPAR(1) * 3 + M = 1 + IF (LDE .LT. N) INFO = -9 + IF (LDA .LT. N) INFO = -11 + IF (LDY .LT. N) INFO = -13 + IF (LDB .LT. M) INFO = -15 + IF (INFO .NE. 0) RETURN +C + VEC(3) = .TRUE. + VEC(6) = .TRUE. + CALL DLASET('A', N, N, ZERO, ZERO, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + DO 150 I = 1, IPAR(1) + TEMP = -DPAR(1)**I + DO 140 J = 1, I - 1 + DO 130 K = 0, 2 + A(N - I*3+3, J*3-K) = TEMP + A(N - I*3+2, J*3-K) = TWO * TEMP + 130 CONTINUE + 140 CONTINUE + A(N - I*3+3, I*3-2) = TEMP + A(N - I*3+2, I*3-2) = TWO * TEMP + A(N - I*3+2, I*3-1) = TWO * TEMP + A(N - I*3+2, I*3 ) = TEMP + A(N - I*3+1, I*3 ) = TEMP + 150 CONTINUE + DO 170 J = 1, N + IF (J .GT. 1) CALL DAXPY(N, ONE, A(J-1,1), LDA, A(J,1), LDA) + B(1, J) = DBLE( J ) + DO 160 I = 1, N + E(I,N-J+1) = DBLE( MIN( I, J ) ) + Y(I,J) = -DBLE( I*J ) + 160 CONTINUE + 170 CONTINUE +C + ELSE + INFO = -2 + END IF + ELSE + INFO = -2 + END IF +C + RETURN +C *** Last Line of BB03AD *** + END diff --git a/mex/sources/libslicot/BB04AD.f b/mex/sources/libslicot/BB04AD.f new file mode 100644 index 000000000..a017a8808 --- /dev/null +++ b/mex/sources/libslicot/BB04AD.f @@ -0,0 +1,476 @@ + SUBROUTINE BB04AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA, + 1 Y, LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK, + 2 LDWORK, INFO) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate benchmark examples of (generalized) discrete-time +C Lyapunov equations +C +C T T +C A X A - E X E = Y . +C +C In some examples, the right hand side has the form +C +C T +C Y = - B B +C +C and the solution can be represented as a product of Cholesky +C factors +C +C T +C X = U U . +C +C E, A, Y, X, and U are real N-by-N matrices, and B is M-by-N. Note +C that E can be the identity matrix. For some examples, B, X, or U +C are not provided. +C +C This routine is an implementation of the benchmark library +C DTLEX (Version 1.0) described in [1]. +C +C ARGUMENTS +C +C Mode Parameters +C +C DEF CHARACTER*1 +C Specifies the kind of values used as parameters when +C generating parameter-dependent and scalable examples +C (i.e., examples with NR(1) = 2, 3, or 4): +C DEF = 'D' or 'd': Default values are used. +C DEF = 'N' or 'n': Values set in DPAR and IPAR are used. +C This parameter is not referenced if NR(1) = 1. +C Note that the scaling parameter of examples with +C NR(1) = 3 or 4 is considered as a regular parameter in +C this context. +C +C Input/Output Parameters +C +C NR (input) INTEGER array, dimension 2 +C Specifies the index of the desired example according +C to [1]. +C NR(1) defines the group: +C 1 : parameter-free problems of fixed size +C 2 : parameter-dependent problems of fixed size +C 3 : parameter-free problems of scalable size +C 4 : parameter-dependent problems of scalable size +C NR(2) defines the number of the benchmark example +C within a certain group according to [1]. +C +C DPAR (input/output) DOUBLE PRECISION array, dimension 2 +C On entry, if DEF = 'N' or 'n' and the desired example +C depends on real parameters, then the array DPAR must +C contain the values for these parameters. +C For an explanation of the parameters see [1]. +C For Example 4.1, DPAR(1) and DPAR(2) define 'r' and 's', +C respectively. +C For Example 4.2, DPAR(1) and DPAR(2) define 'lambda' and +C 's', respectively. +C For Examples 4.3 and 4.4, DPAR(1) defines the parameter +C 't'. +C On exit, if DEF = 'D' or 'd' and the desired example +C depends on real parameters, then the array DPAR is +C overwritten by the default values given in [1]. +C +C IPAR (input/output) INTEGER array of DIMENSION at least 1 +C On entry, if DEF = 'N' or 'n' and the desired example +C depends on integer parameters, then the array IPAR must +C contain the values for these parameters. +C For an explanation of the parameters see [1]. +C For Examples 4.1, 4.2, and 4.3, IPAR(1) defines 'n'. +C For Example 4.4, IPAR(1) defines 'q'. +C On exit, if DEF = 'D' or 'd' and the desired example +C depends on integer parameters, then the array IPAR is +C overwritten by the default values given in [1]. +C +C VEC (output) LOGICAL array, dimension 8 +C Flag vector which displays the availability of the output +C data: +C VEC(1) and VEC(2) refer to N and M, respectively, and are +C always .TRUE. +C VEC(3) is .TRUE. iff E is NOT the identity matrix. +C VEC(4) and VEC(5) refer to A and Y, respectively, and are +C always .TRUE. +C VEC(6) is .TRUE. iff B is provided. +C VEC(7) is .TRUE. iff the solution matrix X is provided. +C VEC(8) is .TRUE. iff the Cholesky factor U is provided. +C +C N (output) INTEGER +C The actual state dimension, i.e., the order of the +C matrices E and A. +C +C M (output) INTEGER +C The number of rows in the matrix B. If B is not provided +C for the desired example, M = 0 is returned. +C +C E (output) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N part of this array contains the +C matrix E. +C NOTE that this array is overwritten (by the identity +C matrix), if VEC(3) = .FALSE. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= N. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the +C matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,N) +C The leading N-by-N part of this array contains the +C matrix Y. +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= N. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,N) +C The leading M-by-N part of this array contains the +C matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= M. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array contains the +C matrix X. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= N. +C +C U (output) DOUBLE PRECISION array, dimension (LDU,N) +C The leading N-by-N part of this array contains the +C matrix U. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= N. +C +C NOTE (output) CHARACTER*70 +C String containing short information about the chosen +C example. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C For Examples 4.1 and 4.2., LDWORK >= 2*IPAR(1) is +C required. +C For the other examples, no workspace is needed, i.e., +C LDWORK >= 1. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; in particular, INFO = -3 or -4 indicates +C that at least one of the parameters in DPAR or +C IPAR, respectively, has an illegal value. +C +C REFERENCES +C +C [1] D. Kressner, V. Mehrmann, and T. Penzl. +C DTLEX - a Collection of Benchmark Examples for Discrete- +C Time Lyapunov Equations. +C SLICOT Working Note 1999-7, 1999. +C +C NUMERICAL ASPECTS +C +C None +C +C CONTRIBUTOR +C +C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) +C +C For questions concerning the collection or for the submission of +C test examples, please contact Volker Mehrmann +C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). +C +C REVISIONS +C +C June 1999, V. Sima. +C +C KEYWORDS +C +C discrete-time Lyapunov equations +C +C ******************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR + PARAMETER (ZERO = .0D0, ONE = .1D1, TWO = .2D1, + 1 THREE = .3D1, FOUR = .4D1) +C .. Scalar Arguments .. + CHARACTER DEF + CHARACTER*70 NOTE + INTEGER INFO, LDA, LDB, LDE, LDU, LDWORK, LDX, LDY, M, N +C .. Array Arguments .. + LOGICAL VEC(8) + INTEGER IPAR(*), NR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), DPAR(*), DWORK(LDWORK), + 1 E(LDE,*), U(LDU,*), X(LDX,*), Y(LDY,*) +C .. Local Scalars .. + INTEGER I, J, K + DOUBLE PRECISION TEMP, TTEMP, TWOBYN +C .. Local Arrays .. + LOGICAL VECDEF(8) +C .. External Functions .. +C . BLAS . + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C . LAPACK . + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. +C . BLAS . + EXTERNAL DGEMV, DGER, DAXPY +C . LAPACK . + EXTERNAL DLASET +C .. Intrinsic Functions .. + INTRINSIC DBLE, MIN, MOD, SQRT +C .. Data Statements .. +C . default values for availabilities . + DATA VECDEF /.TRUE., .TRUE., .FALSE., .TRUE., + 1 .TRUE., .FALSE., .FALSE., .FALSE./ +C +C .. Executable Statements .. +C + INFO = 0 + DO 10 I = 1, 8 + VEC(I) = VECDEF(I) + 10 CONTINUE +C + IF (NR(1) .EQ. 4) THEN + IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN + INFO = -1 + RETURN + END IF +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'DTLEX: Example 4.1' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 10 + DPAR(1) = .15D1 + DPAR(2) = .15D1 + END IF + IF ((DPAR(1) .LE. ONE) .OR. (DPAR(2) .LE. ONE)) INFO = -3 + IF (IPAR(1) .LT. 2) INFO = -4 + N = IPAR(1) + M = 1 + IF (LDE .LT. N) INFO = -9 + IF (LDA .LT. N) INFO = -11 + IF (LDY .LT. N) INFO = -13 + IF (LDB .LT. M) INFO = -15 + IF (LDX .LT. N) INFO = -17 + IF (LDWORK .LT. N*2) INFO = -22 + IF (INFO .NE. 0) RETURN +C + VEC(6) = .TRUE. + VEC(7) = .TRUE. + TWOBYN = TWO / DBLE( N ) + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) + CALL DLASET('A', M, N, -TWOBYN, ONE - TWOBYN, B, LDB) + CALL DLASET('A', N, N, ZERO, ZERO, X, LDX) + DO 20 I = 1, N + TEMP = DPAR(1) ** (I-1) + A(I,I) = (TEMP-ONE) / (TEMP+ONE) + DWORK(I) = ONE + 20 CONTINUE +C H1 * A + CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) +C A * H1 + CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) +C S A INV(S), B INV(S) + DO 40 J = 1, N + B(1,J) = B(1,J) / (DPAR(2)**(J-1)) + DO 30 I = 1, N + A(I,J) = A(I,J) * (DPAR(2)**(I-J)) + 30 CONTINUE + DWORK(J) = ONE - TWO * MOD(J,2) + 40 CONTINUE +C H2 * A + CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) +C A * H2 + CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) +C B * H2 + CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, + 1 B, LDB) +C Y = -B' * B + CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) +C X = -Y + DO 50 J = 1, N + CALL DAXPY(N, -ONE, Y(1,J), 1, X(1,J), 1) + 50 CONTINUE +C + ELSE IF (NR(2) .EQ. 2) THEN + NOTE = 'DTLEX: Example 4.2' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 10 + DPAR(1) = -.5D0 + DPAR(2) = .15D1 + END IF + IF ((DPAR(1) .LE. -ONE) .OR. (DPAR(1) .GE. ONE) .OR. + 1 (DPAR(2) .LE. ONE)) INFO = -3 + IF (IPAR(1) .LT. 2) INFO = -4 + N = IPAR(1) + M = 1 + IF (LDE .LT. N) INFO = -9 + IF (LDA .LT. N) INFO = -11 + IF (LDY .LT. N) INFO = -13 + IF (LDB .LT. M) INFO = -15 + IF (LDWORK .LT. N*2) INFO = -22 + IF (INFO .NE. 0) RETURN +C + VEC(6) = .TRUE. + TWOBYN = TWO / DBLE( N ) + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, DPAR(1), A, LDA) + CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) + CALL DLASET('A', M, N, -TWOBYN, ONE - TWOBYN, B, LDB) + DO 60 I = 1, N-1 + DWORK(I) = ONE + A(I,I+1) = ONE + 60 CONTINUE + DWORK(N) = ONE +C H1 * A + CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) +C A * H1 + CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) +C S A INV(S), B INV(S) + DO 80 J = 1, N + B(1,J) = B(1,J) / (DPAR(2)**(J-1)) + DO 70 I = 1, N + A(I,J) = A(I,J) * (DPAR(2)**(I-J)) + 70 CONTINUE + DWORK(J) = ONE - TWO * MOD(J,2) + 80 CONTINUE +C H2 * A + CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) +C A * H2 + CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) +C B * H2 + CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, + 1 B, LDB) +C Y = -B' * B + CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) +C + ELSE IF (NR(2) .EQ. 3) THEN + NOTE = 'DTLEX: Example 4.3' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 10 + DPAR(1) = .1D2 + END IF + IF (DPAR(1) .LT. ZERO) INFO = -3 + IF (IPAR(1) .LT. 2) INFO = -4 + N = IPAR(1) + M = 0 + IF (LDE .LT. N) INFO = -9 + IF (LDA .LT. N) INFO = -11 + IF (LDY .LT. N) INFO = -13 + IF (LDX .LT. N) INFO = -17 + IF (INFO .NE. 0) RETURN +C + VEC(3) = .TRUE. + VEC(7) = .TRUE. + TEMP = TWO ** (-DPAR(1)) + CALL DLASET('U', N, N, ZERO, ZERO, E, LDE) + CALL DLASET('L', N, N, TEMP, ONE, E, LDE) + CALL DLASET('L', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('U', N, N, ONE, ZERO, A, LDA) + CALL DLASET('A', N, N, ONE, ONE, X, LDX) + DO 90 I = 1, N + A(I,I) = DBLE( I ) + TEMP + 90 CONTINUE + DO 110 J = 1, N + DO 100 I = 1, N + Y(I,J) = TEMP * TEMP * DBLE( 1 - (N-I) * (N-J) ) + + 1 TEMP * DBLE( 3 * (I+J) - 2 * (N+1) ) + + 2 FOUR*DBLE( I*J ) - TWO * DBLE( I+J ) + 100 CONTINUE + 110 CONTINUE +C + ELSE IF (NR(2) .EQ. 4) THEN + NOTE = 'DTLEX: Example 4.4' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 10 + DPAR(1) = .15D1 + END IF + IF (DPAR(1) .LT. ONE) INFO = -3 + IF (IPAR(1) .LT. 1) INFO = -4 + N = IPAR(1) * 3 + M = 1 + IF (LDE .LT. N) INFO = -9 + IF (LDA .LT. N) INFO = -11 + IF (LDY .LT. N) INFO = -13 + IF (LDB .LT. M) INFO = -15 + IF (INFO .NE. 0) RETURN +C + VEC(3) = .TRUE. + VEC(6) = .TRUE. + CALL DLASET('A', N, N, ZERO, ZERO, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + DO 140 I = 1, IPAR(1) + TTEMP = ONE - ONE / (DPAR(1)**I) + TEMP = - TTEMP / SQRT( TWO ) + DO 130 J = 1, I - 1 + DO 120 K = 0, 2 + A(N - I*3+3, J*3-K) = TTEMP + A(N - I*3+2, J*3-K) = TWO * TEMP + 120 CONTINUE + 130 CONTINUE + A(N - I*3+3, I*3-2) = TTEMP + A(N - I*3+2, I*3-2) = TWO * TEMP + A(N - I*3+2, I*3-1) = TWO * TEMP + A(N - I*3+2, I*3 ) = TEMP + A(N - I*3+1, I*3 ) = TEMP + 140 CONTINUE + DO 160 J = 1, N + IF (J .GT. 1) CALL DAXPY(N, ONE, A(J-1,1), LDA, A(J,1), LDA) + B(1, J) = DBLE( J ) + DO 150 I = 1, N + E(I,N-J+1) = DBLE( MIN(I,J) ) + Y(I,J) = -DBLE( I*J ) + 150 CONTINUE + 160 CONTINUE +C + ELSE + INFO = -2 + END IF + ELSE + INFO = -2 + END IF +C + RETURN +C *** Last Line of BB04AD *** + END diff --git a/mex/sources/libslicot/BD01AD.f b/mex/sources/libslicot/BD01AD.f new file mode 100644 index 000000000..9cc34c065 --- /dev/null +++ b/mex/sources/libslicot/BD01AD.f @@ -0,0 +1,1017 @@ + SUBROUTINE BD01AD( DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A, + 1 LDA, B, LDB, C, LDC, D, LDD, NOTE, DWORK, + 2 LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate benchmark examples for time-invariant, +C continuous-time dynamical systems +C +C . +C E x(t) = A x(t) + B u(t) +C +C y(t) = C x(t) + D u(t) +C +C E, A are real N-by-N matrices, B is N-by-M, C is P-by-N, and +C D is P-by-M. In many examples, E is the identity matrix and D is +C the zero matrix. +C +C This routine is an implementation of the benchmark library +C CTDSX (Version 1.0) described in [1]. +C +C ARGUMENTS +C +C Mode Parameters +C +C DEF CHARACTER*1 +C Specifies the kind of values used as parameters when +C generating parameter-dependent and scalable examples +C (i.e., examples with NR(1) = 2, 3, or 4): +C = 'D': Default values defined in [1] are used; +C = 'N': Values set in DPAR and IPAR are used. +C This parameter is not referenced if NR(1) = 1. +C Note that the scaling parameter of examples with +C NR(1) = 3 or 4 is considered as a regular parameter in +C this context. +C +C Input/Output Parameters +C +C NR (input) INTEGER array, dimension (2) +C Specifies the index of the desired example according +C to [1]. +C NR(1) defines the group: +C 1 : parameter-free problems of fixed size +C 2 : parameter-dependent problems of fixed size +C 3 : parameter-free problems of scalable size +C 4 : parameter-dependent problems of scalable size +C NR(2) defines the number of the benchmark example +C within a certain group according to [1]. +C +C DPAR (input/output) DOUBLE PRECISION array, dimension (7) +C On entry, if DEF = 'N' and the desired example depends on +C real parameters, then the array DPAR must contain the +C values for these parameters. +C For an explanation of the parameters see [1]. +C For Examples 2.1 and 2.2, DPAR(1) defines the parameter +C 'epsilon'. +C For Example 2.4, DPAR(1), ..., DPAR(7) define 'b', 'mu', +C 'r', 'r_c', 'k_l', 'sigma', 'a', respectively. +C For Example 2.7, DPAR(1) and DPAR(2) define 'mu' and 'nu', +C respectively. +C For Example 4.1, DPAR(1), ..., DPAR(7) define 'a', 'b', +C 'c', 'beta_1', 'beta_2', 'gamma_1', 'gamma_2', +C respectively. +C For Example 4.2, DPAR(1), ..., DPAR(3) define 'mu', +C 'delta', 'kappa', respectively. +C On exit, if DEF = 'D' and the desired example depends on +C real parameters, then the array DPAR is overwritten by the +C default values given in [1]. +C +C IPAR (input/output) INTEGER array, dimension (1) +C On entry, if DEF = 'N' and the desired example depends on +C integer parameters, then the array IPAR must contain the +C values for these parameters. +C For an explanation of the parameters see [1]. +C For Examples 2.3, 2.5, and 2.6, IPAR(1) defines the +C parameter 's'. +C For Example 3.1, IPAR(1) defines 'q'. +C For Examples 3.2 and 3.3, IPAR(1) defines 'n'. +C For Example 3.4, IPAR(1) defines 'l'. +C For Example 4.1, IPAR(1) defines 'n'. +C For Example 4.2, IPAR(1) defines 'l'. +C On exit, if DEF = 'D' and the desired example depends on +C integer parameters, then the array IPAR is overwritten by +C the default values given in [1]. +C +C VEC (output) LOGICAL array, dimension (8) +C Flag vector which displays the availabilty of the output +C data: +C VEC(1), ..., VEC(3) refer to N, M, and P, respectively, +C and are always .TRUE.. +C VEC(4) is .TRUE. iff E is NOT the identity matrix. +C VEC(5), ..., VEC(7) refer to A, B, and C, respectively, +C and are always .TRUE.. +C VEC(8) is .TRUE. iff D is NOT the zero matrix. +C +C N (output) INTEGER +C The actual state dimension, i.e., the order of the +C matrices E and A. +C +C M (output) INTEGER +C The number of columns in the matrices B and D. +C +C P (output) INTEGER +C The number of rows in the matrices C and D. +C +C E (output) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N part of this array contains the +C matrix E. +C NOTE that this array is overwritten (by the identity +C matrix), if VEC(4) = .FALSE.. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= N. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the +C matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array contains the +C matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= N. +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array contains the +C matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= P. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array contains the +C matrix D. +C NOTE that this array is overwritten (by the zero +C matrix), if VEC(8) = .FALSE.. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= P. +C +C NOTE (output) CHARACTER*70 +C String containing short information about the chosen +C example. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C For Example 3.4, LDWORK >= 4*IPAR(1) is required. +C For the other examples, no workspace is needed, i.e., +C LDWORK >= 1. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; in particular, INFO = -3 or -4 indicates +C that at least one of the parameters in DPAR or +C IPAR, respectively, has an illegal value; +C = 1: data file can not be opened or has wrong format. +C +C +C REFERENCES +C +C [1] Kressner, D., Mehrmann, V. and Penzl, T. +C CTDSX - a Collection of Benchmark Examples for State-Space +C Realizations of Continuous-Time Dynamical Systems. +C SLICOT Working Note 1998-9. 1998. +C +C NUMERICAL ASPECTS +C +C None +C +C CONTRIBUTOR +C +C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) +C +C For questions concerning the collection or for the submission of +C test examples, please contact Volker Mehrmann +C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). +C +C REVISIONS +C +C June 1999, V. Sima. +C +C KEYWORDS +C +C continuous-time dynamical systems +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, PI + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + 1 THREE = 3.0D0, FOUR = 4.0D0, + 2 PI = .3141592653589793D1 ) +C .. Scalar Arguments .. + CHARACTER DEF + CHARACTER*70 NOTE + INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, M, N, P +C .. Array Arguments .. + LOGICAL VEC(8) + INTEGER IPAR(*), NR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DPAR(*), + 1 DWORK(*), E(LDE,*) +C .. Local Scalars .. + CHARACTER*12 DATAF + INTEGER I, J, L, STATUS + DOUBLE PRECISION APPIND, B1, B2, C1, C2, TEMP, TTEMP +C .. Local Arrays .. + LOGICAL VECDEF(8) +C .. External Functions .. +C . LAPACK . + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. +C . BLAS . + EXTERNAL DSCAL +C . LAPACK . + EXTERNAL DLASET +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN, MOD +C .. Data Statements .. +C . default values for availabities . + DATA VECDEF /.TRUE., .TRUE., .TRUE., .FALSE., + 1 .TRUE., .TRUE., .TRUE., .FALSE./ +C +C .. Executable Statements .. +C + INFO = 0 + DO 10 I = 1, 8 + VEC(I) = VECDEF(I) +10 CONTINUE +C + IF (NR(1) .EQ. 1) THEN +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'Laub 1979, Ex.1' + N = 2 + M = 1 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(1,2) = ONE + B(1,1) = ZERO + B(2,1) = ONE + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 2) THEN + NOTE = 'Laub 1979, Ex.2: uncontrollable-unobservable data' + N = 2 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + A(1,1) = FOUR + A(2,1) = -.45D1 + A(1,2) = .3D1 + A(2,2) = -.35D1 + B(1,1) = ONE + B(2,1) = -ONE + C(1,1) = THREE + C(1,2) = TWO + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 3) THEN + NOTE = 'Beale/Shafai 1989: model of L-1011 aircraft' + N = 4 + M = 2 + P = 4 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 4) THEN + NOTE = 'Bhattacharyya et al. 1983: binary distillation column' + N = 8 + M = 2 + P = 8 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 5) THEN + NOTE = 'Patnaik et al. 1980: tubular ammonia reactor' + N = 9 + M = 3 + P = 9 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 6) THEN + NOTE = 'Davison/Gesing 1978: J-100 jet engine' + N = 30 + M = 3 + P = 5 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 7) THEN + NOTE = 'Davison 1967: binary distillation column' + N = 11 + M = 3 + P = 3 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(2,1) = ONE + C(1,10) = ONE + C(3,11) = ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) + + ELSE IF (NR(2) .EQ. 8) THEN + NOTE = 'Chien/Ergin/Ling/Lee 1958: drum boiler' + N = 9 + M = 3 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,6) = ONE + C(2,9) = ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 9) THEN + NOTE = 'Ly, Gangsaas 1981: B-767 airplane' + N = 55 + M = 2 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 10) THEN + NOTE = 'control surface servo for an underwater vehicle' + N = 8 + M = 2 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,7) = ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) + ELSE + INFO = -2 + END IF +C + IF ((NR(2) .GE. 3) .AND. (NR(2) .LE. 10)) THEN +C .. loading data files + WRITE (DATAF(1:11), '(A,I2.2,A)') 'BD011', NR(2), '.dat' + OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = DATAF(1:11)) + IF (STATUS .NE. 0) THEN + INFO = 1 + ELSE + DO 110 I = 1, N + READ (1, FMT = *, IOSTAT = STATUS) (A(I,J), J = 1, N) + IF (STATUS .NE. 0) INFO = 1 +110 CONTINUE + DO 120 I = 1, N + READ (1, FMT = *, IOSTAT = STATUS) (B(I,J), J = 1, M) + IF (STATUS .NE. 0) INFO = 1 +120 CONTINUE + IF ((NR(2) .EQ. 6) .OR. (NR(2) .EQ. 9)) THEN + DO 130 I = 1, P + READ (1, FMT = *, IOSTAT = STATUS) (C(I,J), J = 1, N) + IF (STATUS .NE. 0) INFO = 1 +130 CONTINUE + END IF + END IF + CLOSE(1) + END IF +C + ELSE IF (NR(1) .EQ. 2) THEN + IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN + INFO = -1 + RETURN + END IF +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'Chow/Kokotovic 1976: magnetic tape control system' + IF (LSAME(DEF,'D')) DPAR(1) = 1D-6 + IF (DPAR(1) .EQ. ZERO) INFO = -3 + N = 4 + M = 1 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(1,2) = .400D0 + A(2,3) = .345D0 + A(3,2) = -.524D0/DPAR(1) + A(3,3) = -.465D0/DPAR(1) + A(3,4) = .262D0/DPAR(1) + A(4,4) = -ONE/DPAR(1) + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(4,1) = ONE/DPAR(1) + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,1) = ONE + C(2,3) = ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 2) THEN + NOTE = 'Arnold/Laub 1984' + IF (LSAME(DEF,'D')) DPAR(1) = 1D-6 + N = 4 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, DPAR(1), A, LDA) + A(1,1) = -DPAR(1) + A(2,1) = -ONE + A(1,2) = ONE + A(2,2) = -DPAR(1) + A(4,3) = -ONE + A(3,4) = ONE + CALL DLASET('A', N, M, ONE, ONE, B, LDB) + CALL DLASET('A', P, N, ONE, ONE, C, LDC) + D(1,1) = ZERO +C + ELSE IF (NR(2) .EQ. 3) THEN + NOTE = 'Vertical acceleration of a rigid guided missile' + IF (LSAME(DEF,'D')) IPAR(1) = 1 + IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 10)) INFO = -4 + N = 3 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(2,1) = ONE + A(3,3) = -.19D3 + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(3,1) = .19D3 + D(1,1) = ZERO + OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD01203.dat') + IF (STATUS .NE. 0) THEN + INFO = 1 + ELSE + DO 210 I = 1, IPAR(1) + READ (1, FMT = *, IOSTAT = STATUS) (A(1,J), J = 1, N) + IF (STATUS .NE. 0) INFO = 1 + READ (1, FMT = *, IOSTAT = STATUS) (A(2,J), J = 2, N) + IF (STATUS .NE. 0) INFO = 1 + READ (1, FMT = *, IOSTAT = STATUS) (C(1,J), J = 1, N) + IF (STATUS .NE. 0) INFO = 1 +210 CONTINUE + END IF + CLOSE(1) +C + ELSE IF (NR(2) .EQ. 4) THEN + NOTE = 'Senning 1980: hydraulic positioning system' + IF (LSAME(DEF,'D')) THEN + DPAR(1) = .14D5 + DPAR(2) = .1287D0 + DPAR(3) = .15D0 + DPAR(4) = .1D-1 + DPAR(5) = .2D-2 + DPAR(6) = .24D0 + DPAR(7) = .1075D2 + END IF + IF (((DPAR(1) .LE. .9D4) .OR. (DPAR(1) .GE. .16D5)) .OR. + 1 ((DPAR(2) .LE. .5D-1) .OR. (DPAR(2) .GE. .3D0)) .OR. + 2 ((DPAR(3) .LE. .5D-1) .OR. (DPAR(3) .GE. .5D1)) .OR. + 3 ((DPAR(4) .LE. ZERO) .OR. (DPAR(4) .GE. .5D-1)) .OR. + 4 ((DPAR(5) .LE. .103D-3) .OR. (DPAR(5) .GE. .35D-2)) .OR. + 5 ((DPAR(6) .LE. .1D-2) .OR. (DPAR(6) .GE. .15D2)) .OR. + 6 ((DPAR(7) .LE. .105D2) .OR. (DPAR(7) .GE. .111D2))) THEN + INFO = -3 + END IF + N = 3 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(1,2) = ONE + A(2,2) = -(DPAR(3) + FOUR*DPAR(4)/PI) / DPAR(2) + A(2,3) = DPAR(7) / DPAR(2) + A(3,2) = -FOUR * DPAR(7) * DPAR(1) / .874D3 + A(3,3) = -FOUR * DPAR(1) * (DPAR(6) + DPAR(5)) / .874D3 + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(3,1) = -FOUR * DPAR(1) / .874D3 + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + D(1,1) = 0 +C + ELSE IF (NR(2) .EQ. 5) THEN + NOTE = 'Kwakernaak/Westdyk 1985: cascade of inverted pendula' + IF (LSAME(DEF,'D')) IPAR(1) = 1 + IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 7)) INFO = -4 + IF (IPAR(1) .LE. 6) THEN + M = IPAR(1) + ELSE + M = 10 + END IF + N = 2 * M + P = M + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + WRITE (DATAF(1:12), '(A,I1,A)') 'BD01205', IPAR(1), '.dat' + OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = DATAF(1:12)) + IF (STATUS .NE. 0) THEN + INFO = 1 + ELSE + DO 220 I = 1, N + READ (1, FMT = *, IOSTAT = STATUS) (A(I,J), J = 1, N) + IF (STATUS .NE. 0) INFO = 1 +220 CONTINUE + DO 230 I = 1, N + READ (1, FMT = *, IOSTAT = STATUS) (B(I,J), J = 1, M) + IF (STATUS .NE. 0) INFO = 1 +230 CONTINUE + DO 240 I = 1, P + READ (1, FMT = *, IOSTAT = STATUS) (C(I,J), J = 1, N) + IF (STATUS .NE. 0) INFO = 1 +240 CONTINUE + END IF + CLOSE(1) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 6) THEN + NOTE = 'Kallstrom/Astrom 1981: regulation of a ship heading' + IF (LSAME(DEF,'D')) IPAR(1) = 1 + IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 5)) INFO = -4 + N = 3 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(3,2) = ONE + B(3,1) = ZERO + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,3) = ONE + D(1,1) = ZERO + OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD01206.dat') + IF (STATUS .NE. 0) THEN + INFO = 1 + ELSE + DO 250 I = 1, IPAR(1) + READ (1, FMT = *, IOSTAT = STATUS) (A(1,J), J = 1, 2) + IF (STATUS .NE. 0) INFO = 1 + READ (1, FMT = *, IOSTAT = STATUS) (A(2,J), J = 1, 2) + IF (STATUS .NE. 0) INFO = 1 + READ (1, FMT = *, IOSTAT = STATUS) (B(J,1), J = 1, 2) + IF (STATUS .NE. 0) INFO = 1 +250 CONTINUE + END IF + CLOSE(1) +C + ELSE IF (NR(2) .EQ. 7) THEN + NOTE = 'Ackermann 1989: track-guided bus' + IF (LSAME(DEF,'D')) THEN + DPAR(1) = .15D2 + DPAR(2) = .1D2 + END IF + IF ((DPAR(1) .LT. .995D1) .OR. (DPAR(1) .GT. .16D2)) INFO = -3 + IF ((DPAR(1) .LT. .1D1) .OR. (DPAR(1) .GT. .2D2)) INFO = -3 + N = 5 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(1,1) = -.668D3 / (DPAR(1)*DPAR(2)) + A(1,2) = -ONE + .1804D3 / (DPAR(1)*DPAR(2)**2) + A(2,1) = .1804D3 / (.1086D2*DPAR(1)) + A(2,2) = -.44175452D4 / (.1086D2*DPAR(1)*DPAR(2)) + A(1,5) = 198 / (DPAR(1)*DPAR(2)) + A(2,5) = .72666D3 / (.1086D2*DPAR(1)) + A(3,1) = DPAR(2) + A(3,4) = DPAR(2) + A(4,2) = ONE + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(5,1) = ONE + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,3) = ONE + C(1,4) = .612D1 + D(1,1) = 0 +C + ELSE + INFO = -2 + END IF +C + ELSE IF (NR(1) .EQ. 3) THEN + IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN + INFO = -1 + RETURN + END IF +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'Laub 1979, Ex.4: string of high speed vehicles' + IF (LSAME(DEF,'D')) IPAR(1) = 20 + IF (IPAR(1) .LT. 2) INFO = -4 + N = 2*IPAR(1) - 1 + M = IPAR(1) + P = IPAR(1) - 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + DO 310 I = 1, N + IF (MOD(I,2) .EQ. 1) THEN + A(I,I) = -ONE + B(I,(I+1)/2) = ONE + ELSE + A(I,I-1) = ONE + A(I,I+1) = -ONE + C(I/2,I) = ONE + END IF +310 CONTINUE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 2) THEN + NOTE = 'Hodel et al. 1996: heat flow in a thin rod' + IF (LSAME(DEF,'D')) IPAR(1) = 100 + IF (IPAR(1) .LT. 1) INFO = -4 + N = IPAR(1) + M = 1 + P = N + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + TEMP = DBLE(N + 1) + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, -TWO * TEMP, A, LDA) + A(1,1) = -TEMP + DO 320 I = 1, N - 1 + A(I,I+1) = TEMP + A(I+1,I) = TEMP +320 CONTINUE + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(N,1) = TEMP + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 3) THEN + NOTE = 'Laub 1979, Ex.6' + IF (LSAME(DEF,'D')) IPAR(1) = 21 + IF (IPAR(1) .LT. 1) INFO = -4 + N = IPAR(1) + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('A', N-1, N-1, ZERO, ONE, A(1,2), LDA) + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(N,1) = ONE + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,1) = ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 4) THEN + NOTE = 'Lang/Penzl 1994: rotating axle' + IF (LSAME(DEF,'D')) IPAR(1) = 211 + IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 211)) INFO = -4 + N = 2*IPAR(1) - 1 + M = IPAR(1) + P = IPAR(1) + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (LDWORK .LT. M*4) INFO = -21 + IF (INFO .NE. 0) RETURN +C + OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD01304.dat') + IF (STATUS .NE. 0) THEN + INFO = 1 + ELSE + DO 330 I = 1, M*4 + READ (1, FMT = *, IOSTAT = STATUS) DWORK(I) + IF (STATUS .NE. 0) INFO = 1 +330 CONTINUE + END IF + CLOSE(1) + IF (INFO .NE. 0) RETURN + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + E(1,1) = DWORK(1) + DO 340 I = 2, M + E(I,I-1) = DWORK((I-2) * 4 + 1) + E(I,I) = -DWORK((I-1) * 4 + 1) +340 CONTINUE + E(M,M) = -E(M,M) + DO 350 I = M-1, 1, -1 + DO 345 J = I, M + IF (I .EQ. 1) THEN + E(J,I) = E(J,I) - E(J,I+1) + ELSE + E(J,I) = E(J,I+1) - E(J,I) + END IF +345 CONTINUE +350 CONTINUE + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + DO 360 I = 2, M + A(I-1,I) = DWORK((I-2) * 4 + 3) + A(I,I) = -TWO * DWORK((I-2) * 4 + 3) - DWORK((I-1) * 4 + 2) + A(I,1) = DWORK((I-1) * 4 + 2) - DWORK((I-2) * 4 + 2) + A(I-1,M+I-1) = DWORK((I-1) * 4) + A(I,M+I-1) = -TWO * DWORK((I-1) * 4) + IF (I .LT. M) THEN + A(I+1,I) = DWORK((I-2) * 4 + 3) + DO 355 J = I+1, M + A(J,I) = A(J,I) + DWORK((J-2) * 4 + 2) + 1 - DWORK((J-1) * 4 + 2) +355 CONTINUE + A(I+1,M+I-1) = DWORK((I-1) * 4) + END IF +360 CONTINUE + A(1,1) = -DWORK(2) + A(1,2) = -DWORK(3) + A(1,M+1) = -A(1,M+1) + CALL DLASET('A', M-1, M-1, ZERO, ONE, A(M+1,2), LDA) + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + DO 370 I = 2, M + B(I,I) = -ONE + B(I,I-1) = ONE + C(I,I) = DWORK((I-2) * 4 + 3) + C(I,M+I-1) = DWORK((I-1) * 4) +370 CONTINUE + B(1,1) = ONE + C(1,1) = ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE + INFO = -2 + END IF +C + ELSE IF (NR(1) .EQ. 4) THEN + IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN + INFO = -1 + RETURN + END IF +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'Rosen/Wang 1995: control of 1-dim. heat flow' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 100 + DPAR(1) = .1D-1 + DPAR(2) = ONE + DPAR(3) = ONE + DPAR(4) = .2D0 + DPAR(5) = .3D0 + DPAR(6) = .2D0 + DPAR(7) = .3D0 + END IF + IF (IPAR(1) .LT. 2) INFO = -4 + N = IPAR(1) + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + VEC(4) = .TRUE. + APPIND = DBLE(N + 1) + TTEMP = -DPAR(1) * APPIND + TEMP = 1 / (.6D1 * APPIND) + CALL DLASET('A', N, N, ZERO, FOUR*TEMP, E, LDE) + CALL DLASET('A', N, N, ZERO, TWO*TTEMP, A, LDA) + DO 410 I = 1, N - 1 + A(I+1,I) = -TTEMP + A(I,I+1) = -TTEMP + E(I+1,I) = TEMP + E(I,I+1) = TEMP +410 CONTINUE + DO 420 I = 1, N + B1 = MAX(DBLE(I-1)/APPIND, DPAR(4)) + B2 = MIN(DBLE(I+1)/APPIND, DPAR(5)) + C1 = MAX(DBLE(I-1)/APPIND, DPAR(6)) + C2 = MIN(DBLE(I+1)/APPIND, DPAR(7)) + IF (B1 .GE. B2) THEN + B(I,1) = ZERO + ELSE + B(I,1) = B2 - B1 + TEMP = MIN(B2, DBLE(I)/APPIND) + IF (B1 .LT. TEMP) THEN + B(I,1) = B(I,1) + APPIND*(TEMP**2 - B1**2)/TWO + B(I,1) = B(I,1) + DBLE(I)*(B1 - TEMP) + END IF + TEMP = MAX(B1, DBLE(I)/APPIND) + IF (TEMP .LT. B2) THEN + B(I,1) = B(I,1) - APPIND*(B2**2 - TEMP**2)/TWO + B(I,1) = B(I,1) - DBLE(I)*(TEMP - B2) + END IF + END IF + IF (C1 .GE. C2) THEN + C(1,I) = ZERO + ELSE + C(1,I) = C2 - C1 + TEMP = MIN(C2, DBLE(I)/APPIND) + IF (C1 .LT. TEMP) THEN + C(1,I) = C(1,I) + APPIND*(TEMP**2 - C1**2)/TWO + C(1,I) = C(1,I) + DBLE(I)*(C1 - TEMP) + END IF + TEMP = MAX(C1, DBLE(I)/APPIND) + IF (TEMP .LT. C2) THEN + C(1,I) = C(1,I) - APPIND*(C2**2 - TEMP**2)/TWO + C(1,I) = C(1,I) - DBLE(I)*(TEMP - C2) + END IF + END IF +420 CONTINUE + CALL DSCAL(N, DPAR(2), B(1,1), 1) + CALL DSCAL(N, DPAR(3), C(1,1), LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 2) THEN + NOTE = 'Hench et al. 1995: coupled springs, dashpots, masses' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 30 + DPAR(1) = FOUR + DPAR(2) = FOUR + DPAR(3) = ONE + END IF + IF (IPAR(1) .LT. 2) INFO = -4 + L = IPAR(1) + N = 2*L + M = 2 + P = 2*L + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + VEC(4) = .TRUE. + CALL DLASET('A', N, N, ZERO, DPAR(1), E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + TEMP = -TWO * DPAR(3) + DO 430 I = 1, L + E(I,I) = ONE + A(I,I+L) = ONE + A(I+L,I+L) = -DPAR(2) + IF (I .LT. L) THEN + A(I+L,I+1) = DPAR(3) + A(I+L+1,I) = DPAR(3) + IF (I .GT. 1) THEN + A(I+L,I) = TEMP + END IF + END IF + 430 CONTINUE + A(L+1,1) = -DPAR(3) + A(N,L) = -DPAR(3) + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(L+1,1) = ONE + B(N,2) = -ONE + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE + INFO = -2 + END IF + ELSE + INFO = -2 + END IF +C + RETURN +C *** Last Line of BD01AD *** + END diff --git a/mex/sources/libslicot/BD02AD.f b/mex/sources/libslicot/BD02AD.f new file mode 100644 index 000000000..ebe6f4a70 --- /dev/null +++ b/mex/sources/libslicot/BD02AD.f @@ -0,0 +1,601 @@ + SUBROUTINE BD02AD( DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A, + 1 LDA, B, LDB, C, LDC, D, LDD, NOTE, DWORK, + 2 LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate benchmark examples for time-invariant, +C discrete-time dynamical systems +C +C E x_k+1 = A x_k + B u_k +C +C y_k = C x_k + D u_k +C +C E, A are real N-by-N matrices, B is N-by-M, C is P-by-N, and +C D is P-by-M. In many examples, E is the identity matrix and D is +C the zero matrix. +C +C This routine is an implementation of the benchmark library +C DTDSX (Version 1.0) described in [1]. +C +C ARGUMENTS +C +C Mode Parameters +C +C DEF CHARACTER*1 +C Specifies the kind of values used as parameters when +C generating parameter-dependent and scalable examples +C (i.e., examples with NR(1) = 2, 3, or 4): +C = 'D': Default values defined in [1] are used; +C = 'N': Values set in DPAR and IPAR are used. +C This parameter is not referenced if NR(1) = 1. +C Note that the scaling parameter of examples with +C NR(1) = 3 or 4 is considered as a regular parameter in +C this context. +C +C Input/Output Parameters +C +C NR (input) INTEGER array, dimension (2) +C Specifies the index of the desired example according +C to [1]. +C NR(1) defines the group: +C 1 : parameter-free problems of fixed size +C 2 : parameter-dependent problems of fixed size +C 3 : parameter-free problems of scalable size +C 4 : parameter-dependent problems of scalable size +C NR(2) defines the number of the benchmark example +C within a certain group according to [1]. +C +C DPAR (input/output) DOUBLE PRECISION array, dimension (7) +C On entry, if DEF = 'N' and the desired example depends on +C real parameters, then the array DPAR must contain the +C values for these parameters. +C For an explanation of the parameters see [1]. +C For Example 2.1, DPAR(1), ..., DPAR(3) define the +C parameters 'tau', 'delta', 'K', respectively. +C On exit, if DEF = 'D' and the desired example depends on +C real parameters, then the array DPAR is overwritten by the +C default values given in [1]. +C +C IPAR (input/output) INTEGER array, dimension (1) +C On entry, if DEF = 'N' and the desired example depends on +C integer parameters, then the array IPAR must contain the +C values for these parameters. +C For an explanation of the parameters see [1]. +C For Example 3.1, IPAR(1) defines the parameter 'n'. +C On exit, if DEF = 'D' and the desired example depends on +C integer parameters, then the array IPAR is overwritten by +C the default values given in [1]. +C +C VEC (output) LOGICAL array, dimension (8) +C Flag vector which displays the availabilty of the output +C data: +C VEC(1), ..., VEC(3) refer to N, M, and P, respectively, +C and are always .TRUE.. +C VEC(4) is .TRUE. iff E is NOT the identity matrix. +C VEC(5), ..., VEC(7) refer to A, B, and C, respectively, +C and are always .TRUE.. +C VEC(8) is .TRUE. iff D is NOT the zero matrix. +C +C N (output) INTEGER +C The actual state dimension, i.e., the order of the +C matrices E and A. +C +C M (output) INTEGER +C The number of columns in the matrices B and D. +C +C P (output) INTEGER +C The number of rows in the matrices C and D. +C +C E (output) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N part of this array contains the +C matrix E. +C NOTE that this array is overwritten (by the identity +C matrix), if VEC(4) = .FALSE.. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= N. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the +C matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array contains the +C matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= N. +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array contains the +C matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= P. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array contains the +C matrix D. +C NOTE that this array is overwritten (by the zero +C matrix), if VEC(8) = .FALSE.. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= P. +C +C NOTE (output) CHARACTER*70 +C String containing short information about the chosen +C example. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C NOTE that DWORK is not used in the current version +C of BD02AD. +C +C LDWORK INTEGER +C LDWORK >= 1. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; in particular, INFO = -3 or -4 indicates +C that at least one of the parameters in DPAR or +C IPAR, respectively, has an illegal value; +C = 1: data file can not be opened or has wrong format. +C +C REFERENCES +C +C [1] Kressner, D., Mehrmann, V. and Penzl, T. +C DTDSX - a Collection of Benchmark Examples for State-Space +C Realizations of Discrete-Time Dynamical Systems. +C SLICOT Working Note 1998-10. 1998. +C +C NUMERICAL ASPECTS +C +C None +C +C CONTRIBUTOR +C +C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) +C +C For questions concerning the collection or for the submission of +C test examples, please contact Volker Mehrmann +C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). +C +C REVISIONS +C +C June 1999, V. Sima. +C +C KEYWORDS +C +C discrete-time dynamical systems +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, PI + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + 1 THREE = 3.0D0, FOUR = 4.0D0, + 2 PI = .3141592653589793D1 ) +C .. Scalar Arguments .. + CHARACTER DEF + CHARACTER*70 NOTE + INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, M, N, P +C .. Array Arguments .. + LOGICAL VEC(8) + INTEGER IPAR(*), NR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DPAR(*), + 1 DWORK(*), E(LDE,*) +C .. Local Scalars .. + CHARACTER*12 DATAF + INTEGER I, J, STATUS + DOUBLE PRECISION TEMP +C .. Local Arrays .. + LOGICAL VECDEF(8) +C .. External Functions .. +C . LAPACK . + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. +C . LAPACK . + EXTERNAL DLASET +C .. Data Statements .. +C . default values for availabities . + DATA VECDEF /.TRUE., .TRUE., .TRUE., .FALSE., + 1 .TRUE., .TRUE., .TRUE., .FALSE./ +C +C .. Executable Statements .. +C + INFO = 0 + DO 10 I = 1, 8 + VEC(I) = VECDEF(I) +10 CONTINUE +C + IF (NR(1) .EQ. 1) THEN +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'Laub 1979, Ex. 2: uncontrollable-unobservable data' + N = 2 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + A(1,1) = FOUR + A(2,1) = -.45D1 + A(1,2) = THREE + A(2,2) = -.35D1 + CALL DLASET('A', N, M, -ONE, ONE, B, LDB) + C(1,1) = 3.0D0 + C(1,2) = 2.0D0 + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 2) THEN + NOTE = 'Laub 1979, Ex. 3' + N = 2 + M = 2 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(1,1) = .9512D0 + A(2,2) = .9048D0 + B(1,1) = .4877D1 + B(1,2) = .4877D1 + B(2,1) = -.11895D1 + B(2,2) = .3569D1 + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 3) THEN + NOTE = 'Van Dooren 1981, Ex. II' + N = 2 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + A(1,1) = TWO + A(2,1) = ONE + A(1,2) = -ONE + A(2,2) = ZERO + CALL DLASET('A', N, M, ZERO, ONE, B, LDB) + CALL DLASET('A', P, N, ONE, ZERO, C, LDC) + D(1,1) = ZERO +C + ELSE IF (NR(2) .EQ. 4) THEN + NOTE = 'Ionescu/Weiss 1992' + N = 2 + M = 2 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(1,2) = ONE + A(2,2) = -ONE + CALL DLASET('A', N, M, ZERO, ONE, B, LDB) + B(2,1) = TWO + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 5) THEN + NOTE = 'Jonckheere 1981' + N = 2 + M = 1 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(1,2) = ONE + CALL DLASET('A', N, M, ONE, ZERO, B, LDB) + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 6) THEN + NOTE = 'Ackerson/Fu 1970: satellite control problem' + N = 4 + M = 2 + P = 4 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 7) THEN + NOTE = 'Litkouhi 1983: system with slow and fast modes' + N = 4 + M = 2 + P = 4 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 8) THEN + NOTE = 'Lu/Lin 1993, Ex. 4.3' + N = 4 + M = 4 + P = 4 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('U', P, N, ONE, ONE, C, LDC) + C(1,3) = TWO + C(1,4) = FOUR + C(2,4) = TWO + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 9) THEN + NOTE = 'Gajic/Shen 1993, Section 2.7.4: chemical plant' + N = 5 + M = 2 + P = 5 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 10) THEN + NOTE = 'Davison/Wang 1974' + N = 6 + M = 2 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN + VEC(8) = .TRUE. +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(1,2) = ONE + A(2,3) = ONE + A(4,5) = ONE + A(5,6) = ONE + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(3,1) = ONE + B(6,2) = ONE + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,1) = ONE + C(1,2) = ONE + C(2,4) = ONE + C(2,5) = -ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) + D(1,1) = ONE + D(2,1) = ONE +C + ELSE IF (NR(2) .EQ. 11) THEN + NOTE = 'Patnaik et al. 1980: tubular ammonia reactor' + N = 9 + M = 3 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,1) = ONE + C(2,5) = ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 12) THEN + NOTE = 'Smith 1969: two-stand cold rolling mill' + N = 10 + M = 3 + P = 5 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN + VEC(8) = .TRUE. +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('A', N, N, ZERO, ONE, A(2,1), LDA) + A(1,10) = .112D0 + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(1,1) = .276D1 + B(1,2) = -.135D1 + B(1,3) = -.46D0 + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,1) = ONE + C(2,10) = .894D0 + C(3,10) = -.1693D2 + C(4,10) = .7D-1 + C(5,10) = .398D0 + OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD02112.dat') + IF (STATUS .NE. 0) THEN + INFO = 1 + ELSE + DO 110 I = 1, P + READ (1, FMT = *, IOSTAT = STATUS) (D(I,J), J = 1, M) + IF (STATUS .NE. 0) INFO = 1 +110 CONTINUE + END IF + CLOSE(1) +C + ELSE + INFO = -2 + END IF +C + IF (((NR(2) .GE. 6) .AND. (NR(2) .LE. 9)) .OR. + 1 (NR(2) .EQ. 11)) THEN +C .. loading data files + WRITE (DATAF(1:11), '(A,I2.2,A)') 'BD021', NR(2), '.dat' + OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = DATAF(1:11)) + IF (STATUS .NE. 0) THEN + INFO = 1 + ELSE + DO 120 I = 1, N + READ (1, FMT = *, IOSTAT = STATUS) (A(I,J), J = 1, N) + IF (STATUS .NE. 0) INFO = 1 +120 CONTINUE + DO 130 I = 1, N + READ (1, FMT = *, IOSTAT = STATUS) (B(I,J), J = 1, M) + IF (STATUS .NE. 0) INFO = 1 +130 CONTINUE + END IF + CLOSE(1) + END IF +C + ELSE IF (NR(1) .EQ. 2) THEN + IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN + INFO = -1 + RETURN + END IF +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'Pappas et al. 1980: process control of paper machine' + IF (LSAME(DEF,'D')) THEN + DPAR(1) = .1D9 + DPAR(2) = ONE + DPAR(3) = ONE + END IF + IF (DPAR(1) .EQ. ZERO) INFO = -3 + N = 4 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + TEMP = DPAR(2) / DPAR(1) + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('A', N-1, N-1, ZERO, ONE, A(2,1), LDA) + A(1,1) = ONE - TEMP + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(1,1) = DPAR(3) * TEMP + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,4) = ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE + INFO = -2 + END IF +C + ELSE IF (NR(1) .EQ. 3) THEN + IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN + INFO = -1 + RETURN + END IF +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'Pappas et al. 1980, Ex. 3' + IF (LSAME(DEF,'D')) IPAR(1) = 100 + IF (IPAR(1) .LT. 2) INFO = -4 + N = IPAR(1) + M = 1 + P = N + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('A', N-1, N-1, ZERO, ONE, A(1,2), LDA) + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(N,1) = ONE + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE + INFO = -2 + END IF +C + ELSE + INFO = -2 + END IF +C + RETURN +C *** Last Line of BD02AD *** + END diff --git a/mex/sources/libslicot/DE01OD.f b/mex/sources/libslicot/DE01OD.f new file mode 100644 index 000000000..b2b0a608a --- /dev/null +++ b/mex/sources/libslicot/DE01OD.f @@ -0,0 +1,203 @@ + SUBROUTINE DE01OD( CONV, N, A, B, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the convolution or deconvolution of two real signals +C A and B. +C +C ARGUMENTS +C +C Mode Parameters +C +C CONV CHARACTER*1 +C Indicates whether convolution or deconvolution is to be +C performed as follows: +C = 'C': Convolution; +C = 'D': Deconvolution. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of samples. N must be a power of 2. N >= 2. +C +C A (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the first signal. +C On exit, this array contains the convolution (if +C CONV = 'C') or deconvolution (if CONV = 'D') of the two +C signals. +C +C B (input) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the second signal. +C NOTE that this array is overwritten. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C This routine computes the convolution or deconvolution of two real +C signals A and B using an FFT algorithm (SLICOT Library routine +C DG01MD). +C +C REFERENCES +C +C [1] Rabiner, L.R. and Rader, C.M. +C Digital Signal Processing. +C IEEE Press, 1972. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0( N*log(N) ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine DE01CD by R. Dekeyser, State +C University of Gent, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Convolution, deconvolution, digital signal processing, fast +C Fourier transform, real signals. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF=0.5D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER CONV + INTEGER INFO, N +C .. Array Arguments .. + DOUBLE PRECISION A(*), B(*) +C .. Local Scalars .. + LOGICAL LCONV + INTEGER J, KJ, ND2P1 + DOUBLE PRECISION AC, AS, AST, BC, BS, CI, CR +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DG01MD, DLADIV, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MOD +C .. Executable Statements .. +C + INFO = 0 + LCONV = LSAME( CONV, 'C' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LCONV .AND. .NOT.LSAME( CONV, 'D' ) ) THEN + INFO = -1 + ELSE + J = 0 + IF( N.GE.2 ) THEN + J = N +C WHILE ( MOD( J, 2 ).EQ.0 ) DO + 10 CONTINUE + IF ( MOD( J, 2 ).EQ.0 ) THEN + J = J/2 + GO TO 10 + END IF +C END WHILE 10 + END IF + IF ( J.NE.1 ) INFO = -2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'DE01OD', -INFO ) + RETURN + END IF +C +C Fourier transform. +C + CALL DG01MD( 'Direct', N, A, B, INFO ) +C + IF ( LCONV ) THEN + AST = A(1)*B(1) + ELSE + IF ( B(1).EQ.ZERO ) THEN + AST = ZERO + ELSE + AST = A(1)/B(1) + END IF + END IF +C + ND2P1 = N/2 + 1 + J = ND2P1 +C + DO 20 KJ = ND2P1, N +C +C Components of the transform of function A. +C + AC = HALF*( A(J) + A(KJ) ) + AS = HALF*( B(J) - B(KJ) ) +C +C Components of the transform of function B. +C + BC = HALF*( B(KJ) + B(J) ) + BS = HALF*( A(KJ) - A(J) ) +C +C Deconvolution by complex division if CONV = 'D'; +C Convolution by complex multiplication if CONV = 'C'. +C + IF ( LCONV ) THEN + CR = AC*BC - AS*BS + CI = AS*BC + AC*BS + ELSE + IF ( MAX( ABS( BC ), ABS( BS ) ).EQ.ZERO ) THEN + CR = ZERO + CI = ZERO + ELSE + CALL DLADIV( AC, AS, BC, BS, CR, CI ) + END IF + END IF +C + A(J) = CR + B(J) = CI + A(KJ) = CR + B(KJ) = -CI + J = J - 1 + 20 CONTINUE + A(1) = AST + B(1) = ZERO +C +C Inverse Fourier transform. +C + CALL DG01MD( 'Inverse', N, A, B, INFO ) +C + CALL DSCAL( N, ONE/DBLE( N ), A, 1 ) +C + RETURN +C *** Last line of DE01OD *** + END diff --git a/mex/sources/libslicot/DE01PD.f b/mex/sources/libslicot/DE01PD.f new file mode 100644 index 000000000..0358e8036 --- /dev/null +++ b/mex/sources/libslicot/DE01PD.f @@ -0,0 +1,236 @@ + SUBROUTINE DE01PD( CONV, WGHT, N, A, B, W, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the convolution or deconvolution of two real signals +C A and B using the Hartley transform. +C +C ARGUMENTS +C +C Mode Parameters +C +C CONV CHARACTER*1 +C Indicates whether convolution or deconvolution is to be +C performed as follows: +C = 'C': Convolution; +C = 'D': Deconvolution. +C +C WGHT CHARACTER*1 +C Indicates whether the precomputed weights are available +C or not, as follows: +C = 'A': available; +C = 'N': not available. +C Note that if N > 1 and WGHT = 'N' on entry, then WGHT is +C set to 'A' on exit. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of samples. N must be a power of 2. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the first signal. +C On exit, this array contains the convolution (if +C CONV = 'C') or deconvolution (if CONV = 'D') of the two +C signals. +C +C B (input) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the second signal. +C NOTE that this array is overwritten. +C +C W (input/output) DOUBLE PRECISION array, +C dimension (N - LOG2(N)) +C On entry with WGHT = 'A', this array must contain the long +C weight vector computed by a previous call of this routine +C or of the SLICOT Library routine DG01OD.f, with the same +C value of N. If WGHT = 'N', the contents of this array on +C entry is ignored. +C On exit, this array contains the long weight vector. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C This routine computes the convolution or deconvolution of two +C real signals A and B using three scrambled Hartley transforms +C (SLICOT Library routine DG01OD). +C +C REFERENCES +C +C [1] Van Loan, Charles. +C Computational frameworks for the fast Fourier transform. +C SIAM, 1992. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O(N log(N)) floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, April 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C +C KEYWORDS +C +C Convolution, deconvolution, digital signal processing, +C fast Hartley transform, real signals. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION HALF, ONE, TWO + PARAMETER ( HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + CHARACTER CONV, WGHT + INTEGER INFO, N +C .. Array Arguments .. + DOUBLE PRECISION A(*), B(*), W(*) +C .. Local Scalars .. + LOGICAL LCONV, LWGHT + INTEGER J, L, LEN, M, P1, R1 + DOUBLE PRECISION T1, T2, T3 +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DG01OD, DLADIV, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MOD +C .. Executable Statements .. +C + INFO = 0 + LCONV = LSAME( CONV, 'C' ) + LWGHT = LSAME( WGHT, 'A' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LCONV .AND. .NOT.LSAME( CONV, 'D' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LWGHT .AND. .NOT.LSAME( WGHT, 'N' ) ) THEN + INFO = -2 + ELSE + M = 0 + J = 0 + IF( N.GE.1 ) THEN + J = N +C WHILE ( MOD( J, 2 ).EQ.0 ) DO + 10 CONTINUE + IF ( MOD( J, 2 ).EQ.0 ) THEN + J = J/2 + M = M + 1 + GO TO 10 + END IF +C END WHILE 10 + IF ( J.NE.1 ) INFO = -3 + ELSE IF ( N.LT.0 ) THEN + INFO = -3 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'DE01PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.LE.0 ) THEN + RETURN + ELSE IF ( N.EQ.1 ) THEN + IF ( LCONV ) THEN + A(1) = A(1)*B(1) + ELSE + A(1) = A(1)/B(1) + END IF + RETURN + END IF +C +C Scrambled Hartley transforms of A and B. +C + CALL DG01OD( 'OutputScrambled', WGHT, N, A, W, INFO ) + CALL DG01OD( 'OutputScrambled', WGHT, N, B, W, INFO ) +C +C Something similar to a Hadamard product/quotient. +C + LEN = 1 + IF( LCONV ) THEN + A(1) = TWO*A(1)*B(1) + A(2) = TWO*A(2)*B(2) +C + DO 30 L = 1, M - 1 + LEN = 2*LEN + R1 = 2*LEN +C + DO 20 P1 = LEN + 1, LEN + LEN/2 + T1 = B(P1) + B(R1) + T2 = B(P1) - B(R1) + T3 = T2*A(P1) + A(P1) = T1*A(P1) + T2*A(R1) + A(R1) = T1*A(R1) - T3 + R1 = R1 - 1 + 20 CONTINUE +C + 30 CONTINUE +C + ELSE +C + A(1) = HALF*A(1)/B(1) + A(2) = HALF*A(2)/B(2) +C + DO 50 L = 1, M - 1 + LEN = 2*LEN + R1 = 2*LEN +C + DO 40 P1 = LEN + 1, LEN + LEN/2 + CALL DLADIV( A(P1), A(R1), B(P1)+B(R1), B(R1)-B(P1), T1, + $ T2 ) + A(P1) = T1 + A(R1) = T2 + R1 = R1 - 1 + 40 CONTINUE +C + 50 CONTINUE +C + END IF +C +C Transposed Hartley transform of A. +C + CALL DG01OD( 'InputScrambled', WGHT, N, A, W, INFO ) + IF ( LCONV ) THEN + CALL DSCAL( N, HALF/DBLE( N ), A, 1 ) + ELSE + CALL DSCAL( N, TWO/DBLE( N ), A, 1 ) + END IF +C + RETURN +C *** Last line of DE01PD *** + END diff --git a/mex/sources/libslicot/DF01MD.f b/mex/sources/libslicot/DF01MD.f new file mode 100644 index 000000000..1dafa4b97 --- /dev/null +++ b/mex/sources/libslicot/DF01MD.f @@ -0,0 +1,299 @@ + SUBROUTINE DF01MD( SICO, N, DT, A, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the sine transform or cosine transform of a real +C signal. +C +C ARGUMENTS +C +C Mode Parameters +C +C SICO CHARACTER*1 +C Indicates whether the sine transform or cosine transform +C is to be computed as follows: +C = 'S': The sine transform is computed; +C = 'C': The cosine transform is computed. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of samples. N must be a power of 2 plus 1. +C N >= 5. +C +C DT (input) DOUBLE PRECISION +C The sampling time of the signal. +C +C A (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the signal to be +C processed. +C On exit, this array contains either the sine transform, if +C SICO = 'S', or the cosine transform, if SICO = 'C', of the +C given signal. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N+1) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Let A(1), A(2),..., A(N) be a real signal of N samples. +C +C If SICO = 'S', the routine computes the sine transform of A as +C follows. First, transform A(i), i = 1,2,...,N, into the complex +C signal B(i), i = 1,2,...,(N+1)/2, where +C +C B(1) = -2*A(2), +C B(i) = {A(2i-2) - A(2i)} - j*A(2i-1) for i = 2,3,...,(N-1)/2, +C B((N+1)/2) = 2*A(N-1) and j**2 = -1. +C +C Next, perform a discrete inverse Fourier transform on B(i) by +C calling SLICOT Library Routine DG01ND, to give the complex signal +C Z(i), i = 1,2,...,(N-1)/2, from which the real signal C(i) may be +C obtained as follows: +C +C C(2i-1) = Re(Z(i)), C(2i) = Im(Z(i)) for i = 1,2,...,(N-1)/2. +C +C Finally, compute the sine transform coefficients S ,S ,...,S +C 1 2 N +C given by +C +C S = 0, +C 1 +C { [C(k) + C(N+1-k)] } +C S = DT*{[C(k) - C(N+1-k)] - -----------------------}, +C k { [2*sin(pi*(k-1)/(N-1))]} +C +C for k = 2,3,...,N-1, and +C +C S = 0. +C N +C +C If SICO = 'C', the routine computes the cosine transform of A as +C follows. First, transform A(i), i = 1,2,...,N, into the complex +C signal B(i), i = 1,2,...,(N+1)/2, where +C +C B(1) = 2*A(1), +C B(i) = 2*A(2i-1) + 2*j*{[A(2i-2) - A(2i)]} +C for i = 2,3,...,(N-1)/2 and B((N+1)/2) = 2*A(N). +C +C Next, perform a discrete inverse Fourier transform on B(i) by +C calling SLICOT Library Routine DG01ND, to give the complex signal +C Z(i), i = 1,2,...,(N-1)/2, from which the real signal D(i) may be +C obtained as follows: +C +C D(2i-1) = Re(Z(i)), D(2i) = Im(Z(i)) for i = 1,2,...,(N-1)/2. +C +C Finally, compute the cosine transform coefficients S ,S ,...,S +C 1 2 N +C given by +C +C S = 2*DT*[D(1) + A0], +C 1 +C { [D(k) - D(N+1-k)] } +C S = DT*{[D(k) + D(N+1-k)] - -----------------------}, +C k { [2*sin(pi*(k-1)/(N-1))]} +C +C +C for k = 2,3,...,N-1, and +C +C S = 2*DT*[D(1) - A0], +C N +C (N-1)/2 +C where A0 = 2*SUM A(2i). +C i=1 +C +C REFERENCES +C +C [1] Rabiner, L.R. and Rader, C.M. +C Digital Signal Processing. +C IEEE Press, 1972. +C +C [2] Oppenheim, A.V. and Schafer, R.W. +C Discrete-Time Signal Processing. +C Prentice-Hall Signal Processing Series, 1989. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0( N*log(N) ) operations. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine DF01AD by F. Dumortier, and +C R.M.C. Dekeyser, State University of Gent, Belgium. +C +C REVISIONS +C +C V. Sima, Jan. 2003. +C +C KEYWORDS +C +C Digital signal processing, fast Fourier transform, complex +C signals. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, FOUR + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ FOUR = 4.0D0 ) +C .. Scalar Arguments .. + CHARACTER SICO + INTEGER INFO, N + DOUBLE PRECISION DT +C .. Array Arguments .. + DOUBLE PRECISION A(*), DWORK(*) +C .. Local Scalars .. + LOGICAL LSICO, LSIG + INTEGER I, I2, IND1, IND2, M, MD2 + DOUBLE PRECISION A0, PIBYM, W1, W2, W3 +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DG01ND, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ATAN, DBLE, MOD, SIN +C .. Executable Statements .. +C + INFO = 0 + LSICO = LSAME( SICO, 'S' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LSICO .AND. .NOT.LSAME( SICO, 'C' ) ) THEN + INFO = -1 + ELSE + M = 0 + IF( N.GT.4 ) THEN + M = N - 1 +C WHILE ( MOD( M, 2 ).EQ.0 ) DO + 10 CONTINUE + IF ( MOD( M, 2 ).EQ.0 ) THEN + M = M/2 + GO TO 10 + END IF +C END WHILE 10 + END IF + IF ( M.NE.1 ) INFO = -2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'DF01MD', -INFO ) + RETURN + END IF +C +C Initialisation. +C + M = N - 1 + MD2 = ( N + 1 )/2 + PIBYM = FOUR*ATAN( ONE )/DBLE( M ) + I2 = 1 + DWORK(MD2+1) = ZERO + DWORK(2*MD2) = ZERO +C + IF ( LSICO ) THEN +C +C Sine transform. +C + LSIG = .TRUE. + DWORK(1) = -TWO*A(2) + DWORK(MD2) = TWO*A(M) +C + DO 20 I = 4, M, 2 + I2 = I2 + 1 + DWORK(I2) = A(I-2) - A(I) + DWORK(MD2+I2) = -A(I-1) + 20 CONTINUE +C + ELSE +C +C Cosine transform. +C + LSIG = .FALSE. + DWORK(1) = TWO*A(1) + DWORK(MD2) = TWO*A(N) + A0 = A(2) +C + DO 30 I = 4, M, 2 + I2 = I2 + 1 + DWORK(I2) = TWO*A(I-1) + DWORK(MD2+I2) = TWO*( A(I-2) - A(I) ) + A0 = A0 + A(I) + 30 CONTINUE +C + A0 = TWO*A0 + END IF +C +C Inverse Fourier transform. +C + CALL DG01ND( 'Inverse', MD2-1, DWORK(1), DWORK(MD2+1), INFO ) +C +C Sine or cosine coefficients. +C + IF ( LSICO ) THEN + A(1) = ZERO + A(N) = ZERO + ELSE + A(1) = TWO*DT*( DWORK(1) + A0 ) + A(N) = TWO*DT*( DWORK(1) - A0 ) + END IF +C + IND1 = MD2 + 1 + IND2 = N +C + DO 40 I = 1, M - 1, 2 + W1 = DWORK(IND1) + W2 = DWORK(IND2) + IF ( LSIG ) W2 = -W2 + W3 = TWO*SIN( PIBYM*DBLE( I ) ) + A(I+1) = DT*( W1 + W2 - ( W1 - W2 )/W3 ) + IND1 = IND1 + 1 + IND2 = IND2 - 1 + 40 CONTINUE +C + IND1 = 2 + IND2 = MD2 - 1 +C + DO 50 I = 2, M - 2, 2 + W1 = DWORK(IND1) + W2 = DWORK(IND2) + IF ( LSIG ) W2 = -W2 + W3 = TWO*SIN( PIBYM*DBLE( I ) ) + A(I+1) = DT*( W1 + W2 - ( W1 - W2 )/W3 ) + IND1 = IND1 + 1 + IND2 = IND2 - 1 + 50 CONTINUE +C + RETURN +C *** Last line of DF01MD *** + END diff --git a/mex/sources/libslicot/DG01MD.f b/mex/sources/libslicot/DG01MD.f new file mode 100644 index 000000000..ac91ab314 --- /dev/null +++ b/mex/sources/libslicot/DG01MD.f @@ -0,0 +1,235 @@ + SUBROUTINE DG01MD( INDI, N, XR, XI, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the discrete Fourier transform, or inverse transform, +C of a complex signal. +C +C ARGUMENTS +C +C Mode Parameters +C +C INDI CHARACTER*1 +C Indicates whether a Fourier transform or inverse Fourier +C transform is to be performed as follows: +C = 'D': (Direct) Fourier transform; +C = 'I': Inverse Fourier transform. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of complex samples. N must be a power of 2. +C N >= 2. +C +C XR (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the real part of either +C the complex signal z if INDI = 'D', or f(z) if INDI = 'I'. +C On exit, this array contains either the real part of the +C computed Fourier transform f(z) if INDI = 'D', or the +C inverse Fourier transform z of f(z) if INDI = 'I'. +C +C XI (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the imaginary part of +C either z if INDI = 'D', or f(z) if INDI = 'I'. +C On exit, this array contains either the imaginary part of +C f(z) if INDI = 'D', or z if INDI = 'I'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C If INDI = 'D', then the routine performs a discrete Fourier +C transform on the complex signal Z(i), i = 1,2,...,N. If the result +C is denoted by FZ(k), k = 1,2,...,N, then the relationship between +C Z and FZ is given by the formula: +C +C N ((k-1)*(i-1)) +C FZ(k) = SUM ( Z(i) * V ), +C i=1 +C 2 +C where V = exp( -2*pi*j/N ) and j = -1. +C +C If INDI = 'I', then the routine performs an inverse discrete +C Fourier transform on the complex signal FZ(k), k = 1,2,...,N. If +C the result is denoted by Z(i), i = 1,2,...,N, then the +C relationship between Z and FZ is given by the formula: +C +C N ((k-1)*(i-1)) +C Z(i) = SUM ( FZ(k) * W ), +C k=1 +C +C where W = exp( 2*pi*j/N ). +C +C Note that a discrete Fourier transform, followed by an inverse +C discrete Fourier transform, will result in a signal which is a +C factor N larger than the original input signal. +C +C REFERENCES +C +C [1] Rabiner, L.R. and Rader, C.M. +C Digital Signal Processing. +C IEEE Press, 1972. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0( N*log(N) ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine DG01AD by R. Dekeyser, State +C University of Gent, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Complex signals, digital signal processing, fast Fourier +C transform. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, TWO, EIGHT + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, + $ TWO = 2.0D0, EIGHT = 8.0D0 ) +C .. Scalar Arguments .. + CHARACTER INDI + INTEGER INFO, N +C .. Array Arguments .. + DOUBLE PRECISION XI(*), XR(*) +C .. Local Scalars .. + LOGICAL LINDI + INTEGER I, J, K, L, M + DOUBLE PRECISION PI2, TI, TR, WHELP, WI, WR, WSTPI, WSTPR +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC ATAN, DBLE, MOD, SIN +C .. Executable Statements .. +C + INFO = 0 + LINDI = LSAME( INDI, 'D' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LINDI .AND. .NOT.LSAME( INDI, 'I' ) ) THEN + INFO = -1 + ELSE + J = 0 + IF( N.GE.2 ) THEN + J = N +C WHILE ( MOD( J, 2 ).EQ.0 ) DO + 10 CONTINUE + IF ( MOD( J, 2 ).EQ.0 ) THEN + J = J/2 + GO TO 10 + END IF +C END WHILE 10 + END IF + IF ( J.NE.1 ) INFO = -2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'DG01MD', -INFO ) + RETURN + END IF +C +C Inplace shuffling of data. +C + J = 1 +C + DO 30 I = 1, N + IF ( J.GT.I ) THEN + TR = XR(I) + TI = XI(I) + XR(I) = XR(J) + XI(I) = XI(J) + XR(J) = TR + XI(J) = TI + END IF + K = N/2 +C REPEAT + 20 IF ( J.GT.K ) THEN + J = J - K + K = K/2 + IF ( K.GE.2 ) GO TO 20 + END IF +C UNTIL ( K.LT.2 ) + J = J + K + 30 CONTINUE +C +C Transform by decimation in time. +C + PI2 = EIGHT*ATAN( ONE ) + IF ( LINDI ) PI2 = -PI2 +C + I = 1 +C +C WHILE ( I.LT.N ) DO +C + 40 IF ( I.LT.N ) THEN + L = 2*I + WHELP = PI2/DBLE( L ) + WSTPI = SIN( WHELP ) + WHELP = SIN( HALF*WHELP ) + WSTPR = -TWO*WHELP*WHELP + WR = ONE + WI = ZERO +C + DO 60 J = 1, I +C + DO 50 K = J, N, L + M = K + I + TR = WR*XR(M) - WI*XI(M) + TI = WR*XI(M) + WI*XR(M) + XR(M) = XR(K) - TR + XI(M) = XI(K) - TI + XR(K) = XR(K) + TR + XI(K) = XI(K) + TI + 50 CONTINUE +C + WHELP = WR + WR = WR + WR*WSTPR - WI*WSTPI + WI = WI + WHELP*WSTPI + WI*WSTPR + 60 CONTINUE +C + I = L + GO TO 40 +C END WHILE 40 + END IF +C + RETURN +C *** Last line of DG01MD *** + END diff --git a/mex/sources/libslicot/DG01ND.f b/mex/sources/libslicot/DG01ND.f new file mode 100644 index 000000000..0a97d0ea5 --- /dev/null +++ b/mex/sources/libslicot/DG01ND.f @@ -0,0 +1,247 @@ + SUBROUTINE DG01ND( INDI, N, XR, XI, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the discrete Fourier transform, or inverse Fourier +C transform, of a real signal. +C +C ARGUMENTS +C +C Mode Parameters +C +C INDI CHARACTER*1 +C Indicates whether a Fourier transform or inverse Fourier +C transform is to be performed as follows: +C = 'D': (Direct) Fourier transform; +C = 'I': Inverse Fourier transform. +C +C Input/Output Parameters +C +C N (input) INTEGER +C Half the number of real samples. N must be a power of 2. +C N >= 2. +C +C XR (input/output) DOUBLE PRECISION array, dimension (N+1) +C On entry with INDI = 'D', the first N elements of this +C array must contain the odd part of the input signal; for +C example, XR(I) = A(2*I-1) for I = 1,2,...,N. +C On entry with INDI = 'I', the first N+1 elements of this +C array must contain the the real part of the input discrete +C Fourier transform (computed, for instance, by a previous +C call of the routine). +C On exit with INDI = 'D', the first N+1 elements of this +C array contain the real part of the output signal, that is +C of the computed discrete Fourier transform. +C On exit with INDI = 'I', the first N elements of this +C array contain the odd part of the output signal, that is +C of the computed inverse discrete Fourier transform. +C +C XI (input/output) DOUBLE PRECISION array, dimension (N+1) +C On entry with INDI = 'D', the first N elements of this +C array must contain the even part of the input signal; for +C example, XI(I) = A(2*I) for I = 1,2,...,N. +C On entry with INDI = 'I', the first N+1 elements of this +C array must contain the the imaginary part of the input +C discrete Fourier transform (computed, for instance, by a +C previous call of the routine). +C On exit with INDI = 'D', the first N+1 elements of this +C array contain the imaginary part of the output signal, +C that is of the computed discrete Fourier transform. +C On exit with INDI = 'I', the first N elements of this +C array contain the even part of the output signal, that is +C of the computed inverse discrete Fourier transform. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Let A(1),....,A(2*N) be a real signal of 2*N samples. Then the +C first N+1 samples of the discrete Fourier transform of this signal +C are given by the formula: +C +C 2*N ((m-1)*(i-1)) +C FA(m) = SUM ( A(i) * W ), +C i=1 +C 2 +C where m = 1,2,...,N+1, W = exp(-pi*j/N) and j = -1. +C +C This transform can be computed as follows. First, transform A(i), +C i = 1,2,...,2*N, into the complex signal Z(i) = (X(i),Y(i)), +C i = 1,2,...,N. That is, X(i) = A(2*i-1) and Y(i) = A(2*i). Next, +C perform a discrete Fourier transform on Z(i) by calling SLICOT +C Library routine DG01MD. This gives a new complex signal FZ(k), +C such that +C +C N ((k-1)*(i-1)) +C FZ(k) = SUM ( Z(i) * V ), +C i=1 +C +C where k = 1,2,...,N, V = exp(-2*pi*j/N). Using the values of +C FZ(k), the components of the discrete Fourier transform FA can be +C computed by simple linear relations, implemented in the DG01NY +C subroutine. +C +C Finally, let +C +C XR(k) = Re(FZ(k)), XI(k) = Im(FZ(k)), k = 1,2,...,N, +C +C be the contents of the arrays XR and XI on entry to DG01NY with +C INDI = 'D', then on exit XR and XI contain the real and imaginary +C parts of the Fourier transform of the original real signal A. +C That is, +C +C XR(m) = Re(FA(m)), XI(m) = Im(FA(m)), +C +C where m = 1,2,...,N+1. +C +C If INDI = 'I', then the routine evaluates the inverse Fourier +C transform of a complex signal which may itself be the discrete +C Fourier transform of a real signal. +C +C Let FA(m), m = 1,2,...,2*N, denote the full discrete Fourier +C transform of a real signal A(i), i=1,2,...,2*N. The relationship +C between FA and A is given by the formula: +C +C 2*N ((m-1)*(i-1)) +C A(i) = SUM ( FA(m) * W ), +C m=1 +C +C where W = exp(pi*j/N). +C +C Let +C +C XR(m) = Re(FA(m)) and XI(m) = Im(FA(m)) for m = 1,2,...,N+1, +C +C be the contents of the arrays XR and XI on entry to the routine +C DG01NY with INDI = 'I', then on exit the first N samples of the +C complex signal FZ are returned in XR and XI such that +C +C XR(k) = Re(FZ(k)), XI(k) = Im(FZ(k)) and k = 1,2,...,N. +C +C Next, an inverse Fourier transform is performed on FZ (e.g. by +C calling SLICOT Library routine DG01MD), to give the complex signal +C Z, whose i-th component is given by the formula: +C +C N ((k-1)*(i-1)) +C Z(i) = SUM ( FZ(k) * V ), +C k=1 +C +C where i = 1,2,...,N and V = exp(2*pi*j/N). +C +C Finally, the 2*N samples of the real signal A can then be obtained +C directly from Z. That is, +C +C A(2*i-1) = Re(Z(i)) and A(2*i) = Im(Z(i)), for i = 1,2,...N. +C +C Note that a discrete Fourier transform, followed by an inverse +C transform will result in a signal which is a factor 2*N larger +C than the original input signal. +C +C REFERENCES +C +C [1] Rabiner, L.R. and Rader, C.M. +C Digital Signal Processing. +C IEEE Press, 1972. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0( N*log(N) ) operations. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine DG01BD by R. Dekeyser, and +C F. Dumortier, State University of Gent, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Complex signals, digital signal processing, fast Fourier +C transform, real signals. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER INDI + INTEGER INFO, N +C .. Array Arguments .. + DOUBLE PRECISION XI(*), XR(*) +C .. Local Scalars .. + INTEGER J + LOGICAL LINDI +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DG01MD, DG01NY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MOD +C .. Executable Statements .. +C + INFO = 0 + LINDI = LSAME( INDI, 'D' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LINDI .AND. .NOT.LSAME( INDI, 'I' ) ) THEN + INFO = -1 + ELSE + J = 0 + IF( N.GE.2 ) THEN + J = N +C WHILE ( MOD( J, 2 ).EQ.0 ) DO + 10 CONTINUE + IF ( MOD( J, 2 ).EQ.0 ) THEN + J = J/2 + GO TO 10 + END IF +C END WHILE 10 + END IF + IF ( J.NE.1 ) INFO = -2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'DG01ND', -INFO ) + RETURN + END IF +C +C Compute the Fourier transform of Z = (XR,XI). +C + IF ( .NOT.LINDI ) CALL DG01NY( INDI, N, XR, XI ) +C + CALL DG01MD( INDI, N, XR, XI, INFO ) +C + IF ( LINDI ) CALL DG01NY( INDI, N, XR, XI ) +C + RETURN +C *** Last line of DG01ND *** + END diff --git a/mex/sources/libslicot/DG01NY.f b/mex/sources/libslicot/DG01NY.f new file mode 100644 index 000000000..9b7929dee --- /dev/null +++ b/mex/sources/libslicot/DG01NY.f @@ -0,0 +1,94 @@ + SUBROUTINE DG01NY( INDI, N, XR, XI ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C For efficiency, no tests of the input scalar parameters are +C performed. +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, TWO, EIGHT + PARAMETER ( ZERO=0.0D0, HALF=0.5D0, ONE = 1.0D0, + $ TWO=2.0D0, EIGHT=8.0D0 ) +C .. Scalar Arguments .. + CHARACTER INDI + INTEGER N +C .. Array Arguments .. + DOUBLE PRECISION XI(*), XR(*) +C .. Local Scalars .. + LOGICAL LINDI + INTEGER I, J, N2 + DOUBLE PRECISION AI, AR, BI, BR, HELPI, HELPR, PI2, WHELP, WI, + $ WR, WSTPI, WSTPR +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. Intrinsic Functions .. + INTRINSIC ATAN, DBLE, SIN +C .. Executable Statements .. +C + LINDI = LSAME( INDI, 'D' ) +C +C Initialisation. +C + PI2 = EIGHT*ATAN( ONE ) + IF ( LINDI ) PI2 = -PI2 +C + WHELP = PI2/DBLE( 2*N ) + WSTPI = SIN( WHELP ) + WHELP = SIN( HALF*WHELP ) + WSTPR = -TWO*WHELP*WHELP + WI = ZERO +C + IF ( LINDI ) THEN + WR = ONE + XR(N+1) = XR(1) + XI(N+1) = XI(1) + ELSE + WR = -ONE + END IF +C +C Recursion. +C + N2 = N/2 + 1 + DO 10 I = 1, N2 + J = N + 2 - I + AR = XR(I) + XR(J) + AI = XI(I) - XI(J) + BR = XI(I) + XI(J) + BI = XR(J) - XR(I) + IF ( LINDI ) THEN + AR = HALF*AR + AI = HALF*AI + BR = HALF*BR + BI = HALF*BI + END IF + HELPR = WR*BR - WI*BI + HELPI = WR*BI + WI*BR + XR(I) = AR + HELPR + XI(I) = AI + HELPI + XR(J) = AR - HELPR + XI(J) = HELPI - AI + WHELP = WR + WR = WR + WR*WSTPR - WI*WSTPI + WI = WI + WI*WSTPR + WHELP*WSTPI + 10 CONTINUE +C + RETURN +C *** Last line of DG01NY *** + END diff --git a/mex/sources/libslicot/DG01OD.f b/mex/sources/libslicot/DG01OD.f new file mode 100644 index 000000000..ded9d479f --- /dev/null +++ b/mex/sources/libslicot/DG01OD.f @@ -0,0 +1,357 @@ + SUBROUTINE DG01OD( SCR, WGHT, N, A, W, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the (scrambled) discrete Hartley transform of +C a real signal. +C +C ARGUMENTS +C +C Mode Parameters +C +C SCR CHARACTER*1 +C Indicates whether the signal is scrambled on input or +C on output as follows: +C = 'N': the signal is not scrambled at all; +C = 'I': the input signal is bit-reversed; +C = 'O': the output transform is bit-reversed. +C +C WGHT CHARACTER*1 +C Indicates whether the precomputed weights are available +C or not, as follows: +C = 'A': available; +C = 'N': not available. +C Note that if N > 1 and WGHT = 'N' on entry, then WGHT is +C set to 'A' on exit. +C +C Input/Output Parameters +C +C N (input) INTEGER +C Number of real samples. N must be a power of 2. +C N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (N) +C On entry with SCR = 'N' or SCR = 'O', this array must +C contain the input signal. +C On entry with SCR = 'I', this array must contain the +C bit-reversed input signal. +C On exit with SCR = 'N' or SCR = 'I', this array contains +C the Hartley transform of the input signal. +C On exit with SCR = 'O', this array contains the +C bit-reversed Hartley transform. +C +C W (input/output) DOUBLE PRECISION array, +C dimension (N - LOG2(N)) +C On entry with WGHT = 'A', this array must contain the long +C weight vector computed by a previous call of this routine +C with the same value of N. If WGHT = 'N', the contents of +C this array on entry is ignored. +C On exit, this array contains the long weight vector. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C This routine uses a Hartley butterfly algorithm as described +C in [1]. +C +C REFERENCES +C +C [1] Van Loan, Charles. +C Computational frameworks for the fast Fourier transform. +C SIAM, 1992. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable and requires O(N log(N)) +C floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, April 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C +C KEYWORDS +C +C Digital signal processing, fast Hartley transform, real signals. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TWO, FOUR + PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, FOUR = 4.0D0 ) +C .. Scalar Arguments .. + CHARACTER SCR, WGHT + INTEGER INFO, N +C .. Array Arguments .. + DOUBLE PRECISION A(*), W(*) +C .. Local Scalars .. + INTEGER I, J, L, LEN, M, P1, P2, Q1, Q2, R1, R2, S1, S2, + $ WPOS + LOGICAL LFWD, LSCR, LWGHT + DOUBLE PRECISION CF, SF, T1, T2, TH +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC ATAN, COS, DBLE, MOD, SIN +C .. Executable Statements .. +C + INFO = 0 + LFWD = LSAME( SCR, 'N' ) .OR. LSAME( SCR, 'I' ) + LSCR = LSAME( SCR, 'I' ) .OR. LSAME( SCR, 'O' ) + LWGHT = LSAME( WGHT, 'A' ) +C +C Test the input scalar arguments. +C + IF( .NOT.( LFWD .OR. LSCR ) ) THEN + INFO = -1 + ELSE IF( .NOT.LWGHT .AND. .NOT.LSAME( WGHT, 'N' ) ) THEN + INFO = -2 + ELSE + M = 0 + J = 0 + IF( N.GE.1 ) THEN + J = N +C WHILE ( MOD( J, 2 ).EQ.0 ) DO + 10 CONTINUE + IF ( MOD( J, 2 ).EQ.0 ) THEN + J = J/2 + M = M + 1 + GO TO 10 + END IF +C END WHILE 10 + IF ( J.NE.1 ) INFO = -3 + ELSE IF ( N.LT.0 ) THEN + INFO = -3 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'DG01OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.LE.1 ) + $ RETURN +C + IF ( .NOT. LWGHT ) THEN +C +C Compute the long weight vector via subvector scaling. +C + R1 = 1 + LEN = 1 + TH = FOUR*ATAN( ONE ) / DBLE( N ) +C + DO 30 L = 1, M - 2 + LEN = 2*LEN + TH = TWO*TH + CF = COS(TH) + SF = SIN(TH) + W(R1) = CF + W(R1+1) = SF + R1 = R1 + 2 +C + DO 20 I = 1, LEN - 2, 2 + W(R1) = CF*W(I) - SF*W(I+1) + W(R1+1) = SF*W(I) + CF*W(I+1) + R1 = R1 + 2 + 20 CONTINUE +C + 30 CONTINUE +C + P1 = 3 + Q1 = R1 - 2 +C + DO 50 L = M - 2, 1, -1 +C + DO 40 I = P1, Q1, 4 + W(R1) = W(I) + W(R1+1) = W(I+1) + R1 = R1 + 2 + 40 CONTINUE +C + P1 = Q1 + 4 + Q1 = R1 - 2 + 50 CONTINUE +C + WGHT = 'A' +C + END IF +C + IF ( LFWD .AND. .NOT.LSCR ) THEN +C +C Inplace shuffling of data. +C + J = 1 +C + DO 70 I = 1, N + IF ( J.GT.I ) THEN + T1 = A(I) + A(I) = A(J) + A(J) = T1 + END IF + L = N/2 +C REPEAT + 60 IF ( J.GT.L ) THEN + J = J - L + L = L/2 + IF ( L.GE.2 ) GO TO 60 + END IF +C UNTIL ( L.LT.2 ) + J = J + L + 70 CONTINUE +C + END IF +C + IF ( LFWD ) THEN +C +C Compute Hartley transform with butterfly operators. +C + DO 110 J = 2, N, 2 + T1 = A(J) + A(J) = A(J-1) - T1 + A(J-1) = A(J-1) + T1 + 110 CONTINUE +C + LEN = 1 + WPOS = N - 2*M + 1 +C + DO 140 L = 1, M - 1 + LEN = 2*LEN + P2 = 1 + Q2 = LEN + 1 + R2 = LEN / 2 + 1 + S2 = R2 + Q2 - 1 +C + DO 130 I = 0, N/( 2*LEN ) - 1 + T1 = A(Q2) + A(Q2) = A(P2) - T1 + A(P2) = A(P2) + T1 + T1 = A(S2) + A(S2) = A(R2) - T1 + A(R2) = A(R2) + T1 +C + P1 = P2 + 1 + Q1 = P1 + LEN + R1 = Q1 - 2 + S1 = R1 + LEN +C + DO 120 J = WPOS, WPOS + LEN - 3, 2 + CF = W(J) + SF = W(J+1) + T1 = CF*A(Q1) + SF*A(S1) + T2 = -CF*A(S1) + SF*A(Q1) + A(Q1) = A(P1) - T1 + A(P1) = A(P1) + T1 + A(S1) = A(R1) - T2 + A(R1) = A(R1) + T2 + P1 = P1 + 1 + Q1 = Q1 + 1 + R1 = R1 - 1 + S1 = S1 - 1 + 120 CONTINUE +C + P2 = P2 + 2*LEN + Q2 = Q2 + 2*LEN + R2 = R2 + 2*LEN + S2 = S2 + 2*LEN + 130 CONTINUE +C + WPOS = WPOS - 2*LEN + 2 + 140 CONTINUE +C + ELSE +C +C Compute Hartley transform with transposed butterfly operators. +C + WPOS = 1 + LEN = N +C + DO 230 L = M - 1, 1, -1 + LEN = LEN / 2 + P2 = 1 + Q2 = LEN + 1 + R2 = LEN / 2 + 1 + S2 = R2 + Q2 - 1 +C + DO 220 I = 0, N/( 2*LEN ) - 1 + T1 = A(Q2) + A(Q2) = A(P2) - T1 + A(P2) = A(P2) + T1 + T1 = A(S2) + A(S2) = A(R2) - T1 + A(R2) = A(R2) + T1 +C + P1 = P2 + 1 + Q1 = P1 + LEN + R1 = Q1 - 2 + S1 = R1 + LEN +C + DO 210 J = WPOS, WPOS + LEN - 3, 2 + CF = W(J) + SF = W(J+1) + T1 = A(P1) - A(Q1) + T2 = A(R1) - A(S1) + A(P1) = A(P1) + A(Q1) + A(R1) = A(R1) + A(S1) + A(Q1) = CF*T1 + SF*T2 + A(S1) = -CF*T2 + SF*T1 + P1 = P1 + 1 + Q1 = Q1 + 1 + R1 = R1 - 1 + S1 = S1 - 1 + 210 CONTINUE +C + P2 = P2 + 2*LEN + Q2 = Q2 + 2*LEN + R2 = R2 + 2*LEN + S2 = S2 + 2*LEN + 220 CONTINUE +C + WPOS = WPOS + LEN - 2 + 230 CONTINUE +C + DO 240 J = 2, N, 2 + T1 = A(J) + A(J) = A(J-1) - T1 + A(J-1) = A(J-1) + T1 + 240 CONTINUE +C + END IF + RETURN +C *** Last line of DG01OD *** + END diff --git a/mex/sources/libslicot/DK01MD.f b/mex/sources/libslicot/DK01MD.f new file mode 100644 index 000000000..3ae298675 --- /dev/null +++ b/mex/sources/libslicot/DK01MD.f @@ -0,0 +1,183 @@ + SUBROUTINE DK01MD( TYPE, N, A, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply an anti-aliasing window to a real signal. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPE CHARACTER*1 +C Indicates the type of window to be applied to the signal +C as follows: +C = 'M': Hamming window; +C = 'N': Hann window; +C = 'Q': Quadratic window. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of samples. N >= 1. +C +C A (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the signal to be +C processed. +C On exit, this array contains the windowing function. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C If TYPE = 'M', then a Hamming window is applied to A(1),...,A(N), +C which yields +C _ +C A(i) = (0.54 + 0.46*cos(pi*(i-1)/(N-1)))*A(i), i = 1,2,...,N. +C +C If TYPE = 'N', then a Hann window is applied to A(1),...,A(N), +C which yields +C _ +C A(i) = 0.5*(1 + cos(pi*(i-1)/(N-1)))*A(i), i = 1,2,...,N. +C +C If TYPE = 'Q', then a quadratic window is applied to A(1),..., +C A(N), which yields +C _ +C A(i) = (1 - 2*((i-1)/(N-1))**2)*(1 - (i-1)/(N-1))*A(i), +C i = 1,2,...,(N-1)/2+1; +C _ +C A(i) = 2*(1 - ((i-1)/(N-1))**3)*A(i), i = (N-1)/2+2,...,N. +C +C REFERENCES +C +C [1] Rabiner, L.R. and Rader, C.M. +C Digital Signal Processing. +C IEEE Press, 1972. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0( N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine DK01AD by R. Dekeyser, State +C University of Gent, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Digital signal processing, Hamming window, Hann window, real +C signals, windowing. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION PT46, HALF, PT54, ONE, TWO, FOUR + PARAMETER ( PT46=0.46D0, HALF=0.5D0, PT54=0.54D0, + $ ONE = 1.0D0, TWO=2.0D0, FOUR=4.0D0 ) +C .. Scalar Arguments .. + CHARACTER TYPE + INTEGER INFO, N +C .. Array Arguments .. + DOUBLE PRECISION A(*) +C .. Local Scalars .. + LOGICAL MTYPE, MNTYPE, NTYPE + INTEGER I, N1 + DOUBLE PRECISION BUF, FN, TEMP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC ATAN, COS, DBLE +C .. Executable Statements .. +C + INFO = 0 + MTYPE = LSAME( TYPE, 'M' ) + NTYPE = LSAME( TYPE, 'N' ) + MNTYPE = MTYPE.OR.NTYPE +C +C Test the input scalar arguments. +C + IF( .NOT.MNTYPE .AND. .NOT.LSAME( TYPE, 'Q' ) ) + $ THEN + INFO = -1 + ELSE IF( N.LE.0 ) THEN + INFO = -2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'DK01MD', -INFO ) + RETURN + END IF +C + FN = DBLE( N-1 ) + IF( MNTYPE ) TEMP = FOUR*ATAN( ONE )/FN +C + IF ( MTYPE ) THEN +C +C Hamming window. +C + DO 10 I = 1, N + A(I) = A(I)*( PT54 + PT46*COS( TEMP*DBLE( I-1 ) ) ) + 10 CONTINUE +C + ELSE IF ( NTYPE ) THEN +C +C Hann window. +C + DO 20 I = 1, N + A(I) = A(I)*HALF*( ONE + COS( TEMP*DBLE( I-1 ) ) ) + 20 CONTINUE +C + ELSE +C +C Quadratic window. +C + N1 = ( N-1 )/2 + 1 +C + DO 30 I = 1, N + BUF = DBLE( I-1 )/FN + TEMP = BUF**2 + IF ( I.LE.N1 ) THEN + A(I) = A(I)*( ONE - TWO*TEMP )*( ONE - BUF ) + ELSE + A(I) = A(I)*TWO*( ONE - BUF*TEMP ) + END IF + 30 CONTINUE +C + END IF +C + RETURN +C *** Last line of DK01MD *** + END diff --git a/mex/sources/libslicot/FB01QD.f b/mex/sources/libslicot/FB01QD.f new file mode 100644 index 000000000..4bcc391f9 --- /dev/null +++ b/mex/sources/libslicot/FB01QD.f @@ -0,0 +1,464 @@ + SUBROUTINE FB01QD( JOBK, MULTBQ, N, M, P, S, LDS, A, LDA, B, + $ LDB, Q, LDQ, C, LDC, R, LDR, K, LDK, TOL, + $ IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate a combined measurement and time update of one +C iteration of the time-varying Kalman filter. This update is given +C for the square root covariance filter, using dense matrices. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBK CHARACTER*1 +C Indicates whether the user wishes to compute the Kalman +C filter gain matrix K as follows: +C i +C = 'K': K is computed and stored in array K; +C i +C = 'N': K is not required. +C i +C +C MULTBQ CHARACTER*1 1/2 +C Indicates how matrices B and Q are to be passed to +C i i +C the routine as follows: +C = 'P': Array Q is not used and the array B must contain +C 1/2 +C the product B Q ; +C i i +C = 'N': Arrays B and Q must contain the matrices as +C described below. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e., the order of the +C matrices S and A . N >= 0. +C i-1 i +C +C M (input) INTEGER +C The actual input dimension, i.e., the order of the matrix +C 1/2 +C Q . M >= 0. +C i +C +C P (input) INTEGER +C The actual output dimension, i.e., the order of the matrix +C 1/2 +C R . P >= 0. +C i +C +C S (input/output) DOUBLE PRECISION array, dimension (LDS,N) +C On entry, the leading N-by-N lower triangular part of this +C array must contain S , the square root (left Cholesky +C i-1 +C factor) of the state covariance matrix at instant (i-1). +C On exit, the leading N-by-N lower triangular part of this +C array contains S , the square root (left Cholesky factor) +C i +C of the state covariance matrix at instant i. +C The strict upper triangular part of this array is not +C referenced. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,N). +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain A , +C i +C the state transition matrix of the discrete system at +C instant i. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain B , +C 1/2 i +C the input weight matrix (or the product B Q if +C i i +C MULTBQ = 'P') of the discrete system at instant i. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C Q (input) DOUBLE PRECISION array, dimension (LDQ,*) +C If MULTBQ = 'N', then the leading M-by-M lower triangular +C 1/2 +C part of this array must contain Q , the square root +C i +C (left Cholesky factor) of the input (process) noise +C covariance matrix at instant i. +C The strict upper triangular part of this array is not +C referenced. +C If MULTBQ = 'P', Q is not referenced and can be supplied +C as a dummy array (i.e., set parameter LDQ = 1 and declare +C this array to be Q(1,1) in the calling program). +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= MAX(1,M) if MULTBQ = 'N'; +C LDQ >= 1 if MULTBQ = 'P'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain C , the +C i +C output weight matrix of the discrete system at instant i. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,P) +C On entry, the leading P-by-P lower triangular part of this +C 1/2 +C array must contain R , the square root (left Cholesky +C i +C factor) of the output (measurement) noise covariance +C matrix at instant i. +C On exit, the leading P-by-P lower triangular part of this +C 1/2 +C array contains (RINOV ) , the square root (left Cholesky +C i +C factor) of the covariance matrix of the innovations at +C instant i. +C The strict upper triangular part of this array is not +C referenced. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,P). +C +C K (output) DOUBLE PRECISION array, dimension (LDK,P) +C If JOBK = 'K', and INFO = 0, then the leading N-by-P part +C of this array contains K , the Kalman filter gain matrix +C i +C at instant i. +C If JOBK = 'N', or JOBK = 'K' and INFO = 1, then the +C leading N-by-P part of this array contains AK , a matrix +C i +C related to the Kalman filter gain matrix at instant i (see +C -1/2 +C METHOD). Specifically, AK = A P C'(RINOV') . +C i i i|i-1 i i +C +C LDK INTEGER +C The leading dimension of array K. LDK >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If JOBK = 'K', then TOL is used to test for near +C 1/2 +C singularity of the matrix (RINOV ) . If the user sets +C i +C TOL > 0, then the given value of TOL is used as a +C lower bound for the reciprocal condition number of that +C matrix; a matrix whose estimated condition number is less +C than 1/TOL is considered to be nonsingular. If the user +C sets TOL <= 0, then an implicitly computed, default +C tolerance, defined by TOLDEF = P*P*EPS, is used instead, +C where EPS is the machine precision (see LAPACK Library +C routine DLAMCH). +C Otherwise, TOL is not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), +C where LIWORK = P if JOBK = 'K', +C and LIWORK = 1 otherwise. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. If INFO = 0 and JOBK = 'K', DWORK(2) returns +C an estimate of the reciprocal of the condition number +C 1/2 +C (in the 1-norm) of (RINOV ) . +C i +C +C LDWORK The length of the array DWORK. +C LDWORK >= MAX(1,N*(P+N)+2*P,N*(N+M+2)), if JOBK = 'N'; +C LDWORK >= MAX(2,N*(P+N)+2*P,N*(N+M+2),3*P), if JOBK = 'K'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C 1/2 +C = 1: if JOBK = 'K' and the matrix (RINOV ) is singular, +C i 1/2 +C i.e., the condition number estimate of (RINOV ) +C i +C (in the 1-norm) exceeds 1/TOL. The matrices S, AK , +C 1/2 i +C and (RINOV ) have been computed. +C i +C +C METHOD +C +C The routine performs one recursion of the square root covariance +C filter algorithm, summarized as follows: +C +C | 1/2 | | 1/2 | +C | R C x S 0 | | (RINOV ) 0 0 | +C | i i i-1 | | i | +C | 1/2 | T = | | +C | 0 A x S B x Q | | AK S 0 | +C | i i-1 i i | | i i | +C +C (Pre-array) (Post-array) +C +C where T is an orthogonal transformation triangularizing the +C pre-array. +C +C The state covariance matrix P is factorized as +C i|i-1 +C P = S S' +C i|i-1 i i +C +C and one combined time and measurement update for the state X +C i|i-1 +C is given by +C +C X = A X + K (Y - C X ), +C i+1|i i i|i-1 i i i i|i-1 +C +C -1/2 +C where K = AK (RINOV ) is the Kalman filter gain matrix and Y +C i i i i +C is the observed output of the system. +C +C The triangularization is done entirely via Householder +C transformations exploiting the zero pattern of the pre-array. +C +C REFERENCES +C +C [1] Anderson, B.D.O. and Moore, J.B. +C Optimal Filtering. +C Prentice Hall, Englewood Cliffs, New Jersey, 1979. +C +C [2] Verhaegen, M.H.G. and Van Dooren, P. +C Numerical Aspects of Different Kalman Filter Implementations. +C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. +C +C [3] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. +C Algorithm 675: FORTRAN Subroutines for Computing the Square +C Root Covariance Filter and Square Root Information Filter in +C Dense or Hessenberg Forms. +C ACM Trans. Math. Software, 15, pp. 243-256, 1989. +C +C NUMERICAL ASPECTS +C +C The algorithm requires +C +C 3 2 2 2 +C (7/6)N + N x (5/2 x P + M) + N x (1/2 x M + P ) +C +C operations and is backward stable (see [2]). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine FB01ED by M. Vanbegin, +C P. Van Dooren, and M.H.G. Verhaegen. +C +C REVISIONS +C +C February 20, 1998, November 20, 2003. +C +C KEYWORDS +C +C Kalman filtering, optimal filtering, orthogonal transformation, +C recursive estimation, square-root covariance filtering, +C square-root filtering. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBK, MULTBQ + INTEGER INFO, LDA, LDB, LDC, LDK, LDQ, LDR, LDS, LDWORK, + $ M, N, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ K(LDK,*), Q(LDQ,*), R(LDR,*), S(LDS,*) +C .. Local Scalars .. + LOGICAL LJOBK, LMULTB + INTEGER I12, ITAU, JWORK, N1, PN, WRKOPT + DOUBLE PRECISION RCOND +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGELQF, DLACPY, DTRMM, MB02OD, MB04LD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + PN = P + N + N1 = MAX( 1, N ) + INFO = 0 + LJOBK = LSAME( JOBK, 'K' ) + LMULTB = LSAME( MULTBQ, 'P' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBK .AND. .NOT.LSAME( JOBK, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LMULTB .AND. .NOT.LSAME( MULTBQ, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDS.LT.N1 ) THEN + INFO = -7 + ELSE IF( LDA.LT.N1 ) THEN + INFO = -9 + ELSE IF( LDB.LT.N1 ) THEN + INFO = -11 + ELSE IF( LDQ.LT.1 .OR. ( .NOT.LMULTB .AND. LDQ.LT.M ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDR.LT.MAX( 1, P ) ) THEN + INFO = -17 + ELSE IF( LDK.LT.N1 ) THEN + INFO = -19 + ELSE IF( ( LJOBK .AND. LDWORK.LT.MAX( 2, PN*N + 2*P, + $ N*(N + M + 2), 3*P ) ) .OR. + $ ( .NOT.LJOBK .AND. LDWORK.LT.MAX( 1, PN*N + 2*P, + $ N*(N + M + 2) ) ) ) THEN + INFO = -23 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'FB01QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + IF ( LJOBK ) THEN + DWORK(1) = TWO + DWORK(2) = ONE + ELSE + DWORK(1) = ONE + END IF + RETURN + END IF +C +C Construction of the needed part of the pre-array in DWORK. +C To save workspace, only the blocks (1,2), (2,2), and (2,3) will be +C constructed as shown below. +C +C Storing A x S and C x S in the (1,1) and (2,1) blocks of DWORK, +C respectively. +C Workspace: need (N+P)*N. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, PN ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(N+1), PN ) + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', PN, N, + $ ONE, S, LDS, DWORK, PN ) +C +C Triangularization (2 steps). +C +C Step 1: annihilate the matrix C x S. +C Workspace: need (N+P)*N + 2*P. +C + ITAU = PN*N + 1 + JWORK = ITAU + P +C + CALL MB04LD( 'Full', P, N, N, R, LDR, DWORK(N+1), PN, DWORK, PN, + $ K, LDK, DWORK(ITAU), DWORK(JWORK) ) + WRKOPT = PN*N + 2*P +C +C Now, the workspace for C x S is no longer needed. +C Adjust the leading dimension of DWORK, to save space for the +C following computations. +C + CALL DLACPY( 'Full', N, N, DWORK, PN, DWORK, N ) + I12 = N*N + 1 +C +C Storing B x Q in the (1,2) block of DWORK. +C Workspace: need N*(N+M). +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(I12), N ) + IF ( .NOT.LMULTB ) + $ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', N, M, + $ ONE, Q, LDQ, DWORK(I12), N ) + WRKOPT = MAX( WRKOPT, N*( N + M ) ) +C +C Step 2: LQ triangularization of the matrix [ A x S B x Q ], where +C A x S was modified at Step 1. +C Workspace: need N*(N+M+2); prefer N*(N+M+1)+N*NB. +C + ITAU = N*( N + M ) + 1 + JWORK = ITAU + N +C + CALL DGELQF( N, N+M, DWORK, N, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Output S and K (if needed) and set the optimal workspace +C dimension (and the reciprocal of the condition number estimate). +C + CALL DLACPY( 'Lower', N, N, DWORK, N, S, LDS ) +C + IF ( LJOBK ) THEN +C +C Compute K. +C Workspace: need 3*P. +C + CALL MB02OD( 'Right', 'Lower', 'No transpose', 'Non-unit', + $ '1-norm', N, P, ONE, R, LDR, K, LDK, RCOND, TOL, + $ IWORK, DWORK, INFO ) + IF ( INFO.EQ.0 ) THEN + WRKOPT = MAX( WRKOPT, 3*P ) + DWORK(2) = RCOND + END IF + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of FB01QD *** + END diff --git a/mex/sources/libslicot/FB01RD.f b/mex/sources/libslicot/FB01RD.f new file mode 100644 index 000000000..721cb2ae7 --- /dev/null +++ b/mex/sources/libslicot/FB01RD.f @@ -0,0 +1,535 @@ + SUBROUTINE FB01RD( JOBK, MULTBQ, N, M, P, S, LDS, A, LDA, B, + $ LDB, Q, LDQ, C, LDC, R, LDR, K, LDK, TOL, + $ IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate a combined measurement and time update of one +C iteration of the time-invariant Kalman filter. This update is +C given for the square root covariance filter, using the condensed +C observer Hessenberg form. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBK CHARACTER*1 +C Indicates whether the user wishes to compute the Kalman +C filter gain matrix K as follows: +C i +C = 'K': K is computed and stored in array K; +C i +C = 'N': K is not required. +C i +C +C MULTBQ CHARACTER*1 1/2 +C Indicates how matrices B and Q are to be passed to +C i i +C the routine as follows: +C = 'P': Array Q is not used and the array B must contain +C 1/2 +C the product B Q ; +C i i +C = 'N': Arrays B and Q must contain the matrices as +C described below. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e., the order of the +C matrices S and A. N >= 0. +C i-1 +C +C M (input) INTEGER +C The actual input dimension, i.e., the order of the matrix +C 1/2 +C Q . M >= 0. +C i +C +C P (input) INTEGER +C The actual output dimension, i.e., the order of the matrix +C 1/2 +C R . P >= 0. +C i +C +C S (input/output) DOUBLE PRECISION array, dimension (LDS,N) +C On entry, the leading N-by-N lower triangular part of this +C array must contain S , the square root (left Cholesky +C i-1 +C factor) of the state covariance matrix at instant (i-1). +C On exit, the leading N-by-N lower triangular part of this +C array contains S , the square root (left Cholesky factor) +C i +C of the state covariance matrix at instant i. +C The strict upper triangular part of this array is not +C referenced. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,N). +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain A, +C the state transition matrix of the discrete system in +C lower observer Hessenberg form (e.g., as produced by +C SLICOT Library Routine TB01ND). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain B , +C 1/2 i +C the input weight matrix (or the product B Q if +C i i +C MULTBQ = 'P') of the discrete system at instant i. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C Q (input) DOUBLE PRECISION array, dimension (LDQ,*) +C If MULTBQ = 'N', then the leading M-by-M lower triangular +C 1/2 +C part of this array must contain Q , the square root +C i +C (left Cholesky factor) of the input (process) noise +C covariance matrix at instant i. +C The strict upper triangular part of this array is not +C referenced. +C Otherwise, Q is not referenced and can be supplied as a +C dummy array (i.e., set parameter LDQ = 1 and declare this +C array to be Q(1,1) in the calling program). +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= MAX(1,M) if MULTBQ = 'N'; +C LDQ >= 1 if MULTBQ = 'P'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain C, +C the output weight matrix of the discrete system in lower +C observer Hessenberg form (e.g., as produced by SLICOT +C Library routine TB01ND). +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,P) +C On entry, the leading P-by-P lower triangular part of this +C 1/2 +C array must contain R , the square root (left Cholesky +C i +C factor) of the output (measurement) noise covariance +C matrix at instant i. +C On exit, the leading P-by-P lower triangular part of this +C 1/2 +C array contains (RINOV ) , the square root (left Cholesky +C i +C factor) of the covariance matrix of the innovations at +C instant i. +C The strict upper triangular part of this array is not +C referenced. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,P). +C +C K (output) DOUBLE PRECISION array, dimension (LDK,P) +C If JOBK = 'K', and INFO = 0, then the leading N-by-P part +C of this array contains K , the Kalman filter gain matrix +C i +C at instant i. +C If JOBK = 'N', or JOBK = 'K' and INFO = 1, then the +C leading N-by-P part of this array contains AK , a matrix +C i +C related to the Kalman filter gain matrix at instant i (see +C -1/2 +C METHOD). Specifically, AK = A P C'(RINOV') . +C i i|i-1 i +C +C LDK INTEGER +C The leading dimension of array K. LDK >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If JOBK = 'K', then TOL is used to test for near +C 1/2 +C singularity of the matrix (RINOV ) . If the user sets +C i +C TOL > 0, then the given value of TOL is used as a +C lower bound for the reciprocal condition number of that +C matrix; a matrix whose estimated condition number is less +C than 1/TOL is considered to be nonsingular. If the user +C sets TOL <= 0, then an implicitly computed, default +C tolerance, defined by TOLDEF = P*P*EPS, is used instead, +C where EPS is the machine precision (see LAPACK Library +C routine DLAMCH). +C Otherwise, TOL is not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C where LIWORK = P if JOBK = 'K', +C and LIWORK = 1 otherwise. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. If INFO = 0 and JOBK = 'K', DWORK(2) returns +C an estimate of the reciprocal of the condition number +C 1/2 +C (in the 1-norm) of (RINOV ) . +C i +C +C LDWORK The length of the array DWORK. +C LDWORK >= MAX(1,N*(P+N+1),N*(P+N)+2*P,N*(N+M+2)), +C if JOBK = 'N'; +C LDWORK >= MAX(2,N*(P+N+1),N*(P+N)+2*P,N*(N+M+2),3*P), +C if JOBK = 'K'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C 1/2 +C = 1: if JOBK = 'K' and the matrix (RINOV ) is singular, +C i 1/2 +C i.e., the condition number estimate of (RINOV ) +C i +C (in the 1-norm) exceeds 1/TOL. The matrices S, AK , +C 1/2 i +C and (RINOV ) have been computed. +C i +C +C METHOD +C +C The routine performs one recursion of the square root covariance +C filter algorithm, summarized as follows: +C +C | 1/2 | | 1/2 | +C | R 0 C x S | | (RINOV ) 0 0 | +C | i i-1 | | i | +C | 1/2 | T = | | +C | 0 B x Q A x S | | AK S 0 | +C | i i i-1 | | i i | +C +C (Pre-array) (Post-array) +C +C where T is unitary and (A,C) is in lower observer Hessenberg form. +C +C An example of the pre-array is given below (where N = 6, P = 2 +C and M = 3): +C +C |x | | x | +C |x x | | x x | +C |____|______|____________| +C | | x x x| x x x | +C | | x x x| x x x x | +C | | x x x| x x x x x | +C | | x x x| x x x x x x| +C | | x x x| x x x x x x| +C | | x x x| x x x x x x| +C +C The corresponding state covariance matrix P is then +C i|i-1 +C factorized as +C +C P = S S' +C i|i-1 i i +C +C and one combined time and measurement update for the state X +C i|i-1 +C is given by +C +C X = A X + K (Y - C X ) +C i+1|i i|i-1 i i i|i-1 +C +C -1/2 +C where K = AK (RINOV ) is the Kalman filter gain matrix and Y +C i i i i +C is the observed output of the system. +C +C The triangularization is done entirely via Householder +C transformations exploiting the zero pattern of the pre-array. +C +C REFERENCES +C +C [1] Anderson, B.D.O. and Moore, J.B. +C Optimal Filtering. +C Prentice Hall, Englewood Cliffs, New Jersey, 1979. +C +C [2] Van Dooren, P. and Verhaegen, M.H.G. +C Condensed Forms for Efficient Time-Invariant Kalman Filtering. +C SIAM J. Sci. Stat. Comp., 9. pp. 516-530, 1988. +C +C [3] Verhaegen, M.H.G. and Van Dooren, P. +C Numerical Aspects of Different Kalman Filter Implementations. +C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. +C +C [4] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. +C Algorithm 675: FORTRAN Subroutines for Computing the Square +C Root Covariance Filter and Square Root Information Filter in +C Dense or Hessenberg Forms. +C ACM Trans. Math. Software, 15, pp. 243-256, 1989. +C +C NUMERICAL ASPECTS +C +C The algorithm requires +C +C 3 2 2 3 +C 1/6 x N + N x (3/2 x P + M) + 2 x N x P + 2/3 x P +C +C operations and is backward stable (see [3]). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine FB01FD by M. Vanbegin, +C P. Van Dooren, and M.H.G. Verhaegen. +C +C REVISIONS +C +C February 20, 1998, November 20, 2003, February 14, 2004. +C +C KEYWORDS +C +C Kalman filtering, observer Hessenberg form, optimal filtering, +C orthogonal transformation, recursive estimation, square-root +C covariance filtering, square-root filtering. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TWO + PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBK, MULTBQ + INTEGER INFO, LDA, LDB, LDC, LDK, LDQ, LDR, LDS, LDWORK, + $ M, N, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ K(LDK,*), Q(LDQ,*), R(LDR,*), S(LDS,*) +C .. Local Scalars .. + LOGICAL LJOBK, LMULTB + INTEGER I, II, ITAU, JWORK, N1, PL, PN, WRKOPT + DOUBLE PRECISION RCOND +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DTRMM, DTRMV, MB02OD, MB04JD, + $ MB04LD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + PN = P + N + N1 = MAX( 1, N ) + INFO = 0 + LJOBK = LSAME( JOBK, 'K' ) + LMULTB = LSAME( MULTBQ, 'P' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBK .AND. .NOT.LSAME( JOBK, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LMULTB .AND. .NOT.LSAME( MULTBQ, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDS.LT.N1 ) THEN + INFO = -7 + ELSE IF( LDA.LT.N1 ) THEN + INFO = -9 + ELSE IF( LDB.LT.N1 ) THEN + INFO = -11 + ELSE IF( LDQ.LT.1 .OR. ( .NOT.LMULTB .AND. LDQ.LT.M ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDR.LT.MAX( 1, P ) ) THEN + INFO = -17 + ELSE IF( LDK.LT.N1 ) THEN + INFO = -19 + ELSE IF( ( LJOBK .AND. LDWORK.LT.MAX( 2, PN*N + N, PN*N + 2*P, + $ N*(N + M + 2), 3*P ) ) .OR. + $ ( .NOT.LJOBK .AND. LDWORK.LT.MAX( 1, PN*N + N, PN*N + 2*P, + $ N*(N + M + 2) ) ) ) THEN + INFO = -23 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'FB01RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + IF ( LJOBK ) THEN + DWORK(1) = TWO + DWORK(2) = ONE + ELSE + DWORK(1) = ONE + END IF + RETURN + END IF +C +C Construction of the needed part of the pre-array in DWORK. +C To save workspace, only the blocks (1,3), (2,2), and (2,3) will be +C constructed as shown below. +C +C Storing C x S and A x S in the (1,1) and (2,1) blocks of DWORK, +C respectively. The lower trapezoidal structure of [ C' A' ]' is +C fully exploited. Specifically, if P <= N, the following partition +C is used: +C +C [ C1 0 ] [ S1 0 ] +C [ A1 A3 ] [ S2 S3 ], +C [ A2 A4 ] +C +C where C1, S1, and A2 are P-by-P matrices, A1 and S2 are +C (N-P)-by-P, A3 and S3 are (N-P)-by-(N-P), A4 is P-by-(N-P), and +C C1, S1, A3, and S3 are lower triangular. The left hand side +C matrix above is stored in the workspace. If P > N, the partition +C is: +C +C [ C1 ] +C [ C2 ] [ S ], +C [ A ] +C +C where C1 and C2 are N-by-N and (P-N)-by-N matrices, respectively, +C and C1 and S are lower triangular. +C +C Workspace: need (P+N)*N. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + CALL DLACPY( 'Lower', P, MIN( N, P ), C, LDC, DWORK, PN ) + CALL DLACPY( 'Full', N, MIN( N, P ), A, LDA, DWORK(P+1), PN ) + IF ( N.GT.P ) + $ CALL DLACPY( 'Lower', N, N-P, A(1,P+1), LDA, DWORK(P*PN+P+1), + $ PN ) +C +C [ C1 0 ] +C Compute [ ] x S or C1 x S as a product of lower triangular +C [ A1 A3 ] +C matrices. +C Workspace: need (P+N+1)*N. +C + II = 1 + PL = N*PN + 1 + WRKOPT = PL + N - 1 +C + DO 10 I = 1, N + CALL DCOPY( N-I+1, S(I,I), 1, DWORK(PL), 1 ) + CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', N-I+1, + $ DWORK(II), PN, DWORK(PL), 1 ) + CALL DCOPY( N-I+1, DWORK(PL), 1, DWORK(II), 1 ) + II = II + PN + 1 + 10 CONTINUE +C +C Compute [ A2 A4 ] x S. +C + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', P, N, + $ ONE, S, LDS, DWORK(N+1), PN ) +C +C Triangularization (2 steps). +C +C Step 1: annihilate the matrix C x S (hence C1 x S1, if P <= N). +C Workspace: need (N+P)*N + 2*P. +C + ITAU = PL + JWORK = ITAU + P +C + CALL MB04LD( 'Lower', P, N, N, R, LDR, DWORK, PN, DWORK(P+1), PN, + $ K, LDK, DWORK(ITAU), DWORK(JWORK) ) + WRKOPT = MAX( WRKOPT, PN*N + 2*P ) +C +C Now, the workspace for C x S is no longer needed. +C Adjust the leading dimension of DWORK, to save space for the +C following computations, and make room for B x Q. +C + CALL DLACPY( 'Full', N, N, DWORK(P+1), PN, DWORK, N ) +C + DO 20 I = N*( N - 1 ) + 1, 1, -N + CALL DCOPY( N, DWORK(I), 1, DWORK(I+N*M), 1 ) + 20 CONTINUE +C +C Storing B x Q in the (1,1) block of DWORK. +C Workspace: need N*(M+N). +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + IF ( .NOT.LMULTB ) + $ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', N, M, + $ ONE, Q, LDQ, DWORK, N ) +C +C Step 2: LQ triangularization of the matrix [ B x Q A x S ], where +C A x S was modified at Step 1. +C Workspace: need N*(N+M+2); +C prefer N*(N+M+1)+(P+1)*NB, where NB is the optimal +C block size for DGELQF (called in MB04JD). +C + ITAU = N*( M + N ) + 1 + JWORK = ITAU + N +C + CALL MB04JD( N, M+N, MAX( N-P-1, 0 ), 0, DWORK, N, DWORK, N, + $ DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Output S and K (if needed) and set the optimal workspace +C dimension (and the reciprocal of the condition number estimate). +C + CALL DLACPY( 'Lower', N, N, DWORK, N, S, LDS ) +C + IF ( LJOBK ) THEN +C +C Compute K. +C Workspace: need 3*P. +C + CALL MB02OD( 'Right', 'Lower', 'No transpose', 'Non-unit', + $ '1-norm', N, P, ONE, R, LDR, K, LDK, RCOND, TOL, + $ IWORK, DWORK, INFO ) + IF ( INFO.EQ.0 ) THEN + WRKOPT = MAX( WRKOPT, 3*P ) + DWORK(2) = RCOND + END IF + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of FB01RD *** + END diff --git a/mex/sources/libslicot/FB01SD.f b/mex/sources/libslicot/FB01SD.f new file mode 100644 index 000000000..41783fc2e --- /dev/null +++ b/mex/sources/libslicot/FB01SD.f @@ -0,0 +1,597 @@ + SUBROUTINE FB01SD( JOBX, MULTAB, MULTRC, N, M, P, SINV, LDSINV, + $ AINV, LDAINV, B, LDB, RINV, LDRINV, C, LDC, + $ QINV, LDQINV, X, RINVY, Z, E, TOL, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate a combined measurement and time update of one +C iteration of the time-varying Kalman filter. This update is given +C for the square root information filter, using dense matrices. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBX CHARACTER*1 +C Indicates whether X is to be computed as follows: +C i+1 +C = 'X': X is computed and stored in array X; +C i+1 +C = 'N': X is not required. +C i+1 +C +C MULTAB CHARACTER*1 -1 +C Indicates how matrices A and B are to be passed to +C i i +C the routine as follows: -1 +C = 'P': Array AINV must contain the matrix A and the +C -1 i +C array B must contain the product A B ; +C i i +C = 'N': Arrays AINV and B must contain the matrices +C as described below. +C +C MULTRC CHARACTER*1 -1/2 +C Indicates how matrices R and C are to be passed to +C i+1 i+1 +C the routine as follows: +C = 'P': Array RINV is not used and the array C must +C -1/2 +C contain the product R C ; +C i+1 i+1 +C = 'N': Arrays RINV and C must contain the matrices +C as described below. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e., the order of the +C -1 -1 +C matrices S and A . N >= 0. +C i i +C +C M (input) INTEGER +C The actual input dimension, i.e., the order of the matrix +C -1/2 +C Q . M >= 0. +C i +C +C P (input) INTEGER +C The actual output dimension, i.e., the order of the matrix +C -1/2 +C R . P >= 0. +C i+1 +C +C SINV (input/output) DOUBLE PRECISION array, dimension +C (LDSINV,N) +C On entry, the leading N-by-N upper triangular part of this +C -1 +C array must contain S , the inverse of the square root +C i +C (right Cholesky factor) of the state covariance matrix +C P (hence the information square root) at instant i. +C i|i +C On exit, the leading N-by-N upper triangular part of this +C -1 +C array contains S , the inverse of the square root (right +C i+1 +C Cholesky factor) of the state covariance matrix P +C i+1|i+1 +C (hence the information square root) at instant i+1. +C The strict lower triangular part of this array is not +C referenced. +C +C LDSINV INTEGER +C The leading dimension of array SINV. LDSINV >= MAX(1,N). +C +C AINV (input) DOUBLE PRECISION array, dimension (LDAINV,N) +C -1 +C The leading N-by-N part of this array must contain A , +C i +C the inverse of the state transition matrix of the discrete +C system at instant i. +C +C LDAINV INTEGER +C The leading dimension of array AINV. LDAINV >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain B , +C -1 i +C the input weight matrix (or the product A B if +C i i +C MULTAB = 'P') of the discrete system at instant i. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C RINV (input) DOUBLE PRECISION array, dimension (LDRINV,*) +C If MULTRC = 'N', then the leading P-by-P upper triangular +C -1/2 +C part of this array must contain R , the inverse of the +C i+1 +C covariance square root (right Cholesky factor) of the +C output (measurement) noise (hence the information square +C root) at instant i+1. +C The strict lower triangular part of this array is not +C referenced. +C Otherwise, RINV is not referenced and can be supplied as a +C dummy array (i.e., set parameter LDRINV = 1 and declare +C this array to be RINV(1,1) in the calling program). +C +C LDRINV INTEGER +C The leading dimension of array RINV. +C LDRINV >= MAX(1,P) if MULTRC = 'N'; +C LDRINV >= 1 if MULTRC = 'P'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain C , +C -1/2 i+1 +C the output weight matrix (or the product R C if +C i+1 i+1 +C MULTRC = 'P') of the discrete system at instant i+1. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C QINV (input/output) DOUBLE PRECISION array, dimension +C (LDQINV,M) +C On entry, the leading M-by-M upper triangular part of this +C -1/2 +C array must contain Q , the inverse of the covariance +C i +C square root (right Cholesky factor) of the input (process) +C noise (hence the information square root) at instant i. +C On exit, the leading M-by-M upper triangular part of this +C -1/2 +C array contains (QINOV ) , the inverse of the covariance +C i +C square root (right Cholesky factor) of the process noise +C innovation (hence the information square root) at +C instant i. +C The strict lower triangular part of this array is not +C referenced. +C +C LDQINV INTEGER +C The leading dimension of array QINV. LDQINV >= MAX(1,M). +C +C X (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain X , the estimated +C i +C filtered state at instant i. +C On exit, if JOBX = 'X', and INFO = 0, then this array +C contains X , the estimated filtered state at +C i+1 +C instant i+1. +C On exit, if JOBX = 'N', or JOBX = 'X' and INFO = 1, then +C -1 +C this array contains S X . +C i+1 i+1 +C +C RINVY (input) DOUBLE PRECISION array, dimension (P) +C -1/2 +C This array must contain R Y , the product of the +C i+1 i+1 +C -1/2 +C upper triangular matrix R and the measured output +C i+1 +C vector Y at instant i+1. +C i+1 +C +C Z (input) DOUBLE PRECISION array, dimension (M) +C This array must contain Z , the mean value of the state +C i +C process noise at instant i. +C +C E (output) DOUBLE PRECISION array, dimension (P) +C This array contains E , the estimated error at instant +C i+1 +C i+1. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If JOBX = 'X', then TOL is used to test for near +C -1 +C singularity of the matrix S . If the user sets +C i+1 +C TOL > 0, then the given value of TOL is used as a +C lower bound for the reciprocal condition number of that +C matrix; a matrix whose estimated condition number is less +C than 1/TOL is considered to be nonsingular. If the user +C sets TOL <= 0, then an implicitly computed, default +C tolerance, defined by TOLDEF = N*N*EPS, is used instead, +C where EPS is the machine precision (see LAPACK Library +C routine DLAMCH). +C Otherwise, TOL is not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C where LIWORK = N if JOBX = 'X', +C and LIWORK = 1 otherwise. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. If INFO = 0 and JOBX = 'X', DWORK(2) returns +C an estimate of the reciprocal of the condition number +C -1 +C (in the 1-norm) of S . +C i+1 +C +C LDWORK The length of the array DWORK. +C LDWORK >= MAX(1,N*(N+2*M)+3*M,(N+P)*(N+1)+2*N), +C if JOBX = 'N'; +C LDWORK >= MAX(2,N*(N+2*M)+3*M,(N+P)*(N+1)+2*N,3*N), +C if JOBX = 'X'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; -1 +C = 1: if JOBX = 'X' and the matrix S is singular, +C i+1 -1 +C i.e., the condition number estimate of S (in the +C i+1 +C -1 -1/2 +C 1-norm) exceeds 1/TOL. The matrices S , Q +C i+1 i +C and E have been computed. +C +C METHOD +C +C The routine performs one recursion of the square root information +C filter algorithm, summarized as follows: +C +C | -1/2 -1/2 | | -1/2 | +C | Q 0 Q Z | | (QINOV ) * * | +C | i i i | | i | +C | | | | +C | -1 -1 -1 -1 -1 | | -1 -1 | +C T | S A B S A S X | = | 0 S S X | +C | i i i i i i i | | i+1 i+1 i+1| +C | | | | +C | -1/2 -1/2 | | | +C | 0 R C R Y | | 0 0 E | +C | i+1 i+1 i+1 i+1| | i+1 | +C +C (Pre-array) (Post-array) +C +C where T is an orthogonal transformation triangularizing the +C -1/2 +C pre-array, (QINOV ) is the inverse of the covariance square +C i +C root (right Cholesky factor) of the process noise innovation +C (hence the information square root) at instant i, and E is the +C i+1 +C estimated error at instant i+1. +C +C The inverse of the corresponding state covariance matrix P +C i+1|i+1 +C (hence the information matrix I) is then factorized as +C +C -1 -1 -1 +C I = P = (S )' S +C i+1|i+1 i+1|i+1 i+1 i+1 +C +C and one combined time and measurement update for the state is +C given by X . +C i+1 +C +C The triangularization is done entirely via Householder +C transformations exploiting the zero pattern of the pre-array. +C +C REFERENCES +C +C [1] Anderson, B.D.O. and Moore, J.B. +C Optimal Filtering. +C Prentice Hall, Englewood Cliffs, New Jersey, 1979. +C +C [2] Verhaegen, M.H.G. and Van Dooren, P. +C Numerical Aspects of Different Kalman Filter Implementations. +C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. +C +C [3] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. +C Algorithm 675: FORTRAN Subroutines for Computing the Square +C Root Covariance Filter and Square Root Information Filter in +C Dense or Hessenberg Forms. +C ACM Trans. Math. Software, 15, pp. 243-256, 1989. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately +C +C 3 2 2 2 +C (7/6)N + N x (7/2 x M + P) + N x (1/2 x P + M ) +C +C operations and is backward stable (see [2]). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine FB01GD by M. Vanbegin, +C P. Van Dooren, and M.H.G. Verhaegen. +C +C REVISIONS +C +C February 20, 1998, November 20, 2003, February 14, 2004. +C +C KEYWORDS +C +C Kalman filtering, optimal filtering, orthogonal transformation, +C recursive estimation, square-root filtering, square-root +C information filtering. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBX, MULTAB, MULTRC + INTEGER INFO, LDAINV, LDB, LDC, LDQINV, LDRINV, LDSINV, + $ LDWORK, M, N, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION AINV(LDAINV,*), B(LDB,*), C(LDC,*), DWORK(*), + $ E(*), QINV(LDQINV,*), RINV(LDRINV,*), RINVY(*), + $ SINV(LDSINV,*), X(*), Z(*) +C .. Local Scalars .. + LOGICAL LJOBX, LMULTA, LMULTR + INTEGER I, I12, I13, I21, I23, IJ, ITAU, JWORK, LDW, M1, + $ N1, NP, WRKOPT + DOUBLE PRECISION RCOND +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL DDOT, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEQRF, DLACPY, DORMQR, + $ DTRMM, DTRMV, MB02OD, MB04KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + NP = N + P + N1 = MAX( 1, N ) + M1 = MAX( 1, M ) + INFO = 0 + LJOBX = LSAME( JOBX, 'X' ) + LMULTA = LSAME( MULTAB, 'P' ) + LMULTR = LSAME( MULTRC, 'P' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LMULTA .AND. .NOT.LSAME( MULTAB, 'N' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LMULTR .AND. .NOT.LSAME( MULTRC, 'N' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( LDSINV.LT.N1 ) THEN + INFO = -8 + ELSE IF( LDAINV.LT.N1 ) THEN + INFO = -10 + ELSE IF( LDB.LT.N1 ) THEN + INFO = -12 + ELSE IF( LDRINV.LT.1 .OR. ( .NOT.LMULTR .AND. LDRINV.LT.P ) ) THEN + INFO = -14 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( LDQINV.LT.M1 ) THEN + INFO = -18 + ELSE IF( ( LJOBX .AND. LDWORK.LT.MAX( 2, N*(N + 2*M) + 3*M, + $ NP*(N + 1) + 2*N, 3*N ) ) + $ .OR. + $ ( .NOT.LJOBX .AND. LDWORK.LT.MAX( 1, N*(N + 2*M) + 3*M, + $ NP*(N + 1) + 2*N ) ) ) THEN + INFO = -26 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'FB01SD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, P ).EQ.0 ) THEN + IF ( LJOBX ) THEN + DWORK(1) = TWO + DWORK(2) = ONE + ELSE + DWORK(1) = ONE + END IF + RETURN + END IF +C +C Construction of the needed part of the pre-array in DWORK. +C To save workspace, only the blocks (1,3), (2,1)-(2,3), (3,2), and +C (3,3) will be constructed when needed as shown below. +C +C Storing SINV x AINV and SINV x AINV x B in the (1,1) and (1,2) +C blocks of DWORK, respectively. +C The variables called Ixy define the starting positions where the +C (x,y) blocks of the pre-array are initially stored in DWORK. +C Workspace: need N*(N+M). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + LDW = N1 + I21 = N*N + 1 +C + CALL DLACPY( 'Full', N, N, AINV, LDAINV, DWORK, LDW ) + IF ( LMULTA ) THEN + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(I21), LDW ) + ELSE + CALL DGEMM( 'No transpose', 'No transpose', N, M, N, ONE, + $ DWORK, LDW, B, LDB, ZERO, DWORK(I21), LDW ) + END IF + CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, N+M, + $ ONE, SINV, LDSINV, DWORK, LDW ) +C +C Storing the process noise mean value in (1,3) block of DWORK. +C Workspace: need N*(N+M) + M. +C + I13 = N*( N + M ) + 1 +C + CALL DCOPY( M, Z, 1, DWORK(I13), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', M, QINV, LDQINV, + $ DWORK(I13), 1 ) +C +C Computing SINV x X in X. +C + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, SINV, LDSINV, + $ X, 1 ) +C +C Triangularization (2 steps). +C +C Step 1: annihilate the matrix SINV x AINV x B. +C Workspace: need N*(N+2*M) + 3*M. +C + I12 = I13 + M + ITAU = I12 + M*N + JWORK = ITAU + M +C + CALL MB04KD( 'Full', M, N, N, QINV, LDQINV, DWORK(I21), LDW, + $ DWORK, LDW, DWORK(I12), M1, DWORK(ITAU), + $ DWORK(JWORK) ) + WRKOPT = MAX( 1, N*( N + 2*M ) + 3*M ) +C + IF ( N.EQ.0 ) THEN + CALL DCOPY( P, RINVY, 1, E, 1 ) + IF ( LJOBX ) + $ DWORK(2) = ONE + DWORK(1) = WRKOPT + RETURN + END IF +C +C Apply the transformations to the last column of the pre-array. +C (Only the updated (2,3) block is now needed.) +C + IJ = I21 +C + DO 10 I = 1, M + CALL DAXPY( N, -DWORK(ITAU+I-1)*( DWORK(I13+I-1) + + $ DDOT( N, DWORK(IJ), 1, X, 1 ) ), + $ DWORK(IJ), 1, X, 1 ) + IJ = IJ + N + 10 CONTINUE +C +C Now, the workspace for SINV x AINV x B, as well as for the updated +C (1,2) block of the pre-array, are no longer needed. +C Move the computed (2,3) block of the pre-array in the (1,2) block +C position of DWORK, to save space for the following computations. +C Then, adjust the implicitly defined leading dimension of DWORK, +C to make space for storing the (3,2) and (3,3) blocks of the +C pre-array. +C Workspace: need (N+P)*(N+1). +C + CALL DCOPY( N, X, 1, DWORK(I21), 1 ) + LDW = MAX( 1, NP ) +C + DO 30 I = N + 1, 1, -1 + DO 20 IJ = N, 1, -1 + DWORK(NP*(I-1)+IJ) = DWORK(N*(I-1)+IJ) + 20 CONTINUE + 30 CONTINUE +C +C Copy of RINV x C in the (2,1) block of DWORK. +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(N+1), LDW ) + IF ( .NOT.LMULTR ) + $ CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', P, N, + $ ONE, RINV, LDRINV, DWORK(N+1), LDW ) +C +C Copy the inclusion measurement in the (2,2) block of DWORK. +C + I21 = NP*N + 1 + I23 = I21 + N + CALL DCOPY( P, RINVY, 1, DWORK(I23), 1 ) + WRKOPT = MAX( WRKOPT, NP*( N + 1 ) ) +C +C Step 2: QR factorization of the first block column of the matrix +C +C [ SINV x AINV SINV x X ] +C [ RINV x C RINV x Y ], +C +C where the first block row was modified at Step 1. +C Workspace: need (N+P)*(N+1) + 2*N; +C prefer (N+P)*(N+1) + N + N*NB. +C + ITAU = I21 + NP + JWORK = ITAU + N +C + CALL DGEQRF( NP, N, DWORK, LDW, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Apply the Householder transformations to the last column. +C Workspace: need (N+P)*(N+1) + 1; prefer (N+P)*(N+1) + NB. +C + CALL DORMQR( 'Left', 'Transpose', NP, 1, N, DWORK, LDW, + $ DWORK(ITAU), DWORK(I21), LDW, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Output SINV, X, and E and set the optimal workspace dimension +C (and the reciprocal of the condition number estimate). +C + CALL DLACPY( 'Upper', N, N, DWORK, LDW, SINV, LDSINV ) + CALL DCOPY( N, DWORK(I21), 1, X, 1 ) + CALL DCOPY( P, DWORK(I23), 1, E, 1 ) +C + IF ( LJOBX ) THEN +C +C Compute X. +C Workspace: need 3*N. +C + CALL MB02OD( 'Left', 'Upper', 'No transpose', 'Non-unit', + $ '1-norm', N, 1, ONE, SINV, LDSINV, X, N, RCOND, + $ TOL, IWORK, DWORK, INFO ) + IF ( INFO.EQ.0 ) THEN + WRKOPT = MAX( WRKOPT, 3*N ) + DWORK(2) = RCOND + END IF + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of FB01SD *** + END diff --git a/mex/sources/libslicot/FB01TD.f b/mex/sources/libslicot/FB01TD.f new file mode 100644 index 000000000..f248de0d9 --- /dev/null +++ b/mex/sources/libslicot/FB01TD.f @@ -0,0 +1,641 @@ + SUBROUTINE FB01TD( JOBX, MULTRC, N, M, P, SINV, LDSINV, AINV, + $ LDAINV, AINVB, LDAINB, RINV, LDRINV, C, LDC, + $ QINV, LDQINV, X, RINVY, Z, E, TOL, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate a combined measurement and time update of one +C iteration of the time-invariant Kalman filter. This update is +C given for the square root information filter, using the condensed +C controller Hessenberg form. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBX CHARACTER*1 +C Indicates whether X is to be computed as follows: +C i+1 +C = 'X': X is computed and stored in array X; +C i+1 +C = 'N': X is not required. +C i+1 +C +C MULTRC CHARACTER*1 -1/2 +C Indicates how matrices R and C are to be passed to +C i+1 i+1 +C the routine as follows: +C = 'P': Array RINV is not used and the array C must +C -1/2 +C contain the product R C ; +C i+1 i+1 +C = 'N': Arrays RINV and C must contain the matrices +C as described below. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e., the order of the +C -1 -1 +C matrices S and A . N >= 0. +C i +C +C M (input) INTEGER +C The actual input dimension, i.e., the order of the matrix +C -1/2 +C Q . M >= 0. +C i +C +C P (input) INTEGER +C The actual output dimension, i.e., the order of the matrix +C -1/2 +C R . P >= 0. +C i+1 +C +C SINV (input/output) DOUBLE PRECISION array, dimension +C (LDSINV,N) +C On entry, the leading N-by-N upper triangular part of this +C -1 +C array must contain S , the inverse of the square root +C i +C (right Cholesky factor) of the state covariance matrix +C P (hence the information square root) at instant i. +C i|i +C On exit, the leading N-by-N upper triangular part of this +C -1 +C array contains S , the inverse of the square root (right +C i+1 +C Cholesky factor) of the state covariance matrix P +C i+1|i+1 +C (hence the information square root) at instant i+1. +C The strict lower triangular part of this array is not +C referenced. +C +C LDSINV INTEGER +C The leading dimension of array SINV. LDSINV >= MAX(1,N). +C +C AINV (input) DOUBLE PRECISION array, dimension (LDAINV,N) +C -1 +C The leading N-by-N part of this array must contain A , +C the inverse of the state transition matrix of the discrete +C system in controller Hessenberg form (e.g., as produced by +C SLICOT Library Routine TB01MD). +C +C LDAINV INTEGER +C The leading dimension of array AINV. LDAINV >= MAX(1,N). +C +C AINVB (input) DOUBLE PRECISION array, dimension (LDAINB,M) +C -1 +C The leading N-by-M part of this array must contain A B, +C -1 +C the product of A and the input weight matrix B of the +C discrete system, in upper controller Hessenberg form +C (e.g., as produced by SLICOT Library Routine TB01MD). +C +C LDAINB INTEGER +C The leading dimension of array AINVB. LDAINB >= MAX(1,N). +C +C RINV (input) DOUBLE PRECISION array, dimension (LDRINV,*) +C If MULTRC = 'N', then the leading P-by-P upper triangular +C -1/2 +C part of this array must contain R , the inverse of the +C i+1 +C covariance square root (right Cholesky factor) of the +C output (measurement) noise (hence the information square +C root) at instant i+1. +C The strict lower triangular part of this array is not +C referenced. +C Otherwise, RINV is not referenced and can be supplied as a +C dummy array (i.e., set parameter LDRINV = 1 and declare +C this array to be RINV(1,1) in the calling program). +C +C LDRINV INTEGER +C The leading dimension of array RINV. +C LDRINV >= MAX(1,P) if MULTRC = 'N'; +C LDRINV >= 1 if MULTRC = 'P'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain C , +C -1/2 i+1 +C the output weight matrix (or the product R C if +C i+1 i+1 +C MULTRC = 'P') of the discrete system at instant i+1. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C QINV (input/output) DOUBLE PRECISION array, dimension +C (LDQINV,M) +C On entry, the leading M-by-M upper triangular part of this +C -1/2 +C array must contain Q , the inverse of the covariance +C i +C square root (right Cholesky factor) of the input (process) +C noise (hence the information square root) at instant i. +C On exit, the leading M-by-M upper triangular part of this +C -1/2 +C array contains (QINOV ) , the inverse of the covariance +C i +C square root (right Cholesky factor) of the process noise +C innovation (hence the information square root) at +C instant i. +C The strict lower triangular part of this array is not +C referenced. +C +C LDQINV INTEGER +C The leading dimension of array QINV. LDQINV >= MAX(1,M). +C +C X (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain X , the estimated +C i +C filtered state at instant i. +C On exit, if JOBX = 'X', and INFO = 0, then this array +C contains X , the estimated filtered state at +C i+1 +C instant i+1. +C On exit, if JOBX = 'N', or JOBX = 'X' and INFO = 1, then +C -1 +C this array contains S X . +C i+1 i+1 +C +C RINVY (input) DOUBLE PRECISION array, dimension (P) +C -1/2 +C This array must contain R Y , the product of the +C i+1 i+1 +C -1/2 +C upper triangular matrix R and the measured output +C i+1 +C vector Y at instant i+1. +C i+1 +C +C Z (input) DOUBLE PRECISION array, dimension (M) +C This array must contain Z , the mean value of the state +C i +C process noise at instant i. +C +C E (output) DOUBLE PRECISION array, dimension (P) +C This array contains E , the estimated error at instant +C i+1 +C i+1. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If JOBX = 'X', then TOL is used to test for near +C -1 +C singularity of the matrix S . If the user sets +C i+1 +C TOL > 0, then the given value of TOL is used as a +C lower bound for the reciprocal condition number of that +C matrix; a matrix whose estimated condition number is less +C than 1/TOL is considered to be nonsingular. If the user +C sets TOL <= 0, then an implicitly computed, default +C tolerance, defined by TOLDEF = N*N*EPS, is used instead, +C where EPS is the machine precision (see LAPACK Library +C routine DLAMCH). +C Otherwise, TOL is not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C where LIWORK = N if JOBX = 'X', +C and LIWORK = 1 otherwise. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. If INFO = 0 and JOBX = 'X', DWORK(2) returns +C an estimate of the reciprocal of the condition number +C -1 +C (in the 1-norm) of S . +C i+1 +C +C LDWORK The length of the array DWORK. +C LDWORK >= MAX(1,N*(N+2*M)+3*M,(N+P)*(N+1)+N+MAX(N-1,M+1)), +C if JOBX = 'N'; +C LDWORK >= MAX(2,N*(N+2*M)+3*M,(N+P)*(N+1)+N+MAX(N-1,M+1), +C 3*N), if JOBX = 'X'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; -1 +C = 1: if JOBX = 'X' and the matrix S is singular, +C i+1 -1 +C i.e., the condition number estimate of S (in the +C i+1 +C -1 -1/2 +C 1-norm) exceeds 1/TOL. The matrices S , Q +C i+1 i +C and E have been computed. +C +C METHOD +C +C The routine performs one recursion of the square root information +C filter algorithm, summarized as follows: +C +C | -1/2 -1/2 | | -1/2 | +C | Q 0 Q Z | | (QINOV ) * * | +C | i i i | | i | +C | | | | +C | -1/2 -1/2 | | -1 -1 | +C T | 0 R C R Y | = | 0 S S X | +C | i+1 i+1 i+1 i+1| | i+1 i+1 i+1| +C | | | | +C | -1 -1 -1 -1 -1 | | | +C | S A B S A S X | | 0 0 E | +C | i i i i | | i+1 | +C +C (Pre-array) (Post-array) +C +C where T is an orthogonal transformation triangularizing the +C -1/2 +C pre-array, (QINOV ) is the inverse of the covariance square +C i +C root (right Cholesky factor) of the process noise innovation +C -1 -1 +C (hence the information square root) at instant i and (A ,A B) is +C in upper controller Hessenberg form. +C +C An example of the pre-array is given below (where N = 6, M = 2, +C and P = 3): +C +C |x x | | x| +C | x | | x| +C _______________________ +C | | x x x x x x | x| +C | | x x x x x x | x| +C | | x x x x x x | x| +C _______________________ +C |x x | x x x x x x | x| +C | x | x x x x x x | x| +C | | x x x x x x | x| +C | | x x x x x | x| +C | | x x x x | x| +C | | x x x | x| +C +C The inverse of the corresponding state covariance matrix P +C i+1|i+1 +C (hence the information matrix I) is then factorized as +C +C -1 -1 -1 +C I = P = (S )' S +C i+1|i+1 i+1|i+1 i+1 i+1 +C +C and one combined time and measurement update for the state is +C given by X . +C i+1 +C +C The triangularization is done entirely via Householder +C transformations exploiting the zero pattern of the pre-array. +C +C REFERENCES +C +C [1] Anderson, B.D.O. and Moore, J.B. +C Optimal Filtering. +C Prentice Hall, Englewood Cliffs, New Jersey, 1979. +C +C [2] Van Dooren, P. and Verhaegen, M.H.G. +C Condensed Forms for Efficient Time-Invariant Kalman Filtering. +C SIAM J. Sci. Stat. Comp., 9. pp. 516-530, 1988. +C +C [3] Verhaegen, M.H.G. and Van Dooren, P. +C Numerical Aspects of Different Kalman Filter Implementations. +C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. +C +C [4] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. +C Algorithm 675: FORTRAN Subroutines for Computing the Square +C Root Covariance Filter and Square Root Information Filter in +C Dense or Hessenberg Forms. +C ACM Trans. Math. Software, 15, pp. 243-256, 1989. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately +C +C 3 2 2 3 +C (1/6)N + N x (3/2 x M + P) + 2 x N x M + 2/3 x M +C +C operations and is backward stable (see [3]). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine FB01HD by M. Vanbegin, +C P. Van Dooren, and M.H.G. Verhaegen. +C +C REVISIONS +C +C February 20, 1998, November 20, 2003, February 14, 2004. +C +C KEYWORDS +C +C Controller Hessenberg form, Kalman filtering, optimal filtering, +C orthogonal transformation, recursive estimation, square-root +C filtering, square-root information filtering. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBX, MULTRC + INTEGER INFO, LDAINB, LDAINV, LDC, LDQINV, LDRINV, + $ LDSINV, LDWORK, M, N, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION AINV(LDAINV,*), AINVB(LDAINB,*), C(LDC,*), + $ DWORK(*), E(*), QINV(LDQINV,*), RINV(LDRINV,*), + $ RINVY(*), SINV(LDSINV,*), X(*), Z(*) +C .. Local Scalars .. + LOGICAL LJOBX, LMULTR + INTEGER I, I12, I13, I23, I32, I33, II, IJ, ITAU, JWORK, + $ LDW, M1, MP1, N1, NM, NP, WRKOPT + DOUBLE PRECISION RCOND +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL DDOT, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DLACPY, DTRMM, DTRMV, MB02OD, + $ MB04ID, MB04KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + NP = N + P + NM = N + M + N1 = MAX( 1, N ) + M1 = MAX( 1, M ) + MP1 = M + 1 + INFO = 0 + LJOBX = LSAME( JOBX, 'X' ) + LMULTR = LSAME( MULTRC, 'P' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LMULTR .AND. .NOT.LSAME( MULTRC, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDSINV.LT.N1 ) THEN + INFO = -7 + ELSE IF( LDAINV.LT.N1 ) THEN + INFO = -9 + ELSE IF( LDAINB.LT.N1 ) THEN + INFO = -11 + ELSE IF( LDRINV.LT.1 .OR. ( .NOT.LMULTR .AND. LDRINV.LT.P ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDQINV.LT.M1 ) THEN + INFO = -17 + ELSE IF( ( LJOBX .AND. LDWORK.LT.MAX( 2, N*(NM + M) + 3*M, + $ NP*(N + 1) + N + + $ MAX( N - 1, MP1 ), 3*N ) ) + $ .OR. + $ ( .NOT.LJOBX .AND. LDWORK.LT.MAX( 1, N*(NM + M) + 3*M, + $ NP*(N + 1) + N + + $ MAX( N - 1, MP1 ) ) ) ) THEN + INFO = -25 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'FB01TD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, P ).EQ.0 ) THEN + IF ( LJOBX ) THEN + DWORK(1) = TWO + DWORK(2) = ONE + ELSE + DWORK(1) = ONE + END IF + RETURN + END IF +C +C Construction of the needed part of the pre-array in DWORK. +C To save workspace, only the blocks (1,3), (3,1)-(3,3), (2,2), and +C (2,3) will be constructed when needed as shown below. +C +C Storing SINV x AINVB and SINV x AINV in the (1,1) and (1,2) +C blocks of DWORK, respectively. The upper trapezoidal structure of +C [ AINVB AINV ] is fully exploited. Specifically, if M <= N, the +C following partition is used: +C +C [ S1 S2 ] [ B1 A1 A3 ] +C [ 0 S3 ] [ 0 A2 A4 ], +C +C where B1, A3, and S1 are M-by-M matrices, A1 and S2 are +C M-by-(N-M), A2 and S3 are (N-M)-by-(N-M), A4 is (N-M)-by-M, and +C B1, S1, A2, and S3 are upper triangular. The right hand side +C matrix above is stored in the workspace. If M > N, the partition +C is [ SINV ] [ B1 B2 A ], where B1 is N-by-N, B2 is N-by-(M-N), +C and B1 and SINV are upper triangular. +C The variables called Ixy define the starting positions where the +C (x,y) blocks of the pre-array are initially stored in DWORK. +C Workspace: need N*(M+N). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + LDW = N1 + I32 = N*M + 1 +C + CALL DLACPY( 'Upper', N, M, AINVB, LDAINB, DWORK, LDW ) + CALL DLACPY( 'Full', MIN( M, N ), N, AINV, LDAINV, DWORK(I32), + $ LDW ) + IF ( N.GT.M ) + $ CALL DLACPY( 'Upper', N-M, N, AINV(MP1,1), LDAINV, + $ DWORK(I32+M), LDW ) +C +C [ B1 A1 ] +C Compute SINV x [ 0 A2 ] or SINV x B1 as a product of upper +C triangular matrices. +C Workspace: need N*(M+N+1). +C + II = 1 + I13 = N*NM + 1 + WRKOPT = MAX( 1, N*NM + N ) +C + DO 10 I = 1, N + CALL DCOPY( I, DWORK(II), 1, DWORK(I13), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I, SINV, + $ LDSINV, DWORK(I13), 1 ) + CALL DCOPY( I, DWORK(I13), 1, DWORK(II), 1 ) + II = II + N + 10 CONTINUE +C +C [ A3 ] +C Compute SINV x [ A4 ] or SINV x [ B2 A ]. +C + CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, M, + $ ONE, SINV, LDSINV, DWORK(II), LDW ) +C +C Storing the process noise mean value in (1,3) block of DWORK. +C Workspace: need N*(M+N) + M. +C + CALL DCOPY( M, Z, 1, DWORK(I13), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', M, QINV, LDQINV, + $ DWORK(I13), 1 ) +C +C Computing SINV x X in X. +C + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, SINV, LDSINV, + $ X, 1 ) +C +C Triangularization (2 steps). +C +C Step 1: annihilate the matrix SINV x AINVB. +C Workspace: need N*(N+2*M) + 3*M. +C + I12 = I13 + M + ITAU = I12 + M*N + JWORK = ITAU + M +C + CALL MB04KD( 'Upper', M, N, N, QINV, LDQINV, DWORK, LDW, + $ DWORK(I32), LDW, DWORK(I12), M1, DWORK(ITAU), + $ DWORK(JWORK) ) + WRKOPT = MAX( WRKOPT, N*( NM + M ) + 3*M ) +C + IF ( N.EQ.0 ) THEN + CALL DCOPY( P, RINVY, 1, E, 1 ) + IF ( LJOBX ) + $ DWORK(2) = ONE + DWORK(1) = WRKOPT + RETURN + END IF +C +C Apply the transformations to the last column of the pre-array. +C (Only the updated (3,3) block is now needed.) +C + IJ = 1 +C + DO 20 I = 1, M + CALL DAXPY( MIN( I, N ), -DWORK(ITAU+I-1)*( DWORK(I13+I-1) + + $ DDOT( MIN( I, N ), DWORK(IJ), 1, X, 1 ) ), + $ DWORK(IJ), 1, X, 1 ) + IJ = IJ + N + 20 CONTINUE +C +C Now, the workspace for SINV x AINVB, as well as for the updated +C (1,2) block of the pre-array, are no longer needed. +C Move the computed (3,2) and (3,3) blocks of the pre-array in the +C (1,1) and (1,2) block positions of DWORK, to save space for the +C following computations. +C Then, adjust the implicitly defined leading dimension of DWORK, +C to make space for storing the (2,2) and (2,3) blocks of the +C pre-array. +C Workspace: need (P+N)*(N+1). +C + CALL DLACPY( 'Full', MIN( M, N ), N, DWORK(I32), LDW, DWORK, LDW ) + IF ( N.GT.M ) + $ CALL DLACPY( 'Upper', N-M, N, DWORK(I32+M), LDW, DWORK(MP1), + $ LDW ) + LDW = MAX( 1, NP ) +C + DO 40 I = N, 1, -1 + DO 30 IJ = MIN( N, I+M ), 1, -1 + DWORK(NP*(I-1)+P+IJ) = DWORK(N*(I-1)+IJ) + 30 CONTINUE + 40 CONTINUE +C +C Copy of RINV x C in the (1,1) block of DWORK. +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDW ) + IF ( .NOT.LMULTR ) + $ CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', P, N, + $ ONE, RINV, LDRINV, DWORK, LDW ) +C +C Copy the inclusion measurement in the (1,2) block and the updated +C X in the (2,2) block of DWORK. +C + I23 = NP*N + 1 + I33 = I23 + P + CALL DCOPY( P, RINVY, 1, DWORK(I23), 1 ) + CALL DCOPY( N, X, 1, DWORK(I33), 1 ) + WRKOPT = MAX( WRKOPT, NP*( N + 1 ) ) +C +C Step 2: QR factorization of the first block column of the matrix +C +C [ RINV x C RINV x Y ], +C [ SINV x AINV SINV x X ] +C +C where the second block row was modified at Step 1. +C Workspace: need (P+N)*(N+1) + N + MAX(N-1,M+1); +C prefer (P+N)*(N+1) + N + (M+1)*NB, where NB is the +C optimal block size for DGEQRF called in MB04ID. +C + ITAU = I23 + NP + JWORK = ITAU + N +C + CALL MB04ID( NP, N, MAX( N-MP1, 0 ), 1, DWORK, LDW, DWORK(I23), + $ LDW, DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Output SINV, X, and E and set the optimal workspace dimension +C (and the reciprocal of the condition number estimate). +C + CALL DLACPY( 'Upper', N, N, DWORK, LDW, SINV, LDSINV ) + CALL DCOPY( N, DWORK(I23), 1, X, 1 ) + IF( P.GT.0 ) + $ CALL DCOPY( P, DWORK(I23+N), 1, E, 1 ) +C + IF ( LJOBX ) THEN +C +C Compute X. +C Workspace: need 3*N. +C + CALL MB02OD( 'Left', 'Upper', 'No transpose', 'Non-unit', + $ '1-norm', N, 1, ONE, SINV, LDSINV, X, N, RCOND, + $ TOL, IWORK, DWORK, INFO ) + IF ( INFO.EQ.0 ) THEN + WRKOPT = MAX( WRKOPT, 3*N ) + DWORK(2) = RCOND + END IF + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of FB01TD*** + END diff --git a/mex/sources/libslicot/FB01VD.f b/mex/sources/libslicot/FB01VD.f new file mode 100644 index 000000000..eabf21748 --- /dev/null +++ b/mex/sources/libslicot/FB01VD.f @@ -0,0 +1,391 @@ + SUBROUTINE FB01VD( N, M, L, P, LDP, A, LDA, B, LDB, C, LDC, Q, + $ LDQ, R, LDR, K, LDK, TOL, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute one recursion of the conventional Kalman filter +C equations. This is one update of the Riccati difference equation +C and the Kalman filter gain. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e., the order of the +C matrices P and A . N >= 0. +C i|i-1 i +C +C M (input) INTEGER +C The actual input dimension, i.e., the order of the matrix +C Q . M >= 0. +C i +C +C L (input) INTEGER +C The actual output dimension, i.e., the order of the matrix +C R . L >= 0. +C i +C +C P (input/output) DOUBLE PRECISION array, dimension (LDP,N) +C On entry, the leading N-by-N part of this array must +C contain P , the state covariance matrix at instant +C i|i-1 +C (i-1). The upper triangular part only is needed. +C On exit, if INFO = 0, the leading N-by-N part of this +C array contains P , the state covariance matrix at +C i+1|i +C instant i. The strictly lower triangular part is not set. +C Otherwise, the leading N-by-N part of this array contains +C P , its input value. +C i|i-1 +C +C LDP INTEGER +C The leading dimension of array P. LDP >= MAX(1,N). +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain A , +C i +C the state transition matrix of the discrete system at +C instant i. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain B , +C i +C the input weight matrix of the discrete system at +C instant i. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading L-by-N part of this array must contain C , +C i +C the output weight matrix of the discrete system at +C instant i. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,L). +C +C Q (input) DOUBLE PRECISION array, dimension (LDQ,M) +C The leading M-by-M part of this array must contain Q , +C i +C the input (process) noise covariance matrix at instant i. +C The diagonal elements of this array are modified by the +C routine, but are restored on exit. +C +C LDQ INTEGER +C The leading dimension of array Q. LDQ >= MAX(1,M). +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,L) +C On entry, the leading L-by-L part of this array must +C contain R , the output (measurement) noise covariance +C i +C matrix at instant i. +C On exit, if INFO = 0, or INFO = L+1, the leading L-by-L +C 1/2 +C upper triangular part of this array contains (RINOV ) , +C i +C the square root (left Cholesky factor) of the covariance +C matrix of the innovations at instant i. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,L). +C +C K (output) DOUBLE PRECISION array, dimension (LDK,L) +C If INFO = 0, the leading N-by-L part of this array +C contains K , the Kalman filter gain matrix at instant i. +C i +C If INFO > 0, the leading N-by-L part of this array +C contains the matrix product P C'. +C i|i-1 i +C +C LDK INTEGER +C The leading dimension of array K. LDK >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the matrix RINOV . If the user sets TOL > 0, then the +C i +C given value of TOL is used as a lower bound for the +C reciprocal condition number of that matrix; a matrix whose +C estimated condition number is less than 1/TOL is +C considered to be nonsingular. If the user sets TOL <= 0, +C then an implicitly computed, default tolerance, defined by +C TOLDEF = L*L*EPS, is used instead, where EPS is the +C machine precision (see LAPACK Library routine DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (L) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, or INFO = L+1, DWORK(1) returns an +C estimate of the reciprocal of the condition number (in the +C 1-norm) of the matrix RINOV . +C i +C +C LDWORK The length of the array DWORK. +C LDWORK >= MAX(1,L*N+3*L,N*N,N*M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -k, the k-th argument had an illegal +C value; +C = k: if INFO = k, 1 <= k <= L, the leading minor of order +C k of the matrix RINOV is not positive-definite, and +C i +C its Cholesky factorization could not be completed; +C = L+1: the matrix RINOV is singular, i.e., the condition +C i +C number estimate of RINOV (in the 1-norm) exceeds +C i +C 1/TOL. +C +C METHOD +C +C The conventional Kalman filter gain used at the i-th recursion +C step is of the form +C +C -1 +C K = P C' RINOV , +C i i|i-1 i i +C +C where RINOV = C P C' + R , and the state covariance matrix +C i i i|i-1 i i +C +C P is updated by the discrete-time difference Riccati equation +C i|i-1 +C +C P = A (P - K C P ) A' + B Q B'. +C i+1|i i i|i-1 i i i|i-1 i i i i +C +C Using these two updates, the combined time and measurement update +C of the state X is given by +C i|i-1 +C +C X = A X + A K (Y - C X ), +C i+1|i i i|i-1 i i i i i|i-1 +C +C where Y is the new observation at step i. +C i +C +C REFERENCES +C +C [1] Anderson, B.D.O. and Moore, J.B. +C Optimal Filtering, +C Prentice Hall, Englewood Cliffs, New Jersey, 1979. +C +C [2] Verhaegen, M.H.G. and Van Dooren, P. +C Numerical Aspects of Different Kalman Filter Implementations. +C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, 1986. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately +C +C 3 2 +C 3/2 x N + N x (3 x L + M/2) +C +C operations. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine FB01JD by M.H.G. Verhaegen, +C M. Vanbegin, and P. Van Dooren. +C +C REVISIONS +C +C February 20, 1998, November 20, 2003, April 20, 2004. +C +C KEYWORDS +C +C Kalman filtering, optimal filtering, recursive estimation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, L, LDA, LDB, LDC, LDK, LDP, LDQ, LDR, + $ LDWORK, M, N + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ K(LDK,*), P(LDP,*), Q(LDQ,*), R(LDR,*) +C .. Local Scalars .. + INTEGER J, JWORK, LDW, N1 + DOUBLE PRECISION RCOND, RNORM, TOLDEF +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DLACPY, DLASET, DPOCON, + $ DPOTRF, DSCAL, DTRMM, DTRSM, MB01RD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + N1 = MAX( 1, N ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 ) THEN + INFO = -3 + ELSE IF( LDP.LT.N1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.N1 ) THEN + INFO = -7 + ELSE IF( LDB.LT.N1 ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, L ) ) THEN + INFO = -11 + ELSE IF( LDQ.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF( LDR.LT.MAX( 1, L ) ) THEN + INFO = -15 + ELSE IF( LDK.LT.N1 ) THEN + INFO = -17 + ELSE IF( LDWORK.LT.MAX( 1, L*N + 3*L, N*N, N*M ) ) THEN + INFO = -21 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'FB01VD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, L ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Efficiently compute RINOV = CPC' + R in R and put CP in DWORK and +C PC' in K. (The content of DWORK on exit from MB01RD is used.) +C Workspace: need L*N. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code.) +C + CALL MB01RD( 'Upper', 'No transpose', L, N, ONE, ONE, R, LDR, C, + $ LDC, P, LDP, DWORK, LDWORK, INFO ) + LDW = MAX( 1, L ) +C + DO 10 J = 1, L + CALL DCOPY( N, DWORK(J), LDW, K(1,J), 1 ) + 10 CONTINUE +C + CALL DLACPY( 'Full', L, N, C, LDC, DWORK, LDW ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', L, N, ONE, + $ P, LDP, DWORK, LDW ) + CALL DSCAL( N, TWO, P, LDP+1 ) +C + DO 20 J = 1, L + CALL DAXPY( N, ONE, K(1,J), 1, DWORK(J), LDW ) + CALL DCOPY( N, DWORK(J), LDW, K(1,J), 1 ) + 20 CONTINUE +C +C Calculate the Cholesky decomposition U'U of the innovation +C covariance matrix RINOV, and its reciprocal condition number. +C Workspace: need L*N + 3*L. +C + JWORK = L*N + 1 + RNORM = DLANSY( '1-norm', 'Upper', L, R, LDR, DWORK(JWORK) ) +C + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) + $ TOLDEF = DBLE( L*L )*DLAMCH( 'Epsilon' ) + CALL DPOTRF( 'Upper', L, R, LDR, INFO ) + IF ( INFO.NE.0 ) + $ RETURN +C + CALL DPOCON( 'Upper', L, R, LDR, RNORM, RCOND, DWORK(JWORK), + $ IWORK, INFO ) +C + IF ( RCOND.LT.TOLDEF ) THEN +C +C Error return: RINOV is numerically singular. +C + INFO = L+1 + DWORK(1) = RCOND + RETURN + END IF +C + IF ( L.GT.1 ) + $ CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, R(2,1),LDR ) +C -1 +C Calculate the Kalman filter gain matrix K = PC'RINOV . +C Workspace: need L*N. +C + CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L, + $ ONE, R, LDR, K, LDK ) + CALL DTRSM( 'Right', 'Upper', 'Transpose', 'Non-unit', N, L, + $ ONE, R, LDR, K, LDK ) +C +C First part of the Riccati equation update: compute A(P-KCP)A'. +C The upper triangular part of the symmetric matrix P-KCP is formed. +C Workspace: need max(L*N,N*N). +C + JWORK = 1 +C + DO 30 J = 1, N + CALL DGEMV( 'No transpose', J, L, -ONE, K, LDK, DWORK(JWORK), + $ 1, ONE, P(1,J), 1 ) + JWORK = JWORK + L + 30 CONTINUE +C + CALL MB01RD( 'Upper', 'No transpose', N, N, ZERO, ONE, P, LDP, A, + $ LDA, P, LDP, DWORK, LDWORK, INFO ) +C +C Second part of the Riccati equation update: add BQB'. +C Workspace: need N*M. +C + CALL MB01RD( 'Upper', 'No transpose', N, M, ONE, ONE, P, LDP, B, + $ LDB, Q, LDQ, DWORK, LDWORK, INFO ) + CALL DSCAL( M, TWO, Q, LDQ+1 ) +C +C Set the reciprocal of the condition number estimate. +C + DWORK(1) = RCOND +C + RETURN +C *** Last line of FB01VD *** + END diff --git a/mex/sources/libslicot/FD01AD.f b/mex/sources/libslicot/FD01AD.f new file mode 100644 index 000000000..79fef1b65 --- /dev/null +++ b/mex/sources/libslicot/FD01AD.f @@ -0,0 +1,367 @@ + SUBROUTINE FD01AD( JP, L, LAMBDA, XIN, YIN, EFOR, XF, EPSBCK, + $ CTETA, STETA, YQ, EPOS, EOUT, SALPH, IWARN, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the least-squares filtering problem recursively in time. +C Each subroutine call implements one time update of the solution. +C The algorithm uses a fast QR-decomposition based approach. +C +C ARGUMENTS +C +C Mode Parameters +C +C JP CHARACTER*1 +C Indicates whether the user wishes to apply both prediction +C and filtering parts, as follows: +C = 'B': Both prediction and filtering parts are to be +C applied; +C = 'P': Only the prediction section is to be applied. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The length of the impulse response of the equivalent +C transversal filter model. L >= 1. +C +C LAMBDA (input) DOUBLE PRECISION +C Square root of the forgetting factor. +C For tracking capabilities and exponentially stable error +C propagation, LAMBDA < 1.0 (strict inequality) should +C be used. 0.0 < LAMBDA <= 1.0. +C +C XIN (input) DOUBLE PRECISION +C The input sample at instant n. +C (The situation just before and just after the call of +C the routine are denoted by instant (n-1) and instant n, +C respectively.) +C +C YIN (input) DOUBLE PRECISION +C If JP = 'B', then YIN must contain the reference sample +C at instant n. +C Otherwise, YIN is not referenced. +C +C EFOR (input/output) DOUBLE PRECISION +C On entry, this parameter must contain the square root of +C exponentially weighted forward prediction error energy +C at instant (n-1). EFOR >= 0.0. +C On exit, this parameter contains the square root of the +C exponentially weighted forward prediction error energy +C at instant n. +C +C XF (input/output) DOUBLE PRECISION array, dimension (L) +C On entry, this array must contain the transformed forward +C prediction variables at instant (n-1). +C On exit, this array contains the transformed forward +C prediction variables at instant n. +C +C EPSBCK (input/output) DOUBLE PRECISION array, dimension (L+1) +C On entry, the leading L elements of this array must +C contain the normalized a posteriori backward prediction +C error residuals of orders zero through L-1, respectively, +C at instant (n-1), and EPSBCK(L+1) must contain the +C square-root of the so-called "conversion factor" at +C instant (n-1). +C On exit, this array contains the normalized a posteriori +C backward prediction error residuals, plus the square root +C of the conversion factor at instant n. +C +C CTETA (input/output) DOUBLE PRECISION array, dimension (L) +C On entry, this array must contain the cosines of the +C rotation angles used in time updates, at instant (n-1). +C On exit, this array contains the cosines of the rotation +C angles at instant n. +C +C STETA (input/output) DOUBLE PRECISION array, dimension (L) +C On entry, this array must contain the sines of the +C rotation angles used in time updates, at instant (n-1). +C On exit, this array contains the sines of the rotation +C angles at instant n. +C +C YQ (input/output) DOUBLE PRECISION array, dimension (L) +C On entry, if JP = 'B', then this array must contain the +C orthogonally transformed reference vector at instant +C (n-1). These elements are also the tap multipliers of an +C equivalent normalized lattice least-squares filter. +C Otherwise, YQ is not referenced and can be supplied as +C a dummy array (i.e., declare this array to be YQ(1) in +C the calling program). +C On exit, if JP = 'B', then this array contains the +C orthogonally transformed reference vector at instant n. +C +C EPOS (output) DOUBLE PRECISION +C The a posteriori forward prediction error residual. +C +C EOUT (output) DOUBLE PRECISION +C If JP = 'B', then EOUT contains the a posteriori output +C error residual from the least-squares filter at instant n. +C +C SALPH (output) DOUBLE PRECISION array, dimension (L) +C The element SALPH(i), i=1,...,L, contains the opposite of +C the i-(th) reflection coefficient for the least-squares +C normalized lattice predictor (whose value is -SALPH(i)). +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: an element to be annihilated by a rotation is less +C than the machine precision (see LAPACK Library +C routine DLAMCH). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The output error EOUT at instant n, denoted by EOUT(n), is the +C reference sample minus a linear combination of L successive input +C samples: +C +C L-1 +C EOUT(n) = YIN(n) - SUM h_i * XIN(n-i), +C i=0 +C +C where YIN(n) and XIN(n) are the scalar samples at instant n. +C A least-squares filter uses those h_0,...,h_{L-1} which minimize +C an exponentially weighted sum of successive output errors squared: +C +C n +C SUM [LAMBDA**(2(n-k)) * EOUT(k)**2]. +C k=1 +C +C Each subroutine call performs a time update of the least-squares +C filter using a fast least-squares algorithm derived from a +C QR decomposition, as described in references [1] and [2] (the +C notation from [2] is followed in the naming of the arrays). +C The algorithm does not compute the parameters h_0,...,h_{L-1} from +C the above formula, but instead furnishes the parameters of an +C equivalent normalized least-squares lattice filter, which are +C available from the arrays SALPH (reflection coefficients) and YQ +C (tap multipliers), as well as the exponentially weighted input +C signal energy +C +C n L +C SUM [LAMBDA**(2(n-k)) * XIN(k)**2] = EFOR**2 + SUM XF(i)**2. +C k=1 i=1 +C +C For more details on reflection coefficients and tap multipliers, +C references [2] and [4] are recommended. +C +C REFERENCES +C +C [1] Proudler, I. K., McWhirter, J. G., and Shepherd, T. J. +C Fast QRD based algorithms for least-squares linear +C prediction. +C Proceedings IMA Conf. Mathematics in Signal Processing +C Warwick, UK, December 1988. +C +C [2] Regalia, P. A., and Bellanger, M. G. +C On the duality between QR methods and lattice methods in +C least-squares adaptive filtering. +C IEEE Trans. Signal Processing, SP-39, pp. 879-891, +C April 1991. +C +C [3] Regalia, P. A. +C Numerical stability properties of a QR-based fast +C least-squares algorithm. +C IEEE Trans. Signal Processing, SP-41, June 1993. +C +C [4] Lev-Ari, H., Kailath, T., and Cioffi, J. +C Least-squares adaptive lattice and transversal filters: +C A unified geometric theory. +C IEEE Trans. Information Theory, IT-30, pp. 222-236, +C March 1984. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O(L) operations for each subroutine call. +C It is backward consistent for all input sequences XIN, and +C backward stable for persistently exciting input sequences, +C assuming LAMBDA < 1.0 (see [3]). +C If the condition of the signal is very poor (IWARN = 1), then the +C results are not guaranteed to be reliable. +C +C FURTHER COMMENTS +C +C 1. For tracking capabilities and exponentially stable error +C propagation, LAMBDA < 1.0 should be used. LAMBDA is typically +C chosen slightly less than 1.0 so that "past" data are +C exponentially forgotten. +C 2. Prior to the first subroutine call, the variables must be +C initialized. The following initial values are recommended: +C +C XF(i) = 0.0, i=1,...,L +C EPSBCK(i) = 0.0 i=1,...,L +C EPSBCK(L+1) = 1.0 +C CTETA(i) = 1.0 i=1,...,L +C STETA(i) = 0.0 i=1,...,L +C YQ(i) = 0.0 i=1,...,L +C +C EFOR = 0.0 (exact start) +C EFOR = "small positive constant" (soft start). +C +C Soft starts are numerically more reliable, but result in a +C biased least-squares solution during the first few iterations. +C This bias decays exponentially fast provided LAMBDA < 1.0. +C If sigma is the standard deviation of the input sequence +C XIN, then initializing EFOR = sigma*1.0E-02 usually works +C well. +C +C CONTRIBUTOR +C +C P. A. Regalia (October 1994). +C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Kalman filtering, least-squares estimator, optimal filtering, +C orthogonal transformation, recursive estimation, QR decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER JP + INTEGER INFO, IWARN, L + DOUBLE PRECISION EFOR, EOUT, EPOS, LAMBDA, XIN, YIN +C .. Array Arguments .. + DOUBLE PRECISION CTETA(*), EPSBCK(*), SALPH(*), STETA(*), XF(*), + $ YQ(*) +C .. Local Scalars .. + LOGICAL BOTH + INTEGER I + DOUBLE PRECISION CTEMP, EPS, FNODE, NORM, TEMP, XFI, YQI +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 + EXTERNAL DLAMCH, DLAPY2, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DLARTG, XERBLA +C .. Intrinsic Functions + INTRINSIC ABS, SQRT +C .. Executable statements .. +C +C Test the input scalar arguments. +C + BOTH = LSAME( JP, 'B' ) + IWARN = 0 + INFO = 0 +C + IF( .NOT.BOTH .AND. .NOT.LSAME( JP, 'P' ) ) THEN + INFO = -1 + ELSE IF( L.LT.1 ) THEN + INFO = -2 + ELSE IF( ( LAMBDA.LE.ZERO ) .OR. ( LAMBDA.GT.ONE ) ) THEN + INFO = -3 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'FD01AD', -INFO ) + RETURN + END IF +C +C Computation of the machine precision EPS. +C + EPS = DLAMCH( 'Epsilon' ) +C +C Forward prediction rotations. +C + FNODE = XIN +C + DO 10 I = 1, L + XFI = XF(I) * LAMBDA + XF(I) = STETA(I) * FNODE + CTETA(I) * XFI + FNODE = CTETA(I) * FNODE - STETA(I) * XFI + 10 CONTINUE +C + EPOS = FNODE * EPSBCK(L+1) +C +C Update the square root of the prediction energy. +C + EFOR = EFOR * LAMBDA + TEMP = DLAPY2( FNODE, EFOR ) + IF ( TEMP.LT.EPS ) THEN + FNODE = ZERO + IWARN = 1 + ELSE + FNODE = FNODE * EPSBCK(L+1)/TEMP + END IF + EFOR = TEMP +C +C Calculate the reflection coefficients and the backward prediction +C errors. +C + DO 20 I = L, 1, -1 + IF ( ABS( XF(I) ).LT.EPS ) + $ IWARN = 1 + CALL DLARTG( TEMP, XF(I), CTEMP, SALPH(I), NORM ) + EPSBCK(I+1) = CTEMP * EPSBCK(I) - SALPH(I) * FNODE + FNODE = CTEMP * FNODE + SALPH(I) * EPSBCK(I) + TEMP = NORM + 20 CONTINUE +C + EPSBCK(1) = FNODE +C +C Update to new rotation angles. +C + NORM = DNRM2( L, EPSBCK, 1 ) + TEMP = SQRT( ( ONE + NORM )*( ONE - NORM ) ) + EPSBCK(L+1) = TEMP +C + DO 30 I = L, 1, -1 + IF ( ABS( EPSBCK(I) ).LT.EPS ) + $ IWARN = 1 + CALL DLARTG( TEMP, EPSBCK(I), CTETA(I), STETA(I), NORM ) + TEMP = NORM + 30 CONTINUE +C +C Joint process section. +C + IF ( BOTH) THEN + FNODE = YIN +C + DO 40 I = 1, L + YQI = YQ(I) * LAMBDA + YQ(I) = STETA(I) * FNODE + CTETA(I) * YQI + FNODE = CTETA(I) * FNODE - STETA(I) * YQI + 40 CONTINUE +C + EOUT = FNODE * EPSBCK(L+1) + END IF +C + RETURN +C *** Last line of FD01AD *** + END diff --git a/mex/sources/libslicot/IB01AD.f b/mex/sources/libslicot/IB01AD.f new file mode 100644 index 000000000..301cdd529 --- /dev/null +++ b/mex/sources/libslicot/IB01AD.f @@ -0,0 +1,686 @@ + SUBROUTINE IB01AD( METH, ALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, + $ L, NSMP, U, LDU, Y, LDY, N, R, LDR, SV, RCOND, + $ TOL, IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To preprocess the input-output data for estimating the matrices +C of a linear time-invariant dynamical system and to find an +C estimate of the system order. The input-output data can, +C optionally, be processed sequentially. +C +C ARGUMENTS +C +C Mode Parameters +C +C METH CHARACTER*1 +C Specifies the subspace identification method to be used, +C as follows: +C = 'M': MOESP algorithm with past inputs and outputs; +C = 'N': N4SID algorithm. +C +C ALG CHARACTER*1 +C Specifies the algorithm for computing the triangular +C factor R, as follows: +C = 'C': Cholesky algorithm applied to the correlation +C matrix of the input-output data; +C = 'F': Fast QR algorithm; +C = 'Q': QR algorithm applied to the concatenated block +C Hankel matrices. +C +C JOBD CHARACTER*1 +C Specifies whether or not the matrices B and D should later +C be computed using the MOESP approach, as follows: +C = 'M': the matrices B and D should later be computed +C using the MOESP approach; +C = 'N': the matrices B and D should not be computed using +C the MOESP approach. +C This parameter is not relevant for METH = 'N'. +C +C BATCH CHARACTER*1 +C Specifies whether or not sequential data processing is to +C be used, and, for sequential processing, whether or not +C the current data block is the first block, an intermediate +C block, or the last block, as follows: +C = 'F': the first block in sequential data processing; +C = 'I': an intermediate block in sequential data +C processing; +C = 'L': the last block in sequential data processing; +C = 'O': one block only (non-sequential data processing). +C NOTE that when 100 cycles of sequential data processing +C are completed for BATCH = 'I', a warning is +C issued, to prevent for an infinite loop. +C +C CONCT CHARACTER*1 +C Specifies whether or not the successive data blocks in +C sequential data processing belong to a single experiment, +C as follows: +C = 'C': the current data block is a continuation of the +C previous data block and/or it will be continued +C by the next data block; +C = 'N': there is no connection between the current data +C block and the previous and/or the next ones. +C This parameter is not used if BATCH = 'O'. +C +C CTRL CHARACTER*1 +C Specifies whether or not the user's confirmation of the +C system order estimate is desired, as follows: +C = 'C': user's confirmation; +C = 'N': no confirmation. +C If CTRL = 'C', a reverse communication routine, IB01OY, +C is indirectly called (by SLICOT Library routine IB01OD), +C and, after inspecting the singular values and system order +C estimate, n, the user may accept n or set a new value. +C IB01OY is not called if CTRL = 'N'. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the input and output +C block Hankel matrices to be processed. NOBR > 0. +C (In the MOESP theory, NOBR should be larger than n, +C the estimated dimension of state vector.) +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C When M = 0, no system inputs are processed. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C NSMP (input) INTEGER +C The number of rows of matrices U and Y (number of +C samples, t). (When sequential data processing is used, +C NSMP is the number of samples of the current data +C block.) +C NSMP >= 2*(M+L+1)*NOBR - 1, for non-sequential +C processing; +C NSMP >= 2*NOBR, for sequential processing. +C The total number of samples when calling the routine with +C BATCH = 'L' should be at least 2*(M+L+1)*NOBR - 1. +C The NSMP argument may vary from a cycle to another in +C sequential data processing, but NOBR, M, and L should +C be kept constant. For efficiency, it is advisable to use +C NSMP as large as possible. +C +C U (input) DOUBLE PRECISION array, dimension (LDU,M) +C The leading NSMP-by-M part of this array must contain the +C t-by-m input-data sequence matrix U, +C U = [u_1 u_2 ... u_m]. Column j of U contains the +C NSMP values of the j-th input component for consecutive +C time increments. +C If M = 0, this array is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= NSMP, if M > 0; +C LDU >= 1, if M = 0. +C +C Y (input) DOUBLE PRECISION array, dimension (LDY,L) +C The leading NSMP-by-L part of this array must contain the +C t-by-l output-data sequence matrix Y, +C Y = [y_1 y_2 ... y_l]. Column j of Y contains the +C NSMP values of the j-th output component for consecutive +C time increments. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= NSMP. +C +C N (output) INTEGER +C The estimated order of the system. +C If CTRL = 'C', the estimated order has been reset to a +C value specified by the user. +C +C R (output or input/output) DOUBLE PRECISION array, dimension +C ( LDR,2*(M+L)*NOBR ) +C On exit, if ALG = 'C' and BATCH = 'F' or 'I', the leading +C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this +C array contains the current upper triangular part of the +C correlation matrix in sequential data processing. +C If ALG = 'F' and BATCH = 'F' or 'I', the array R is not +C referenced. +C On exit, if INFO = 0, ALG = 'Q', and BATCH = 'F' or 'I', +C the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular +C part of this array contains the current upper triangular +C factor R from the QR factorization of the concatenated +C block Hankel matrices. Denote R_ij, i,j = 1:4, the +C ij submatrix of R, partitioned by M*NOBR, M*NOBR, +C L*NOBR, and L*NOBR rows and columns. +C On exit, if INFO = 0 and BATCH = 'L' or 'O', the leading +C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of +C this array contains the matrix S, the processed upper +C triangular factor R from the QR factorization of the +C concatenated block Hankel matrices, as required by other +C subroutines. Specifically, let S_ij, i,j = 1:4, be the +C ij submatrix of S, partitioned by M*NOBR, L*NOBR, +C M*NOBR, and L*NOBR rows and columns. The submatrix +C S_22 contains the matrix of left singular vectors needed +C subsequently. Useful information is stored in S_11 and +C in the block-column S_14 : S_44. For METH = 'M' and +C JOBD = 'M', the upper triangular part of S_31 contains +C the upper triangular factor in the QR factorization of the +C matrix R_1c = [ R_12' R_22' R_11' ]', and S_12 +C contains the corresponding leading part of the transformed +C matrix R_2c = [ R_13' R_23' R_14' ]'. For METH = 'N', +C the subarray S_41 : S_43 contains the transpose of the +C matrix contained in S_14 : S_34. +C The details of the contents of R need not be known if this +C routine is followed by SLICOT Library routine IB01BD. +C On entry, if ALG = 'C', or ALG = 'Q', and BATCH = 'I' or +C 'L', the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper +C triangular part of this array must contain the upper +C triangular matrix R computed at the previous call of this +C routine in sequential data processing. The array R need +C not be set on entry if ALG = 'F' or if BATCH = 'F' or 'O'. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= MAX( 2*(M+L)*NOBR, 3*M*NOBR ), +C for METH = 'M' and JOBD = 'M'; +C LDR >= 2*(M+L)*NOBR, for METH = 'M' and JOBD = 'N' or +C for METH = 'N'. +C +C SV (output) DOUBLE PRECISION array, dimension ( L*NOBR ) +C The singular values used to estimate the system order. +C +C Tolerances +C +C RCOND DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets RCOND > 0, the given value +C of RCOND is used as a lower bound for the reciprocal +C condition number; an m-by-n matrix whose estimated +C condition number is less than 1/RCOND is considered to +C be of full rank. If the user sets RCOND <= 0, then an +C implicitly computed, default tolerance, defined by +C RCONDEF = m*n*EPS, is used instead, where EPS is the +C relative machine precision (see LAPACK Library routine +C DLAMCH). +C This parameter is not used for METH = 'M'. +C +C TOL DOUBLE PRECISION +C Absolute tolerance used for determining an estimate of +C the system order. If TOL >= 0, the estimate is +C indicated by the index of the last singular value greater +C than or equal to TOL. (Singular values less than TOL +C are considered as zero.) When TOL = 0, an internally +C computed default value, TOL = NOBR*EPS*SV(1), is used, +C where SV(1) is the maximal singular value, and EPS is +C the relative machine precision (see LAPACK Library routine +C DLAMCH). When TOL < 0, the estimate is indicated by the +C index of the singular value that has the largest +C logarithmic gap to its successor. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK >= (M+L)*NOBR, if METH = 'N'; +C LIWORK >= M+L, if METH = 'M' and ALG = 'F'; +C LIWORK >= 0, if METH = 'M' and ALG = 'C' or 'Q'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and, for METH = 'N', and BATCH = 'L' or +C 'O', DWORK(2) and DWORK(3) contain the reciprocal +C condition numbers of the triangular factors of the +C matrices U_f and r_1 [6]. +C On exit, if INFO = -23, DWORK(1) returns the minimum +C value of LDWORK. +C Let +C k = 0, if CONCT = 'N' and ALG = 'C' or 'Q'; +C k = 2*NOBR-1, if CONCT = 'C' and ALG = 'C' or 'Q'; +C k = 2*NOBR*(M+L+1), if CONCT = 'N' and ALG = 'F'; +C k = 2*NOBR*(M+L+2), if CONCT = 'C' and ALG = 'F'. +C The first (M+L)*k elements of DWORK should be preserved +C during successive calls of the routine with BATCH = 'F' +C or 'I', till the final call with BATCH = 'L'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= (4*NOBR-2)*(M+L), if ALG = 'C', BATCH = 'F' or +C 'I' and CONCT = 'C'; +C LDWORK >= 1, if ALG = 'C', BATCH = 'F' or 'I' and +C CONCT = 'N'; +C LDWORK >= max((4*NOBR-2)*(M+L), 5*L*NOBR), if METH = 'M', +C ALG = 'C', BATCH = 'L' and CONCT = 'C'; +C LDWORK >= max((2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR), +C if METH = 'M', JOBD = 'M', ALG = 'C', +C BATCH = 'O', or +C (BATCH = 'L' and CONCT = 'N'); +C LDWORK >= 5*L*NOBR, if METH = 'M', JOBD = 'N', ALG = 'C', +C BATCH = 'O', or +C (BATCH = 'L' and CONCT = 'N'); +C LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N', ALG = 'C', and +C BATCH = 'L' or 'O'; +C LDWORK >= (M+L)*2*NOBR*(M+L+3), if ALG = 'F', +C BATCH <> 'O' and CONCT = 'C'; +C LDWORK >= (M+L)*2*NOBR*(M+L+1), if ALG = 'F', +C BATCH = 'F', 'I' and CONCT = 'N'; +C LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, if ALG = 'F', +C BATCH = 'L' and CONCT = 'N', or +C BATCH = 'O'; +C LDWORK >= 4*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F', and +C LDR >= NS = NSMP - 2*NOBR + 1; +C LDWORK >= max(4*(M+L)*NOBR, 5*L*NOBR), if METH = 'M', +C ALG = 'Q', BATCH = 'O', and LDR >= NS; +C LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N', ALG = 'Q', +C BATCH = 'O', and LDR >= NS; +C LDWORK >= 6*(M+L)*NOBR, if ALG = 'Q', (BATCH = 'F' or 'O', +C and LDR < NS), or (BATCH = 'I' or +C 'L' and CONCT = 'N'); +C LDWORK >= 4*(NOBR+1)*(M+L)*NOBR, if ALG = 'Q', BATCH = 'I' +C or 'L' and CONCT = 'C'. +C The workspace used for ALG = 'Q' is +C LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR, +C where LDRWRK = LDWORK/(2*(M+L)*NOBR) - 2; recommended +C value LDRWRK = NS, assuming a large enough cache size. +C For good performance, LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: the number of 100 cycles in sequential data +C processing has been exhausted without signaling +C that the last block of data was get; the cycle +C counter was reinitialized; +C = 2: a fast algorithm was requested (ALG = 'C' or 'F'), +C but it failed, and the QR algorithm was then used +C (non-sequential data processing); +C = 3: all singular values were exactly zero, hence N = 0 +C (both input and output were identically zero); +C = 4: the least squares problems with coefficient matrix +C U_f, used for computing the weighted oblique +C projection (for METH = 'N'), have a rank-deficient +C coefficient matrix; +C = 5: the least squares problem with coefficient matrix +C r_1 [6], used for computing the weighted oblique +C projection (for METH = 'N'), has a rank-deficient +C coefficient matrix. +C NOTE: the values 4 and 5 of IWARN have no significance +C for the identification problem. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: a fast algorithm was requested (ALG = 'C', or 'F') +C in sequential data processing, but it failed; the +C routine can be repeatedly called again using the +C standard QR algorithm; +C = 2: the singular value decomposition (SVD) algorithm did +C not converge. +C +C METHOD +C +C The procedure consists in three main steps, the first step being +C performed by one of the three algorithms included. +C +C 1.a) For non-sequential data processing using QR algorithm, a +C t x 2(m+l)s matrix H is constructed, where +C +C H = [ Uf' Up' Y' ], for METH = 'M', +C s+1,2s,t 1,s,t 1,2s,t +C +C H = [ U' Y' ], for METH = 'N', +C 1,2s,t 1,2s,t +C +C and Up , Uf , U , and Y are block Hankel +C 1,s,t s+1,2s,t 1,2s,t 1,2s,t +C matrices defined in terms of the input and output data [3]. +C A QR factorization is used to compress the data. +C The fast QR algorithm uses a QR factorization which exploits +C the block-Hankel structure. Actually, the Cholesky factor of H'*H +C is computed. +C +C 1.b) For sequential data processing using QR algorithm, the QR +C decomposition is done sequentially, by updating the upper +C triangular factor R. This is also performed internally if the +C workspace is not large enough to accommodate an entire batch. +C +C 1.c) For non-sequential or sequential data processing using +C Cholesky algorithm, the correlation matrix of input-output data is +C computed (sequentially, if requested), taking advantage of the +C block Hankel structure [7]. Then, the Cholesky factor of the +C correlation matrix is found, if possible. +C +C 2) A singular value decomposition (SVD) of a certain matrix is +C then computed, which reveals the order n of the system as the +C number of "non-zero" singular values. For the MOESP approach, this +C matrix is [ R_24' R_34' ]' := R(ms+1:(2m+l)s,(2m+l)s+1:2(m+l)s), +C where R is the upper triangular factor R constructed by SLICOT +C Library routine IB01MD. For the N4SID approach, a weighted +C oblique projection is computed from the upper triangular factor R +C and its SVD is then found. +C +C 3) The singular values are compared to the given, or default TOL, +C and the estimated order n is returned, possibly after user's +C confirmation. +C +C REFERENCES +C +C [1] Verhaegen M., and Dewilde, P. +C Subspace Model Identification. Part 1: The output-error +C state-space model identification class of algorithms. +C Int. J. Control, 56, pp. 1187-1210, 1992. +C +C [2] Verhaegen M. +C Subspace Model Identification. Part 3: Analysis of the +C ordinary output-error state-space model identification +C algorithm. +C Int. J. Control, 58, pp. 555-586, 1993. +C +C [3] Verhaegen M. +C Identification of the deterministic part of MIMO state space +C models given in innovations form from input-output data. +C Automatica, Vol.30, No.1, pp.61-74, 1994. +C +C [4] Van Overschee, P., and De Moor, B. +C N4SID: Subspace Algorithms for the Identification of +C Combined Deterministic-Stochastic Systems. +C Automatica, Vol.30, No.1, pp. 75-93, 1994. +C +C [5] Peternell, K., Scherrer, W. and Deistler, M. +C Statistical Analysis of Novel Subspace Identification Methods. +C Signal Processing, 52, pp. 161-177, 1996. +C +C [6] Sima, V. +C Subspace-based Algorithms for Multivariable System +C Identification. +C Studies in Informatics and Control, 5, pp. 335-344, 1996. +C +C [7] Sima, V. +C Cholesky or QR Factorization for Data Compression in +C Subspace-based Identification ? +C Proceedings of the Second NICONET Workshop on ``Numerical +C Control Software: SLICOT, a Useful Tool in Industry'', +C December 3, 1999, INRIA Rocquencourt, France, pp. 75-80, 1999. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable (when QR algorithm is +C used), reliable and efficient. The fast Cholesky or QR algorithms +C are more efficient, but the accuracy could diminish by forming the +C correlation matrix. +C The most time-consuming computational step is step 1: +C 2 +C The QR algorithm needs 0(t(2(m+l)s) ) floating point operations. +C 2 3 +C The Cholesky algorithm needs 0(2t(m+l) s)+0((2(m+l)s) ) floating +C point operations. +C 2 3 2 +C The fast QR algorithm needs 0(2t(m+l) s)+0(4(m+l) s ) floating +C point operations. +C 3 +C Step 2 of the algorithm requires 0(((m+l)s) ) floating point +C operations. +C +C FURTHER COMMENTS +C +C For ALG = 'Q', BATCH = 'O' and LDR < NS, or BATCH <> 'O', the +C calculations could be rather inefficient if only minimal workspace +C (see argument LDWORK) is provided. It is advisable to provide as +C much workspace as possible. Almost optimal efficiency can be +C obtained for LDWORK = (NS+2)*(2*(M+L)*NOBR), assuming that the +C cache size is large enough to accommodate R, U, Y, and DWORK. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Universiteit Leuven, Feb. 2000. +C +C REVISIONS +C +C August 2000, March 2005. +C +C KEYWORDS +C +C Cholesky decomposition, Hankel matrix, identification methods, +C multivariable systems, QR decomposition, singular value +C decomposition. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + DOUBLE PRECISION RCOND, TOL + INTEGER INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, N, + $ NOBR, NSMP + CHARACTER ALG, BATCH, CONCT, CTRL, JOBD, METH +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION DWORK(*), R(LDR, *), SV(*), U(LDU, *), + $ Y(LDY, *) +C .. Local Scalars .. + INTEGER IWARNL, LMNOBR, LNOBR, MAXWRK, MINWRK, MNOBR, + $ NOBR21, NR, NS, NSMPSM + LOGICAL CHALG, CONNEC, CONTRL, FIRST, FQRALG, INTERM, + $ JOBDM, LAST, MOESP, N4SID, ONEBCH, QRALG +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL IB01MD, IB01ND, IB01OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Save Statement .. +C MAXWRK is used to store the optimal workspace. +C NSMPSM is used to sum up the NSMP values for BATCH <> 'O'. + SAVE MAXWRK, NSMPSM +C .. +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MOESP = LSAME( METH, 'M' ) + N4SID = LSAME( METH, 'N' ) + FQRALG = LSAME( ALG, 'F' ) + QRALG = LSAME( ALG, 'Q' ) + CHALG = LSAME( ALG, 'C' ) + JOBDM = LSAME( JOBD, 'M' ) + ONEBCH = LSAME( BATCH, 'O' ) + FIRST = LSAME( BATCH, 'F' ) .OR. ONEBCH + INTERM = LSAME( BATCH, 'I' ) + LAST = LSAME( BATCH, 'L' ) .OR. ONEBCH + CONTRL = LSAME( CTRL, 'C' ) +C + IF( .NOT.ONEBCH ) THEN + CONNEC = LSAME( CONCT, 'C' ) + ELSE + CONNEC = .FALSE. + END IF +C + MNOBR = M*NOBR + LNOBR = L*NOBR + LMNOBR = LNOBR + MNOBR + NR = LMNOBR + LMNOBR + NOBR21 = 2*NOBR - 1 + IWARN = 0 + INFO = 0 + IF( FIRST ) THEN + MAXWRK = 1 + NSMPSM = 0 + END IF + NSMPSM = NSMPSM + NSMP +C +C Check the scalar input parameters. +C + IF( .NOT.( MOESP .OR. N4SID ) ) THEN + INFO = -1 + ELSE IF( .NOT.( FQRALG .OR. QRALG .OR. CHALG ) ) THEN + INFO = -2 + ELSE IF( MOESP .AND. .NOT.( JOBDM .OR. LSAME( JOBD, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT.( FIRST .OR. INTERM .OR. LAST ) ) THEN + INFO = -4 + ELSE IF( .NOT. ONEBCH ) THEN + IF( .NOT.( CONNEC .OR. LSAME( CONCT, 'N' ) ) ) + $ INFO = -5 + END IF + IF( INFO.EQ.0 ) THEN + IF( .NOT.( CONTRL .OR. LSAME( CTRL, 'N' ) ) ) THEN + INFO = -6 + ELSE IF( NOBR.LE.0 ) THEN + INFO = -7 + ELSE IF( M.LT.0 ) THEN + INFO = -8 + ELSE IF( L.LE.0 ) THEN + INFO = -9 + ELSE IF( NSMP.LT.2*NOBR .OR. + $ ( LAST .AND. NSMPSM.LT.NR+NOBR21 ) ) THEN + INFO = -10 + ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN + INFO = -12 + ELSE IF( LDY.LT.NSMP ) THEN + INFO = -14 + ELSE IF( LDR.LT.NR .OR. ( MOESP .AND. JOBDM .AND. + $ LDR.LT.3*MNOBR ) ) THEN + INFO = -17 + ELSE +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe +C the minimal amount of workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + NS = NSMP - NOBR21 + IF ( CHALG ) THEN + IF ( .NOT.LAST ) THEN + IF ( CONNEC ) THEN + MINWRK = 2*( NR - M - L ) + ELSE + MINWRK = 1 + END IF + ELSE IF ( MOESP ) THEN + IF ( CONNEC .AND. .NOT.ONEBCH ) THEN + MINWRK = MAX( 2*( NR - M - L ), 5*LNOBR ) + ELSE + MINWRK = 5*LNOBR + IF ( JOBDM ) + $ MINWRK = MAX( 2*MNOBR - NOBR, LMNOBR, MINWRK ) + END IF + ELSE + MINWRK = 5*LMNOBR + 1 + END IF + ELSE IF ( FQRALG ) THEN + IF ( .NOT.ONEBCH .AND. CONNEC ) THEN + MINWRK = NR*( M + L + 3 ) + ELSE IF ( FIRST .OR. INTERM ) THEN + MINWRK = NR*( M + L + 1 ) + ELSE + MINWRK = 2*NR*( M + L + 1 ) + NR + END IF + ELSE + MINWRK = 2*NR + IF ( ONEBCH .AND. LDR.GE.NS ) THEN + IF ( MOESP ) THEN + MINWRK = MAX( MINWRK, 5*LNOBR ) + ELSE + MINWRK = 5*LMNOBR + 1 + END IF + END IF + IF ( FIRST ) THEN + IF ( LDR.LT.NS ) THEN + MINWRK = MINWRK + NR + END IF + ELSE + IF ( CONNEC ) THEN + MINWRK = MINWRK*( NOBR + 1 ) + ELSE + MINWRK = MINWRK + NR + END IF + END IF + END IF +C + MAXWRK = MINWRK +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -23 + DWORK( 1 ) = MINWRK + END IF + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01AD', -INFO ) + RETURN + END IF +C +C Compress the input-output data. +C Workspace: need c*(M+L)*NOBR, where c is a constant depending +C on the algorithm and the options used +C (see SLICOT Library routine IB01MD); +C prefer larger. +C + CALL IB01MD( METH, ALG, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU, Y, + $ LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN, INFO ) +C + IF ( INFO.EQ.1 ) THEN +C +C Error return: A fast algorithm was requested (ALG = 'C', 'F') +C in sequential data processing, but it failed. +C + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK( 1 ) ) ) +C + IF ( .NOT.LAST ) THEN +C +C Return to get new data. +C + RETURN + END IF +C +C Find the singular value decomposition (SVD) giving the system +C order, and perform related preliminary calculations needed for +C computing the system matrices. +C Workspace: need max( (2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR ), +C if METH = 'M'; +C 5*(M+L)*NOBR+1, if METH = 'N'; +C prefer larger. +C + CALL IB01ND( METH, JOBD, NOBR, M, L, R, LDR, SV, RCOND, IWORK, + $ DWORK, LDWORK, IWARNL, INFO ) + IWARN = MAX( IWARN, IWARNL ) +C + IF ( INFO.EQ.2 ) THEN +C +C Error return: the singular value decomposition (SVD) algorithm +C did not converge. +C + RETURN + END IF +C +C Estimate the system order. +C + CALL IB01OD( CTRL, NOBR, L, SV, N, TOL, IWARNL, INFO ) + IWARN = MAX( IWARN, IWARNL ) +C +C Return optimal workspace in DWORK(1). +C + DWORK( 1 ) = MAX( MAXWRK, INT( DWORK( 1 ) ) ) + RETURN +C +C *** Last line of IB01AD *** + END diff --git a/mex/sources/libslicot/IB01BD.f b/mex/sources/libslicot/IB01BD.f new file mode 100644 index 000000000..011e02d34 --- /dev/null +++ b/mex/sources/libslicot/IB01BD.f @@ -0,0 +1,791 @@ + SUBROUTINE IB01BD( METH, JOB, JOBCK, NOBR, N, M, L, NSMPL, R, + $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, + $ RY, LDRY, S, LDS, K, LDK, TOL, IWORK, DWORK, + $ LDWORK, BWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the system matrices A, C, B, and D, the noise +C covariance matrices Q, Ry, and S, and the Kalman gain matrix K +C of a linear time-invariant state space model, using the +C processed triangular factor R of the concatenated block Hankel +C matrices, provided by SLICOT Library routine IB01AD. +C +C ARGUMENTS +C +C Mode Parameters +C +C METH CHARACTER*1 +C Specifies the subspace identification method to be used, +C as follows: +C = 'M': MOESP algorithm with past inputs and outputs; +C = 'N': N4SID algorithm; +C = 'C': combined method: MOESP algorithm for finding the +C matrices A and C, and N4SID algorithm for +C finding the matrices B and D. +C +C JOB CHARACTER*1 +C Specifies which matrices should be computed, as follows: +C = 'A': compute all system matrices, A, B, C, and D; +C = 'C': compute the matrices A and C only; +C = 'B': compute the matrix B only; +C = 'D': compute the matrices B and D only. +C +C JOBCK CHARACTER*1 +C Specifies whether or not the covariance matrices and the +C Kalman gain matrix are to be computed, as follows: +C = 'C': the covariance matrices only should be computed; +C = 'K': the covariance matrices and the Kalman gain +C matrix should be computed; +C = 'N': the covariance matrices and the Kalman gain matrix +C should not be computed. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the input and output +C Hankel matrices processed by other routines. NOBR > 1. +C +C N (input) INTEGER +C The order of the system. NOBR > N > 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C NSMPL (input) INTEGER +C If JOBCK = 'C' or 'K', the total number of samples used +C for calculating the covariance matrices. +C NSMPL >= 2*(M+L)*NOBR. +C This parameter is not meaningful if JOBCK = 'N'. +C +C R (input/workspace) DOUBLE PRECISION array, dimension +C ( LDR,2*(M+L)*NOBR ) +C On entry, the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR part +C of this array must contain the relevant data for the MOESP +C or N4SID algorithms, as constructed by SLICOT Library +C routine IB01AD. Let R_ij, i,j = 1:4, be the +C ij submatrix of R (denoted S in IB01AD), partitioned +C by M*NOBR, L*NOBR, M*NOBR, and L*NOBR rows and +C columns. The submatrix R_22 contains the matrix of left +C singular vectors used. Also needed, for METH = 'N' or +C JOBCK <> 'N', are the submatrices R_11, R_14 : R_44, +C and, for METH = 'M' or 'C' and JOB <> 'C', the +C submatrices R_31 and R_12, containing the processed +C matrices R_1c and R_2c, respectively, as returned by +C SLICOT Library routine IB01AD. +C Moreover, if METH = 'N' and JOB = 'A' or 'C', the +C block-row R_41 : R_43 must contain the transpose of the +C block-column R_14 : R_34 as returned by SLICOT Library +C routine IB01AD. +C The remaining part of R is used as workspace. +C On exit, part of this array is overwritten. Specifically, +C if METH = 'M', R_22 and R_31 are overwritten if +C JOB = 'B' or 'D', and R_12, R_22, R_14 : R_34, +C and possibly R_11 are overwritten if JOBCK <> 'N'; +C if METH = 'N', all needed submatrices are overwritten. +C The details of the contents of R need not be known if +C this routine is called once just after calling the SLICOT +C Library routine IB01AD. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= 2*(M+L)*NOBR. +C +C A (input or output) DOUBLE PRECISION array, dimension +C (LDA,N) +C On entry, if METH = 'N' or 'C' and JOB = 'B' or 'D', +C the leading N-by-N part of this array must contain the +C system state matrix. +C If METH = 'M' or (METH = 'N' or 'C' and JOB = 'A' +C or 'C'), this array need not be set on input. +C On exit, if JOB = 'A' or 'C' and INFO = 0, the +C leading N-by-N part of this array contains the system +C state matrix. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= N, if JOB = 'A' or 'C', or METH = 'N' or 'C' +C and JOB = 'B' or 'D'; +C LDA >= 1, otherwise. +C +C C (input or output) DOUBLE PRECISION array, dimension +C (LDC,N) +C On entry, if METH = 'N' or 'C' and JOB = 'B' or 'D', +C the leading L-by-N part of this array must contain the +C system output matrix. +C If METH = 'M' or (METH = 'N' or 'C' and JOB = 'A' +C or 'C'), this array need not be set on input. +C On exit, if JOB = 'A' or 'C' and INFO = 0, or +C INFO = 3 (or INFO >= 0, for METH = 'M'), the leading +C L-by-N part of this array contains the system output +C matrix. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= L, if JOB = 'A' or 'C', or METH = 'N' or 'C' +C and JOB = 'B' or 'D'; +C LDC >= 1, otherwise. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C If M > 0, JOB = 'A', 'B', or 'D' and INFO = 0, the +C leading N-by-M part of this array contains the system +C input matrix. If M = 0 or JOB = 'C', this array is +C not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= N, if M > 0 and JOB = 'A', 'B', or 'D'; +C LDB >= 1, if M = 0 or JOB = 'C'. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M) +C If M > 0, JOB = 'A' or 'D' and INFO = 0, the leading +C L-by-M part of this array contains the system input-output +C matrix. If M = 0 or JOB = 'C' or 'B', this array is +C not referenced. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= L, if M > 0 and JOB = 'A' or 'D'; +C LDD >= 1, if M = 0 or JOB = 'C' or 'B'. +C +C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) +C If JOBCK = 'C' or 'K', the leading N-by-N part of this +C array contains the positive semidefinite state covariance +C matrix. If JOBCK = 'K', this matrix has been used as +C state weighting matrix for computing the Kalman gain. +C This parameter is not referenced if JOBCK = 'N'. +C +C LDQ INTEGER +C The leading dimension of the array Q. +C LDQ >= N, if JOBCK = 'C' or 'K'; +C LDQ >= 1, if JOBCK = 'N'. +C +C RY (output) DOUBLE PRECISION array, dimension (LDRY,L) +C If JOBCK = 'C' or 'K', the leading L-by-L part of this +C array contains the positive (semi)definite output +C covariance matrix. If JOBCK = 'K', this matrix has been +C used as output weighting matrix for computing the Kalman +C gain. +C This parameter is not referenced if JOBCK = 'N'. +C +C LDRY INTEGER +C The leading dimension of the array RY. +C LDRY >= L, if JOBCK = 'C' or 'K'; +C LDRY >= 1, if JOBCK = 'N'. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,L) +C If JOBCK = 'C' or 'K', the leading N-by-L part of this +C array contains the state-output cross-covariance matrix. +C If JOBCK = 'K', this matrix has been used as state- +C output weighting matrix for computing the Kalman gain. +C This parameter is not referenced if JOBCK = 'N'. +C +C LDS INTEGER +C The leading dimension of the array S. +C LDS >= N, if JOBCK = 'C' or 'K'; +C LDS >= 1, if JOBCK = 'N'. +C +C K (output) DOUBLE PRECISION array, dimension ( LDK,L ) +C If JOBCK = 'K', the leading N-by-L part of this array +C contains the estimated Kalman gain matrix. +C If JOBCK = 'C' or 'N', this array is not referenced. +C +C LDK INTEGER +C The leading dimension of the array K. +C LDK >= N, if JOBCK = 'K'; +C LDK >= 1, if JOBCK = 'C' or 'N'. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets TOL > 0, then the given value +C of TOL is used as a lower bound for the reciprocal +C condition number; an m-by-n matrix whose estimated +C condition number is less than 1/TOL is considered to +C be of full rank. If the user sets TOL <= 0, then an +C implicitly computed, default tolerance, defined by +C TOLDEF = m*n*EPS, is used instead, where EPS is the +C relative machine precision (see LAPACK Library routine +C DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK >= max(LIW1,LIW2), where +C LIW1 = N, if METH <> 'N' and M = 0 +C or JOB = 'C' and JOBCK = 'N'; +C LIW1 = M*NOBR+N, if METH <> 'N', JOB = 'C', +C and JOBCK <> 'N'; +C LIW1 = max(L*NOBR,M*NOBR), if METH = 'M', JOB <> 'C', +C and JOBCK = 'N'; +C LIW1 = max(L*NOBR,M*NOBR+N), if METH = 'M', JOB <> 'C', +C and JOBCK = 'C' or 'K'; +C LIW1 = max(M*NOBR+N,M*(N+L)), if METH = 'N', or METH = 'C' +C and JOB <> 'C'; +C LIW2 = 0, if JOBCK <> 'K'; +C LIW2 = N*N, if JOBCK = 'K'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2), DWORK(3), DWORK(4), and +C DWORK(5) contain the reciprocal condition numbers of the +C triangular factors of the following matrices (defined in +C SLICOT Library routine IB01PD and in the lower level +C routines): +C GaL (GaL = Un(1:(s-1)*L,1:n)), +C R_1c (if METH = 'M' or 'C'), +C M (if JOBCK = 'C' or 'K' or METH = 'N'), and +C Q or T (see SLICOT Library routine IB01PY or IB01PX), +C respectively. +C If METH = 'N', DWORK(3) is set to one without any +C calculations. Similarly, if METH = 'M' and JOBCK = 'N', +C DWORK(4) is set to one. If M = 0 or JOB = 'C', +C DWORK(3) and DWORK(5) are set to one. +C If JOBCK = 'K' and INFO = 0, DWORK(6) to DWORK(13) +C contain information about the accuracy of the results when +C computing the Kalman gain matrix, as follows: +C DWORK(6) - reciprocal condition number of the matrix +C U11 of the Nth order system of algebraic +C equations from which the solution matrix X +C of the Riccati equation is obtained; +C DWORK(7) - reciprocal pivot growth factor for the LU +C factorization of the matrix U11; +C DWORK(8) - reciprocal condition number of the matrix +C As = A - S*inv(Ry)*C, which is inverted by +C the standard Riccati solver; +C DWORK(9) - reciprocal pivot growth factor for the LU +C factorization of the matrix As; +C DWORK(10) - reciprocal condition number of the matrix +C Ry; +C DWORK(11) - reciprocal condition number of the matrix +C Ry + C*X*C'; +C DWORK(12) - reciprocal condition number for the Riccati +C equation solution; +C DWORK(13) - forward error bound for the Riccati +C equation solution. +C On exit, if INFO = -30, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( LDW1,LDW2,LDW3 ), where, if METH = 'M', +C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N ), +C if JOB = 'C' or JOB = 'A' and M = 0; +C LDW1 >= max( 2*(L*NOBR-L)*N+N*N+7*N, +C (L*NOBR-L)*N+N+6*M*NOBR, (L*NOBR-L)*N+N+ +C max( L+M*NOBR, L*NOBR + +C max( 3*L*NOBR+1, M ) ) ), +C if M > 0 and JOB = 'A', 'B', or 'D'; +C LDW2 >= 0, if JOBCK = 'N'; +C LDW2 >= L*NOBR*N+ +C max( (L*NOBR-L)*N+Aw+2*N+max(5*N,(2*M+L)*NOBR+L), +C 4*(M*NOBR+N)+1, M*NOBR+2*N+L ), +C if JOBCK = 'C' or 'K', +C where Aw = N+N*N, if M = 0 or JOB = 'C'; +C Aw = 0, otherwise; +C if METH = 'N', +C LDW1 >= L*NOBR*N+max( (L*NOBR-L)*N+2*N+(2*M+L)*NOBR+L, +C 2*(L*NOBR-L)*N+N*N+8*N, +C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ); +C LDW2 >= 0, if M = 0 or JOB = 'C'; +C LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+ +C max( (N+L)**2, 4*M*(N+L)+1 ), +C if M > 0 and JOB = 'A', 'B', or 'D'; +C and, if METH = 'C', LDW1 as +C max( LDW1 for METH = 'M', JOB = 'C', LDW1 for METH = 'N'), +C and LDW2 for METH = 'N' are used; +C LDW3 >= 0, if JOBCK <> 'K'; +C LDW3 >= max( 4*N*N+2*N*L+L*L+max( 3*L,N*L ), +C 14*N*N+12*N+5 ), if JOBCK = 'K'. +C For good performance, LDWORK should be larger. +C +C BWORK LOGICAL array, dimension (LBWORK) +C LBWORK = 2*N, if JOBCK = 'K'; +C LBWORK = 0, if JOBCK <> 'K'. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 4: a least squares problem to be solved has a +C rank-deficient coefficient matrix; +C = 5: the computed covariance matrices are too small. +C The problem seems to be a deterministic one; the +C gain matrix is set to zero. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 2: the singular value decomposition (SVD) algorithm did +C not converge; +C = 3: a singular upper triangular matrix was found; +C = 3+i: if JOBCK = 'K' and the associated Riccati +C equation could not be solved, where i = 1,...,6; +C (see the description of the parameter INFO for the +C SLICOT Library routine SB02RD for the meaning of +C the i values); +C = 10: the QR algorithm did not converge. +C +C METHOD +C +C In the MOESP approach, the matrices A and C are first +C computed from an estimated extended observability matrix [1], +C and then, the matrices B and D are obtained by solving an +C extended linear system in a least squares sense. +C In the N4SID approach, besides the estimated extended +C observability matrix, the solutions of two least squares problems +C are used to build another least squares problem, whose solution +C is needed to compute the system matrices A, C, B, and D. The +C solutions of the two least squares problems are also optionally +C used by both approaches to find the covariance matrices. +C The Kalman gain matrix is obtained by solving a discrete-time +C algebraic Riccati equation. +C +C REFERENCES +C +C [1] Verhaegen M., and Dewilde, P. +C Subspace Model Identification. Part 1: The output-error +C state-space model identification class of algorithms. +C Int. J. Control, 56, pp. 1187-1210, 1992. +C +C [2] Van Overschee, P., and De Moor, B. +C N4SID: Two Subspace Algorithms for the Identification +C of Combined Deterministic-Stochastic Systems. +C Automatica, Vol.30, No.1, pp. 75-93, 1994. +C +C [3] Van Overschee, P. +C Subspace Identification : Theory - Implementation - +C Applications. +C Ph. D. Thesis, Department of Electrical Engineering, +C Katholieke Universiteit Leuven, Belgium, Feb. 1995. +C +C [4] Sima, V. +C Subspace-based Algorithms for Multivariable System +C Identification. +C Studies in Informatics and Control, 5, pp. 335-344, 1996. +C +C NUMERICAL ASPECTS +C +C The implemented method consists in numerically stable steps. +C +C FURTHER COMMENTS +C +C The covariance matrices are computed using the N4SID approach. +C Therefore, for efficiency reasons, it is advisable to set +C METH = 'N', if the Kalman gain matrix or covariance matrices +C are needed (JOBCK = 'K', or 'C'). When JOBCK = 'N', it could +C be more efficient to use the combined method, METH = 'C'. +C Often, this combination will also provide better accuracy than +C MOESP algorithm. +C In some applications, it is useful to compute the system matrices +C using two calls to this routine, the first one with JOB = 'C', +C and the second one with JOB = 'B' or 'D'. This is slightly less +C efficient than using a single call with JOB = 'A', because some +C calculations are repeated. If METH = 'N', all the calculations +C at the first call are performed again at the second call; +C moreover, it is required to save the needed submatrices of R +C before the first call and restore them before the second call. +C If the covariance matrices and/or the Kalman gain are desired, +C JOBCK should be set to 'C' or 'K' at the second call. +C If B and D are both needed, they should be computed at once. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 1999. +C +C REVISIONS +C +C March 2000, August 2000, Sept. 2001, March 2005. +C +C KEYWORDS +C +C Identification methods; least squares solutions; multivariable +C systems; QR decomposition; singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDK, LDQ, + $ LDR, LDRY, LDS, LDWORK, M, N, NOBR, NSMPL + CHARACTER JOB, JOBCK, METH +C .. Array Arguments .. + DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), + $ DWORK(*), K(LDK, *), Q(LDQ, *), R(LDR, *), + $ RY(LDRY, *), S(LDS, *) + INTEGER IWORK( * ) + LOGICAL BWORK( * ) +C .. Local Scalars .. + DOUBLE PRECISION FERR, RCOND, RCONDR, RNORM, SEP + INTEGER I, IA, IAW, IC, ID, IERR, IFACT, IG, IK, IO, + $ IQ, IR, IS, IT, IV, IWARNL, IWI, IWR, IX, + $ JWORK, LDUNN, LL, LMMNOL, LMNOBR, LNOBR, + $ MAXWRK, MINWRK, MNOBR, MNOBRN, N2, NL, NN, NPL, + $ NR + CHARACTER JOBBD, JOBCOV, JOBCV + LOGICAL COMBIN, MOESP, N4SID, WITHAL, WITHB, WITHC, + $ WITHCO, WITHD, WITHK +C .. Local Arrays .. + DOUBLE PRECISION RCND(8) + INTEGER OUFACT(2) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DLASET, IB01PD, MA02AD, SB02MT, SB02ND, + $ SB02RD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MOESP = LSAME( METH, 'M' ) + N4SID = LSAME( METH, 'N' ) + COMBIN = LSAME( METH, 'C' ) + WITHAL = LSAME( JOB, 'A' ) + WITHC = LSAME( JOB, 'C' ) .OR. WITHAL + WITHD = LSAME( JOB, 'D' ) .OR. WITHAL + WITHB = LSAME( JOB, 'B' ) .OR. WITHD + WITHK = LSAME( JOBCK, 'K' ) + WITHCO = LSAME( JOBCK, 'C' ) .OR. WITHK + MNOBR = M*NOBR + LNOBR = L*NOBR + LMNOBR = LNOBR + MNOBR + MNOBRN = MNOBR + N + LDUNN = ( LNOBR - L )*N + LMMNOL = LNOBR + 2*MNOBR + L + NR = LMNOBR + LMNOBR + NPL = N + L + N2 = N + N + NN = N*N + NL = N*L + LL = L*L + MINWRK = 1 + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT.( MOESP .OR. N4SID .OR. COMBIN ) ) THEN + INFO = -1 + ELSE IF( .NOT.( WITHB .OR. WITHC ) ) THEN + INFO = -2 + ELSE IF( .NOT.( WITHCO .OR. LSAME( JOBCK, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( NOBR.LE.1 ) THEN + INFO = -4 + ELSE IF( N.LE.0 .OR. N.GE.NOBR ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( L.LE.0 ) THEN + INFO = -7 + ELSE IF( WITHCO .AND. NSMPL.LT.NR ) THEN + INFO = -8 + ELSE IF( LDR.LT.NR ) THEN + INFO = -10 + ELSE IF( LDA.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. .NOT.MOESP ) ) + $ .AND. LDA.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. .NOT.MOESP ) ) + $ .AND. LDC.LT.L ) ) THEN + INFO = -14 + ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.N .AND. M.GT.0 ) ) + $ THEN + INFO = -16 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) + $ THEN + INFO = -18 + ELSE IF( LDQ.LT.1 .OR. ( WITHCO .AND. LDQ.LT.N ) ) THEN + INFO = -20 + ELSE IF( LDRY.LT.1 .OR. ( WITHCO .AND. LDRY.LT.L ) ) THEN + INFO = -22 + ELSE IF( LDS.LT.1 .OR. ( WITHCO .AND. LDS.LT.N ) ) THEN + INFO = -24 + ELSE IF( LDK.LT.1 .OR. ( WITHK .AND. LDK.LT.N ) ) THEN + INFO = -26 + ELSE +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance.) +C + IAW = 0 + MINWRK = LDUNN + 4*N + IF( .NOT.N4SID ) THEN + ID = 0 + IF( WITHC ) THEN + MINWRK = MAX( MINWRK, 2*LDUNN + N2, LDUNN + NN + 7*N ) + END IF + ELSE + ID = N + END IF +C + IF( ( M.GT.0 .AND. WITHB ) .OR. .NOT.MOESP ) THEN + MINWRK = MAX( MINWRK, 2*LDUNN + NN + ID + 7*N ) + IF ( MOESP ) + $ MINWRK = MAX( MINWRK, LDUNN + N + 6*MNOBR, LDUNN + N + + $ MAX( L + MNOBR, LNOBR + + $ MAX( 3*LNOBR + 1, M ) ) ) + ELSE + IF( .NOT.N4SID ) + $ IAW = N + NN + END IF +C + IF( .NOT.MOESP .OR. WITHCO ) THEN + MINWRK = MAX( MINWRK, LDUNN + IAW + N2 + MAX( 5*N, LMMNOL ), + $ ID + 4*MNOBRN + 1, ID + MNOBRN + NPL ) + IF( .NOT.MOESP .AND. M.GT.0 .AND. WITHB ) + $ MINWRK = MAX( MINWRK, MNOBR*NPL*( M*NPL + 1 ) + + $ MAX( NPL**2, 4*M*NPL + 1 ) ) + MINWRK = LNOBR*N + MINWRK + END IF +C + IF( WITHK ) THEN + MINWRK = MAX( MINWRK, 4*NN + 2*NL + LL + MAX( 3*L, NL ), + $ 14*NN + 12*N + 5 ) + END IF +C + IF ( LDWORK.LT.MINWRK ) THEN + INFO = -30 + DWORK( 1 ) = MINWRK + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01BD', -INFO ) + RETURN + END IF +C + IF ( .NOT.WITHK ) THEN + JOBCV = JOBCK + ELSE + JOBCV = 'C' + END IF +C + IO = 1 + IF ( .NOT.MOESP .OR. WITHCO ) THEN + JWORK = IO + LNOBR*N + ELSE + JWORK = IO + END IF + MAXWRK = MINWRK +C +C Call the computational routine for estimating system matrices. +C + IF ( .NOT.COMBIN ) THEN + CALL IB01PD( METH, JOB, JOBCV, NOBR, N, M, L, NSMPL, R, LDR, + $ A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, RY, LDRY, + $ S, LDS, DWORK(IO), LNOBR, TOL, IWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, IWARN, INFO ) +C + ELSE +C + IF ( WITHC ) THEN + IF ( WITHAL ) THEN + JOBCOV = 'N' + ELSE + JOBCOV = JOBCV + END IF + CALL IB01PD( 'MOESP', 'C and A', JOBCOV, NOBR, N, M, L, + $ NSMPL, R, LDR, A, LDA, C, LDC, B, LDB, D, LDD, + $ Q, LDQ, RY, LDRY, S, LDS, DWORK(IO), LNOBR, + $ TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, + $ IWARNL, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + IWARN = MAX( IWARN, IWARNL ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + END IF +C + IF ( WITHB ) THEN + IF ( .NOT.WITHAL ) THEN + JOBBD = JOB + ELSE + JOBBD = 'D' + END IF + CALL IB01PD( 'N4SID', JOBBD, JOBCV, NOBR, N, M, L, NSMPL, R, + $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, + $ RY, LDRY, S, LDS, DWORK(IO), LNOBR, TOL, IWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFO ) + IWARN = MAX( IWARN, IWARNL ) + END IF + END IF +C + IF ( INFO.NE.0 ) + $ RETURN + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + DO 10 I = 1, 4 + RCND(I) = DWORK(JWORK+I) + 10 CONTINUE +C + IF ( WITHK ) THEN + IF ( IWARN.EQ.5 ) THEN +C +C The problem seems to be a deterministic one. Set the Kalman +C gain to zero, set accuracy parameters and return. +C + CALL DLASET( 'Full', N, L, ZERO, ZERO, K, LDK ) +C + DO 20 I = 6, 12 + DWORK(I) = ONE + 20 CONTINUE +C + DWORK(13) = ZERO + ELSE +C +C Compute the Kalman gain matrix. +C +C Convert the optimal problem with coupling weighting terms +C to a standard problem. +C Workspace: need 4*N*N+2*N*L+L*L+max( 3*L,N*L ); +C prefer larger. +C + IX = 1 + IQ = IX + NN + IA = IQ + NN + IG = IA + NN + IC = IG + NN + IR = IC + NL + IS = IR + LL + JWORK = IS + NL +C + CALL MA02AD( 'Full', N, N, A, LDA, DWORK(IA), N ) + CALL MA02AD( 'Full', L, N, C, LDC, DWORK(IC), N ) + CALL DLACPY( 'Upper', N, N, Q, LDQ, DWORK(IQ), N ) + CALL DLACPY( 'Upper', L, L, RY, LDRY, DWORK(IR), L ) + CALL DLACPY( 'Full', N, L, S, LDS, DWORK(IS), N ) +C + CALL SB02MT( 'G needed', 'Nonzero S', 'Not factored', + $ 'Upper', N, L, DWORK(IA), N, DWORK(IC), N, + $ DWORK(IQ), N, DWORK(IR), L, DWORK(IS), N, + $ IWORK, IFACT, DWORK(IG), N, IWORK(L+1), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + RCONDR = DWORK(JWORK+1) +C +C Solve the Riccati equation. +C Workspace: need 14*N*N+12*N+5; +C prefer larger. +C + IT = IC + IV = IT + NN + IWR = IV + NN + IWI = IWR + N2 + IS = IWI + N2 + JWORK = IS + N2*N2 +C + CALL SB02RD( 'All', 'Discrete', 'Direct', 'NoTranspose', + $ 'Upper', 'General scaling', 'Unstable first', + $ 'Not factored', 'Reduced', N, DWORK(IA), N, + $ DWORK(IT), N, DWORK(IV), N, DWORK(IG), N, + $ DWORK(IQ), N, DWORK(IX), N, SEP, RCOND, FERR, + $ DWORK(IWR), DWORK(IWI), DWORK(IS), N2, IWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, BWORK, IERR ) +C + IF ( IERR.NE.0 .AND. IERR.LT.7 ) THEN + INFO = IERR + 3 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + DO 30 I = 1, 4 + RCND(I+4) = DWORK(JWORK+I) + 30 CONTINUE +C +C Compute the gain matrix. +C Workspace: need 2*N*N+2*N*L+L*L+3*L; +C prefer larger. +C + IA = IX + NN + IC = IA + NN + IR = IC + NL + IK = IR + LL + JWORK = IK + NL +C + CALL MA02AD( 'Full', N, N, A, LDA, DWORK(IA), N ) + CALL MA02AD( 'Full', L, N, C, LDC, DWORK(IC), N ) + CALL DLACPY( 'Upper', L, L, RY, LDRY, DWORK(IR), L ) +C + CALL SB02ND( 'Discrete', 'NotFactored', 'Upper', + $ 'Nonzero S', N, L, 0, DWORK(IA), N, DWORK(IC), + $ N, DWORK(IR), L, IWORK, S, LDS, DWORK(IX), N, + $ RNORM, DWORK(IK), L, OUFACT, IWORK(L+1), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C + IF ( IERR.NE.0 ) THEN + IF ( IERR.LE.L+1 ) THEN + INFO = 3 + ELSE IF ( IERR.EQ.L+2 ) THEN + INFO = 10 + END IF + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + CALL MA02AD( 'Full', L, N, DWORK(IK), L, K, LDK ) +C +C Set the accuracy parameters. +C + DWORK(11) = DWORK(JWORK+1) +C + DO 40 I = 6, 9 + DWORK(I) = RCND(I-1) + 40 CONTINUE +C + DWORK(10) = RCONDR + DWORK(12) = RCOND + DWORK(13) = FERR + END IF + END IF +C +C Return optimal workspace in DWORK(1) and the remaining +C reciprocal condition numbers in the next locations. +C + DWORK(1) = MAXWRK +C + DO 50 I = 2, 5 + DWORK(I) = RCND(I-1) + 50 CONTINUE +C + RETURN +C +C *** Last line of IB01BD *** + END diff --git a/mex/sources/libslicot/IB01CD.f b/mex/sources/libslicot/IB01CD.f new file mode 100644 index 000000000..001c6dcca --- /dev/null +++ b/mex/sources/libslicot/IB01CD.f @@ -0,0 +1,823 @@ + SUBROUTINE IB01CD( JOBX0, COMUSE, JOB, N, M, L, NSMP, A, LDA, B, + $ LDB, C, LDC, D, LDD, U, LDU, Y, LDY, X0, V, + $ LDV, TOL, IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the initial state and, optionally, the system matrices +C B and D of a linear time-invariant (LTI) discrete-time system, +C given the system matrices (A,B,C,D), or (when B and D are +C estimated) only the matrix pair (A,C), and the input and output +C trajectories of the system. The model structure is : +C +C x(k+1) = Ax(k) + Bu(k), k >= 0, +C y(k) = Cx(k) + Du(k), +C +C where x(k) is the n-dimensional state vector (at time k), +C u(k) is the m-dimensional input vector, +C y(k) is the l-dimensional output vector, +C and A, B, C, and D are real matrices of appropriate dimensions. +C The input-output data can internally be processed sequentially. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBX0 CHARACTER*1 +C Specifies whether or not the initial state should be +C computed, as follows: +C = 'X': compute the initial state x(0); +C = 'N': do not compute the initial state (possibly, +C because x(0) is known to be zero). +C +C COMUSE CHARACTER*1 +C Specifies whether the system matrices B and D should be +C computed or used, as follows: +C = 'C': compute the system matrices B and D, as specified +C by JOB; +C = 'U': use the system matrices B and D, as specified by +C JOB; +C = 'N': do not compute/use the matrices B and D. +C If JOBX0 = 'N' and COMUSE <> 'N', then x(0) is set +C to zero. +C If JOBX0 = 'N' and COMUSE = 'N', then x(0) is +C neither computed nor set to zero. +C +C JOB CHARACTER*1 +C If COMUSE = 'C' or 'U', specifies which of the system +C matrices B and D should be computed or used, as follows: +C = 'B': compute/use the matrix B only (D is known to be +C zero); +C = 'D': compute/use the matrices B and D. +C The value of JOB is irrelevant if COMUSE = 'N' or if +C JOBX0 = 'N' and COMUSE = 'U'. +C The combinations of options, the data used, and the +C returned results, are given in the table below, where +C '*' denotes an irrelevant value. +C +C JOBX0 COMUSE JOB Data used Returned results +C ---------------------------------------------------------- +C X C B A,C,u,y x,B +C X C D A,C,u,y x,B,D +C N C B A,C,u,y x=0,B +C N C D A,C,u,y x=0,B,D +C ---------------------------------------------------------- +C X U B A,B,C,u,y x +C X U D A,B,C,D,u,y x +C N U * - x=0 +C ---------------------------------------------------------- +C X N * A,C,y x +C N N * - - +C ---------------------------------------------------------- +C +C For JOBX0 = 'N' and COMUSE = 'N', the routine just +C sets DWORK(1) to 2 and DWORK(2) to 1, and returns +C (see the parameter DWORK). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C NSMP (input) INTEGER +C The number of rows of matrices U and Y (number of +C samples, t). +C NSMP >= 0, if JOBX0 = 'N' and COMUSE <> 'C'; +C NSMP >= N, if JOBX0 = 'X' and COMUSE <> 'C'; +C NSMP >= N*M + a + e, if COMUSE = 'C', +C where a = 0, if JOBX0 = 'N'; +C a = N, if JOBX0 = 'X'; +C e = 0, if JOBX0 = 'X' and JOB = 'B'; +C e = 1, if JOBX0 = 'N' and JOB = 'B'; +C e = M, if JOB = 'D'. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C If JOBX0 = 'X' or COMUSE = 'C', the leading N-by-N +C part of this array must contain the system state matrix A. +C If N = 0, or JOBX0 = 'N' and COMUSE <> 'C', this +C array is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,N), if JOBX0 = 'X' or COMUSE = 'C'; +C LDA >= 1, if JOBX0 = 'N' and COMUSE <> 'C'. +C +C B (input or output) DOUBLE PRECISION array, dimension +C (LDB,M) +C If JOBX0 = 'X' and COMUSE = 'U', B is an input +C parameter and, on entry, the leading N-by-M part of this +C array must contain the system input matrix B. +C If COMUSE = 'C', B is an output parameter and, on exit, +C if INFO = 0, the leading N-by-M part of this array +C contains the estimated system input matrix B. +C If min(N,M) = 0, or JOBX0 = 'N' and COMUSE = 'U', +C or COMUSE = 'N', this array is not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,N), if M > 0, COMUSE = 'U', JOBX0 = 'X', +C or M > 0, COMUSE = 'C'; +C LDB >= 1, if min(N,M) = 0, or COMUSE = 'N', +C or JOBX0 = 'N' and COMUSE = 'U'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C If JOBX0 = 'X' or COMUSE = 'C', the leading L-by-N +C part of this array must contain the system output +C matrix C. +C If N = 0, or JOBX0 = 'N' and COMUSE <> 'C', this +C array is not referenced. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= L, if N > 0, and JOBX0 = 'X' or COMUSE = 'C'; +C LDC >= 1, if N = 0, or JOBX0 = 'N' and COMUSE <> 'C'. +C +C D (input or output) DOUBLE PRECISION array, dimension +C (LDD,M) +C If JOBX0 = 'X', COMUSE = 'U', and JOB = 'D', D is an +C input parameter and, on entry, the leading L-by-M part of +C this array must contain the system input-output matrix D. +C If COMUSE = 'C' and JOB = 'D', D is an output +C parameter and, on exit, if INFO = 0, the leading +C L-by-M part of this array contains the estimated system +C input-output matrix D. +C If M = 0, or JOBX0 = 'N' and COMUSE = 'U', or +C COMUSE = 'N', or JOB = 'B', this array is not +C referenced. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= L, if M > 0, JOBX0 = 'X', COMUSE = 'U', and +C JOB = 'D', or +C if M > 0, COMUSE = 'C', and JOB = 'D'; +C LDD >= 1, if M = 0, or JOBX0 = 'N' and COMUSE = 'U', +C or COMUSE = 'N', or JOB = 'B'. +C +C U (input or input/output) DOUBLE PRECISION array, dimension +C (LDU,M) +C On entry, if COMUSE = 'C', or JOBX0 = 'X' and +C COMUSE = 'U', the leading NSMP-by-M part of this array +C must contain the t-by-m input-data sequence matrix U, +C U = [u_1 u_2 ... u_m]. Column j of U contains the +C NSMP values of the j-th input component for consecutive +C time increments. +C On exit, if COMUSE = 'C' and JOB = 'D', the leading +C NSMP-by-M part of this array contains details of the +C QR factorization of the t-by-m matrix U, possibly +C computed sequentially (see METHOD). +C If COMUSE = 'C' and JOB = 'B', or COMUSE = 'U', this +C array is unchanged on exit. +C If M = 0, or JOBX0 = 'N' and COMUSE = 'U', or +C COMUSE = 'N', this array is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= MAX(1,NSMP), if M > 0 and COMUSE = 'C' or +C JOBX0 = 'X' and COMUSE = 'U; +C LDU >= 1, if M = 0, or COMUSE = 'N', or +C JOBX0 = 'N' and COMUSE = 'U'. +C +C Y (input) DOUBLE PRECISION array, dimension (LDY,L) +C On entry, if JOBX0 = 'X' or COMUSE = 'C', the leading +C NSMP-by-L part of this array must contain the t-by-l +C output-data sequence matrix Y, Y = [y_1 y_2 ... y_l]. +C Column j of Y contains the NSMP values of the j-th +C output component for consecutive time increments. +C If JOBX0 = 'N' and COMUSE <> 'C', this array is not +C referenced. +C +C LDY INTEGER +C The leading dimension of the array Y. +C LDY >= MAX(1,NSMP), if JOBX0 = 'X' or COMUSE = 'C; +C LDY >= 1, if JOBX0 = 'N' and COMUSE <> 'C'. +C +C X0 (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0 and JOBX0 = 'X', this array contains the +C estimated initial state of the system, x(0). +C If JOBX0 = 'N' and COMUSE = 'C', this array is used as +C workspace and finally it is set to zero. +C If JOBX0 = 'N' and COMUSE = 'U', then x(0) is set to +C zero without any calculations. +C If JOBX0 = 'N' and COMUSE = 'N', this array is not +C referenced. +C +C V (output) DOUBLE PRECISION array, dimension (LDV,N) +C On exit, if INFO = 0 or 2, JOBX0 = 'X' or +C COMUSE = 'C', the leading N-by-N part of this array +C contains the orthogonal matrix V of a real Schur +C factorization of the matrix A. +C If JOBX0 = 'N' and COMUSE <> 'C', this array is not +C referenced. +C +C LDV INTEGER +C The leading dimension of the array V. +C LDV >= MAX(1,N), if JOBX0 = 'X' or COMUSE = 'C; +C LDV >= 1, if JOBX0 = 'N' and COMUSE <> 'C'. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets TOL > 0, then the given value +C of TOL is used as a lower bound for the reciprocal +C condition number; a matrix whose estimated condition +C number is less than 1/TOL is considered to be of full +C rank. If the user sets TOL <= 0, then EPS is used +C instead, where EPS is the relative machine precision +C (see LAPACK Library routine DLAMCH). TOL <= 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), where +C LIWORK >= 0, if JOBX0 = 'N' and COMUSE <> 'C'; +C LIWORK >= N, if JOBX0 = 'X' and COMUSE <> 'C'; +C LIWORK >= N*M + a, if COMUSE = 'C' and JOB = 'B', +C LIWORK >= max(N*M + a,M), if COMUSE = 'C' and JOB = 'D', +C with a = 0, if JOBX0 = 'N'; +C a = N, if JOBX0 = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK; DWORK(2) contains the reciprocal condition +C number of the triangular factor of the QR factorization of +C the matrix W2, if COMUSE = 'C', or of the matrix +C Gamma, if COMUSE = 'U' (see METHOD); if JOBX0 = 'N' +C and COMUSE <> 'C', DWORK(2) is set to one; +C if COMUSE = 'C', M > 0, and JOB = 'D', DWORK(3) +C contains the reciprocal condition number of the triangular +C factor of the QR factorization of U; denoting +C g = 2, if JOBX0 = 'X' and COMUSE <> 'C' or +C COMUSE = 'C' and M = 0 or JOB = 'B', +C g = 3, if COMUSE = 'C' and M > 0 and JOB = 'D', +C then DWORK(i), i = g+1:g+N*N, +C DWORK(j), j = g+1+N*N:g+N*N+L*N, and +C DWORK(k), k = g+1+N*N+L*N:g+N*N+L*N+N*M, +C contain the transformed system matrices At, Ct, and Bt, +C respectively, corresponding to the real Schur form of the +C given system state matrix A, i.e., +C At = V'*A*V, Bt = V'*B, Ct = C*V. +C The matrices At, Ct, Bt are not computed if JOBX0 = 'N' +C and COMUSE <> 'C'. +C On exit, if INFO = -26, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 2, if JOBX0 = 'N' and COMUSE <> 'C', or +C if max( N, M ) = 0. +C Otherwise, +C LDWORK >= LDW1 + N*( N + M + L ) + +C max( 5*N, LDW1, min( LDW2, LDW3 ) ), +C where, if COMUSE = 'C', then +C LDW1 = 2, if M = 0 or JOB = 'B', +C LDW1 = 3, if M > 0 and JOB = 'D', +C LDWa = t*L*(r + 1) + max( N + max( d, f ), 6*r ), +C LDW2 = LDWa, if M = 0 or JOB = 'B', +C LDW2 = max( LDWa, t*L*(r + 1) + 2*M*M + 6*M ), +C if M > 0 and JOB = 'D', +C LDWb = (b + r)*(r + 1) + +C max( q*(r + 1) + N*N*M + c + max( d, f ), 6*r ), +C LDW3 = LDWb, if M = 0 or JOB = 'B', +C LDW3 = max( LDWb, (b + r)*(r + 1) + 2*M*M + 6*M ), +C if M > 0 and JOB = 'D', +C r = N*M + a, +C a = 0, if JOBX0 = 'N', +C a = N, if JOBX0 = 'X'; +C b = 0, if JOB = 'B', +C b = L*M, if JOB = 'D'; +C c = 0, if JOBX0 = 'N', +C c = L*N, if JOBX0 = 'X'; +C d = 0, if JOBX0 = 'N', +C d = 2*N*N + N, if JOBX0 = 'X'; +C f = 2*r, if JOB = 'B' or M = 0, +C f = M + max( 2*r, M ), if JOB = 'D' and M > 0; +C q = b + r*L; +C and, if JOBX0 = 'X' and COMUSE <> 'C', then +C LDW1 = 2, +C LDW2 = t*L*(N + 1) + 2*N + max( 2*N*N, 4*N ), +C LDW3 = N*(N + 1) + 2*N + max( q*(N + 1) + 2*N*N + L*N, +C 4*N ), +C q = N*L. +C For good performance, LDWORK should be larger. +C If LDWORK >= LDW2, or if COMUSE = 'C' and +C LDWORK >= t*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c + +C max( d, f ), +C then standard QR factorizations of the matrices U and/or +C W2, if COMUSE = 'C', or of the matrix Gamma, if +C JOBX0 = 'X' and COMUSE <> 'C' (see METHOD), are used. +C Otherwise, the QR factorizations are computed sequentially +C by performing NCYCLE cycles, each cycle (except possibly +C the last one) processing s < t samples, where s is +C chosen by equating LDWORK to the first term of LDWb, +C if COMUSE = 'C', or of LDW3, if COMUSE <> 'C', for +C q replaced by s*L. (s is larger than or equal to the +C minimum value of NSMP.) The computational effort may +C increase and the accuracy may slightly decrease with the +C decrease of s. Recommended value is LDWORK = LDW2, +C assuming a large enough cache size, to also accommodate +C A, (B,) C, (D,) U, and Y. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 4: the least squares problem to be solved has a +C rank-deficient coefficient matrix; +C = 6: the matrix A is unstable; the estimated x(0) +C and/or B and D could be inaccurate. +C NOTE: the value 4 of IWARN has no significance for the +C identification problem. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the QR algorithm failed to compute all the +C eigenvalues of the matrix A (see LAPACK Library +C routine DGEES); the locations DWORK(i), for +C i = g+1:g+N*N, contain the partially converged +C Schur form; +C = 2: the singular value decomposition (SVD) algorithm did +C not converge. +C +C METHOD +C +C Matrix A is initially reduced to a real Schur form, A = V*At*V', +C and the given system matrices are transformed accordingly. For the +C reduced system, an extension and refinement of the method in [1,2] +C is used. Specifically, for JOBX0 = 'X', COMUSE = 'C', and +C JOB = 'D', denoting +C +C X = [ vec(D')' vec(B)' x0' ]', +C +C where vec(M) is the vector obtained by stacking the columns of +C the matrix M, then X is the least squares solution of the +C system S*X = vec(Y), with the matrix S = [ diag(U) W ], +C defined by +C +C ( U | | ... | | | ... | | ) +C ( U | 11 | ... | n1 | 12 | ... | nm | ) +C S = ( : | y | ... | y | y | ... | y | P*Gamma ), +C ( : | | ... | | | ... | | ) +C ( U | | ... | | | ... | | ) +C ij +C diag(U) having L block rows and columns. In this formula, y +C are the outputs of the system for zero initial state computed +C using the following model, for j = 1:m, and for i = 1:n, +C ij ij ij +C x (k+1) = Ax (k) + e_i u_j(k), x (0) = 0, +C +C ij ij +C y (k) = Cx (k), +C +C where e_i is the i-th n-dimensional unit vector, Gamma is +C given by +C +C ( C ) +C ( C*A ) +C Gamma = ( C*A^2 ), +C ( : ) +C ( C*A^(t-1) ) +C +C and P is a permutation matrix that groups together the rows of +C Gamma depending on the same row of C, namely +C [ c_j; c_j*A; c_j*A^2; ... c_j*A^(t-1) ], for j = 1:L. +C The first block column, diag(U), is not explicitly constructed, +C but its structure is exploited. The last block column is evaluated +C using powers of A with exponents 2^k. No interchanges are applied. +C A special QR decomposition of the matrix S is computed. Let +C U = q*[ r' 0 ]' be the QR decomposition of U, if M > 0, where +C r is M-by-M. Then, diag(q') is applied to W and vec(Y). +C The block-rows of S and vec(Y) are implicitly permuted so that +C matrix S becomes +C +C ( diag(r) W1 ) +C ( 0 W2 ), +C +C where W1 has L*M rows. Then, the QR decomposition of W2 is +C computed (sequentially, if M > 0) and used to obtain B and x0. +C The intermediate results and the QR decomposition of U are +C needed to find D. If a triangular factor is too ill conditioned, +C then singular value decomposition (SVD) is employed. SVD is not +C generally needed if the input sequence is sufficiently +C persistently exciting and NSMP is large enough. +C If the matrix W cannot be stored in the workspace (i.e., +C LDWORK < LDW2), the QR decompositions of W2 and U are +C computed sequentially. +C For JOBX0 = 'N' and COMUSE = 'C', or JOB = 'B', a simpler +C problem is solved efficiently. +C +C For JOBX0 = 'X' and COMUSE <> 'C', a simpler method is used. +C Specifically, the output y0(k) of the system for zero initial +C state is computed for k = 0, 1, ..., t-1 using the given model. +C Then the following least squares problem is solved for x(0) +C +C ( y(0) - y0(0) ) +C ( y(1) - y0(1) ) +C Gamma * x(0) = ( : ). +C ( : ) +C ( y(t-1) - y0(t-1) ) +C +C The coefficient matrix Gamma is evaluated using powers of A with +C exponents 2^k. The QR decomposition of this matrix is computed. +C If its triangular factor R is too ill conditioned, then singular +C value decomposition of R is used. +C If the coefficient matrix cannot be stored in the workspace (i.e., +C LDWORK < LDW2), the QR decomposition is computed sequentially. +C +C +C REFERENCES +C +C [1] Verhaegen M., and Varga, A. +C Some Experience with the MOESP Class of Subspace Model +C Identification Methods in Identifying the BO105 Helicopter. +C Report TR R165-94, DLR Oberpfaffenhofen, 1994. +C +C [2] Sima, V., and Varga, A. +C RASP-IDENT : Subspace Model Identification Programs. +C Deutsche Forschungsanstalt fur Luft- und Raumfahrt e. V., +C Report TR R888-94, DLR Oberpfaffenhofen, Oct. 1994. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C +C FURTHER COMMENTS +C +C The algorithm for computing the system matrices B and D is +C less efficient than the MOESP or N4SID algorithms implemented in +C SLICOT Library routines IB01BD/IB01PD, because a large least +C squares problem has to be solved, but the accuracy is better, as +C the computed matrices B and D are fitted to the input and +C output trajectories. However, if matrix A is unstable, the +C computed matrices B and D could be inaccurate. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Identification methods; least squares solutions; multivariable +C systems; QR decomposition; singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU, LDV, + $ LDWORK, LDY, M, N, NSMP + CHARACTER COMUSE, JOB, JOBX0 +C .. Array Arguments .. + DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), + $ DWORK(*), U(LDU, *), V(LDV, *), X0(*), + $ Y(LDY, *) + INTEGER IWORK(*) +C .. Local Scalars .. + DOUBLE PRECISION RCOND, RCONDU + INTEGER I, IA, IB, IC, IERR, IQ, ISIZE, ITAU, IWARNL, + $ IWI, IWR, JWORK, LDW, LDW2, LDW3, LM, LN, + $ MAXWRK, MINSMP, MINWLS, MINWRK, MTMP, N2M, + $ NCOL, NCP1, NM, NN, NSMPL + LOGICAL COMPBD, USEBD, MAXDIA, MAXDIM, WITHB, WITHD, + $ WITHX0 + CHARACTER JOBD +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLACPY, IB01QD, IB01RD, + $ TB01WD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C +C Check the input parameters. +C + WITHX0 = LSAME( JOBX0, 'X' ) + COMPBD = LSAME( COMUSE, 'C' ) + USEBD = LSAME( COMUSE, 'U' ) + WITHD = LSAME( JOB, 'D' ) + WITHB = LSAME( JOB, 'B' ) .OR. WITHD + MAXDIM = ( WITHX0 .AND. USEBD ) .OR. COMPBD + MAXDIA = WITHX0 .OR. COMPBD +C + IWARN = 0 + INFO = 0 + LDW = MAX( 1, N ) + LM = L*M + LN = L*N + NN = N*N + NM = N*M + N2M = N*NM + IF( COMPBD ) THEN + NCOL = NM + IF( WITHX0 ) + $ NCOL = NCOL + N + MINSMP = NCOL + IF( WITHD ) THEN + MINSMP = MINSMP + M + IQ = MINSMP + ELSE IF ( .NOT.WITHX0 ) THEN + IQ = MINSMP + MINSMP = MINSMP + 1 + ELSE + IQ = MINSMP + END IF + ELSE + NCOL = N + IF( WITHX0 ) THEN + MINSMP = N + ELSE + MINSMP = 0 + END IF + IQ = MINSMP + END IF +C + IF( .NOT.( WITHX0 .OR. LSAME( JOBX0, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( COMPBD .OR. USEBD .OR. LSAME( COMUSE, 'N' ) ) ) + $ THEN + INFO = -2 + ELSE IF( .NOT.WITHB ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( L.LE.0 ) THEN + INFO = -6 + ELSE IF( NSMP.LT.MINSMP ) THEN + INFO = -7 + ELSE IF( LDA.LT.1 .OR. ( MAXDIA .AND. LDA.LT.LDW ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. LDB.LT.LDW ) ) + $ THEN + INFO = -11 + ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. MAXDIA .AND. LDC.LT.L ) ) + $ THEN + INFO = -13 + ELSE IF( LDD.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. WITHD .AND. + $ LDD.LT.L ) ) THEN + INFO = -15 + ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. LDU.LT.NSMP ) ) + $ THEN + INFO = -17 + ELSE IF( LDY.LT.1 .OR. ( MAXDIA .AND. LDY.LT.NSMP ) ) THEN + INFO = -19 + ELSE IF( LDV.LT.1 .OR. ( MAXDIA .AND. LDV.LT.LDW ) ) THEN + INFO = -22 + ELSE IF( TOL.GT.ONE ) THEN + INFO = -23 + END IF +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF ( .NOT.MAXDIA .OR. MAX( N, M ).EQ.0 ) THEN + MINWRK = 2 + ELSE + NSMPL = NSMP*L + IQ = IQ*L + NCP1 = NCOL + 1 + ISIZE = NSMPL*NCP1 + IF ( COMPBD ) THEN + IF ( N.GT.0 .AND. WITHX0 ) THEN + IC = 2*NN + N + ELSE + IC = 0 + END IF + ELSE + IC = 2*NN + END IF + MINWLS = NCOL*NCP1 + IF ( COMPBD ) THEN + IF ( WITHD ) + $ MINWLS = MINWLS + LM*NCP1 + IF ( M.GT.0 .AND. WITHD ) THEN + IA = M + MAX( 2*NCOL, M ) + ELSE + IA = 2*NCOL + END IF + ITAU = N2M + MAX( IC, IA ) + IF ( WITHX0 ) + $ ITAU = ITAU + LN + LDW2 = ISIZE + MAX( N + MAX( IC, IA ), 6*NCOL ) + LDW3 = MINWLS + MAX( IQ*NCP1 + ITAU, 6*NCOL ) + IF ( M.GT.0 .AND. WITHD ) THEN + LDW2 = MAX( LDW2, ISIZE + 2*M*M + 6*M ) + LDW3 = MAX( LDW3, MINWLS + 2*M*M + 6*M ) + IA = 3 + ELSE + IA = 2 + END IF + ELSE + ITAU = IC + LN + LDW2 = ISIZE + 2*N + MAX( IC, 4*N ) + LDW3 = MINWLS + 2*N + MAX( IQ*NCP1 + ITAU, 4*N ) + IA = 2 + END IF + MINWRK = IA + NN + NM + LN + MAX( 5*N, IA, MIN( LDW2, LDW3 ) ) +C + IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN + MAXWRK = MAX( 5*N, IA ) + IF ( COMPBD ) THEN + IF ( M.GT.0 .AND. WITHD ) THEN + MAXWRK = MAX( MAXWRK, ISIZE + N + M + + $ MAX( M*ILAENV( 1, 'DGEQRF', ' ', NSMP, + $ M, -1, -1 ), + $ NCOL + NCOL*ILAENV( 1, 'DGEQRF', + $ ' ', NSMP-M, NCOL, -1, -1 ) ) ) + MAXWRK = MAX( MAXWRK, ISIZE + N + M + + $ MAX( NCP1*ILAENV( 1, 'DORMQR', 'LT', + $ NSMP, NCP1, M, -1 ), + $ NCOL + ILAENV( 1, 'DORMQR', 'LT', + $ NSMP-M, 1, NCOL, -1 ) ) ) + ELSE + MAXWRK = MAX( MAXWRK, ISIZE + N + NCOL + + $ MAX( NCOL*ILAENV( 1, 'DGEQRF', + $ ' ', NSMPL, NCOL, -1, -1 ), + $ ILAENV( 1, 'DORMQR', 'LT', + $ NSMPL, 1, NCOL, -1 ) ) ) + END IF + ELSE + MAXWRK = MAX( MAXWRK, ISIZE + 2*N + + $ MAX( N*ILAENV( 1, 'DGEQRF', ' ', + $ NSMPL, N, -1, -1 ), + $ ILAENV( 1, 'DORMQR', 'LT', + $ NSMPL, 1, N, -1 ) ) ) + END IF + MAXWRK = IA + NN + NM + LN + MAXWRK + MAXWRK = MAX( MAXWRK, MINWRK ) + END IF + END IF +C + IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN + INFO = -26 + DWORK(1) = MINWRK + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01CD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( .NOT.MAXDIA .OR. MAX( N, M ).EQ.0 ) THEN + DWORK(2) = ONE + IF ( COMPBD .AND. M.GT.0 .AND. WITHD ) THEN + DWORK(1) = THREE + DWORK(3) = ONE + ELSE + DWORK(1) = TWO + END IF + IF ( N.GT.0 .AND. USEBD ) THEN + DUM(1) = ZERO + CALL DCOPY( N, DUM, 0, X0, 1 ) + END IF + RETURN + END IF +C +C Compute the Schur factorization of A and transform the other +C given system matrices accordingly. +C Workspace: need g + N*N + L*N + N*M + 5*N, where +C g = 2, if M = 0, COMUSE = 'C', or JOB = 'B', +C g = 3, if M > 0, COMUSE = 'C', and JOB = 'D', +C g = 2, if JOBX0 = 'X' and COMUSE <> 'C'; +C prefer larger. +C + IA = IA + 1 + IC = IA + NN + IB = IC + LN + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), LDW ) + CALL DLACPY( 'Full', L, N, C, LDC, DWORK(IC), L ) +C + IF ( USEBD ) THEN + MTMP = M + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(IB), LDW ) + ELSE + MTMP = 0 + END IF + IWR = IB + NM + IWI = IWR + N + JWORK = IWI + N +C + CALL TB01WD( N, MTMP, L, DWORK(IA), LDW, DWORK(IB), LDW, + $ DWORK(IC), L, V, LDV, DWORK(IWR), DWORK(IWI), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 1 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 ) +C + DO 10 I = IWR, IWI - 1 + IF( DLAPY2( DWORK(I), DWORK(I+N) ).GE.ONE ) + $ IWARN = 6 + 10 CONTINUE +C + JWORK = IWR +C +C Estimate x(0) and/or the system matrices B and D. +C Workspace: need g + N*N + L*N + N*M + +C max( g, min( LDW2, LDW3 ) ) (see LDWORK); +C prefer larger. +C + IF ( COMPBD ) THEN + CALL IB01QD( JOBX0, JOB, N, M, L, NSMP, DWORK(IA), LDW, + $ DWORK(IC), L, U, LDU, Y, LDY, X0, DWORK(IB), LDW, + $ D, LDD, TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, + $ IWARNL, INFO ) +C + IF( INFO.EQ.0 ) THEN + IF ( M.GT.0 .AND. WITHD ) + $ RCONDU = DWORK(JWORK+2) +C +C Compute the system input matrix B corresponding to the +C original system. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, N, ONE, + $ V, LDV, DWORK(IB), LDW, ZERO, B, LDB ) + END IF + ELSE + IF ( WITHD ) THEN + JOBD = 'N' + ELSE + JOBD = 'Z' + END IF +C + CALL IB01RD( JOBD, N, MTMP, L, NSMP, DWORK(IA), LDW, DWORK(IB), + $ LDW, DWORK(IC), L, D, LDD, U, LDU, Y, LDY, X0, + $ TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, IWARNL, + $ INFO ) + END IF + IWARN = MAX( IWARN, IWARNL ) +C + IF( INFO.EQ.0 ) THEN + RCOND = DWORK(JWORK+1) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF( WITHX0 ) THEN +C +C Transform the initial state estimate to obtain the initial +C state corresponding to the original system. +C Workspace: need g + N*N + L*N + N*M + N. +C + CALL DGEMV( 'NoTranspose', N, N, ONE, V, LDV, X0, 1, ZERO, + $ DWORK(JWORK), 1 ) + CALL DCOPY( N, DWORK(JWORK), 1, X0, 1 ) + END IF +C + DWORK(1) = MAXWRK + DWORK(2) = RCOND + IF ( COMPBD .AND. M.GT.0 .AND. WITHD ) + $ DWORK(3) = RCONDU + END IF + RETURN +C +C *** End of IB01CD *** + END diff --git a/mex/sources/libslicot/IB01MD.f b/mex/sources/libslicot/IB01MD.f new file mode 100644 index 000000000..d76b4af38 --- /dev/null +++ b/mex/sources/libslicot/IB01MD.f @@ -0,0 +1,1433 @@ + SUBROUTINE IB01MD( METH, ALG, BATCH, CONCT, NOBR, M, L, NSMP, U, + $ LDU, Y, LDY, R, LDR, IWORK, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct an upper triangular factor R of the concatenated +C block Hankel matrices using input-output data. The input-output +C data can, optionally, be processed sequentially. +C +C ARGUMENTS +C +C Mode Parameters +C +C METH CHARACTER*1 +C Specifies the subspace identification method to be used, +C as follows: +C = 'M': MOESP algorithm with past inputs and outputs; +C = 'N': N4SID algorithm. +C +C ALG CHARACTER*1 +C Specifies the algorithm for computing the triangular +C factor R, as follows: +C = 'C': Cholesky algorithm applied to the correlation +C matrix of the input-output data; +C = 'F': Fast QR algorithm; +C = 'Q': QR algorithm applied to the concatenated block +C Hankel matrices. +C +C BATCH CHARACTER*1 +C Specifies whether or not sequential data processing is to +C be used, and, for sequential processing, whether or not +C the current data block is the first block, an intermediate +C block, or the last block, as follows: +C = 'F': the first block in sequential data processing; +C = 'I': an intermediate block in sequential data +C processing; +C = 'L': the last block in sequential data processing; +C = 'O': one block only (non-sequential data processing). +C NOTE that when 100 cycles of sequential data processing +C are completed for BATCH = 'I', a warning is +C issued, to prevent for an infinite loop. +C +C CONCT CHARACTER*1 +C Specifies whether or not the successive data blocks in +C sequential data processing belong to a single experiment, +C as follows: +C = 'C': the current data block is a continuation of the +C previous data block and/or it will be continued +C by the next data block; +C = 'N': there is no connection between the current data +C block and the previous and/or the next ones. +C This parameter is not used if BATCH = 'O'. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the input and output +C block Hankel matrices to be processed. NOBR > 0. +C (In the MOESP theory, NOBR should be larger than n, +C the estimated dimension of state vector.) +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C When M = 0, no system inputs are processed. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C NSMP (input) INTEGER +C The number of rows of matrices U and Y (number of +C samples, t). (When sequential data processing is used, +C NSMP is the number of samples of the current data +C block.) +C NSMP >= 2*(M+L+1)*NOBR - 1, for non-sequential +C processing; +C NSMP >= 2*NOBR, for sequential processing. +C The total number of samples when calling the routine with +C BATCH = 'L' should be at least 2*(M+L+1)*NOBR - 1. +C The NSMP argument may vary from a cycle to another in +C sequential data processing, but NOBR, M, and L should +C be kept constant. For efficiency, it is advisable to use +C NSMP as large as possible. +C +C U (input) DOUBLE PRECISION array, dimension (LDU,M) +C The leading NSMP-by-M part of this array must contain the +C t-by-m input-data sequence matrix U, +C U = [u_1 u_2 ... u_m]. Column j of U contains the +C NSMP values of the j-th input component for consecutive +C time increments. +C If M = 0, this array is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= NSMP, if M > 0; +C LDU >= 1, if M = 0. +C +C Y (input) DOUBLE PRECISION array, dimension (LDY,L) +C The leading NSMP-by-L part of this array must contain the +C t-by-l output-data sequence matrix Y, +C Y = [y_1 y_2 ... y_l]. Column j of Y contains the +C NSMP values of the j-th output component for consecutive +C time increments. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= NSMP. +C +C R (output or input/output) DOUBLE PRECISION array, dimension +C ( LDR,2*(M+L)*NOBR ) +C On exit, if INFO = 0 and ALG = 'Q', or (ALG = 'C' or 'F', +C and BATCH = 'L' or 'O'), the leading +C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of +C this array contains the (current) upper triangular factor +C R from the QR factorization of the concatenated block +C Hankel matrices. The diagonal elements of R are positive +C when the Cholesky algorithm was successfully used. +C On exit, if ALG = 'C' and BATCH = 'F' or 'I', the leading +C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this +C array contains the current upper triangular part of the +C correlation matrix in sequential data processing. +C If ALG = 'F' and BATCH = 'F' or 'I', the array R is not +C referenced. +C On entry, if ALG = 'C', or ALG = 'Q', and BATCH = 'I' or +C 'L', the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper +C triangular part of this array must contain the upper +C triangular matrix R computed at the previous call of this +C routine in sequential data processing. The array R need +C not be set on entry if ALG = 'F' or if BATCH = 'F' or 'O'. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= 2*(M+L)*NOBR. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK >= M+L, if ALG = 'F'; +C LIWORK >= 0, if ALG = 'C' or 'Q'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -17, DWORK(1) returns the minimum +C value of LDWORK. +C Let +C k = 0, if CONCT = 'N' and ALG = 'C' or 'Q'; +C k = 2*NOBR-1, if CONCT = 'C' and ALG = 'C' or 'Q'; +C k = 2*NOBR*(M+L+1), if CONCT = 'N' and ALG = 'F'; +C k = 2*NOBR*(M+L+2), if CONCT = 'C' and ALG = 'F'. +C The first (M+L)*k elements of DWORK should be preserved +C during successive calls of the routine with BATCH = 'F' +C or 'I', till the final call with BATCH = 'L'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= (4*NOBR-2)*(M+L), if ALG = 'C', BATCH <> 'O' and +C CONCT = 'C'; +C LDWORK >= 1, if ALG = 'C', BATCH = 'O' or +C CONCT = 'N'; +C LDWORK >= (M+L)*2*NOBR*(M+L+3), if ALG = 'F', +C BATCH <> 'O' and CONCT = 'C'; +C LDWORK >= (M+L)*2*NOBR*(M+L+1), if ALG = 'F', +C BATCH = 'F', 'I' and CONCT = 'N'; +C LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, if ALG = 'F', +C BATCH = 'L' and CONCT = 'N', or +C BATCH = 'O'; +C LDWORK >= 4*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F' or 'O', +C and LDR >= NS = NSMP - 2*NOBR + 1; +C LDWORK >= 6*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F' or 'O', +C and LDR < NS, or BATCH = 'I' or +C 'L' and CONCT = 'N'; +C LDWORK >= 4*(NOBR+1)*(M+L)*NOBR, if ALG = 'Q', BATCH = 'I' +C or 'L' and CONCT = 'C'. +C The workspace used for ALG = 'Q' is +C LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR, +C where LDRWRK = LDWORK/(2*(M+L)*NOBR) - 2; recommended +C value LDRWRK = NS, assuming a large enough cache size. +C For good performance, LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: the number of 100 cycles in sequential data +C processing has been exhausted without signaling +C that the last block of data was get; the cycle +C counter was reinitialized; +C = 2: a fast algorithm was requested (ALG = 'C' or 'F'), +C but it failed, and the QR algorithm was then used +C (non-sequential data processing). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: a fast algorithm was requested (ALG = 'C', or 'F') +C in sequential data processing, but it failed. The +C routine can be repeatedly called again using the +C standard QR algorithm. +C +C METHOD +C +C 1) For non-sequential data processing using QR algorithm, a +C t x 2(m+l)s matrix H is constructed, where +C +C H = [ Uf' Up' Y' ], for METH = 'M', +C s+1,2s,t 1,s,t 1,2s,t +C +C H = [ U' Y' ], for METH = 'N', +C 1,2s,t 1,2s,t +C +C and Up , Uf , U , and Y are block Hankel +C 1,s,t s+1,2s,t 1,2s,t 1,2s,t +C matrices defined in terms of the input and output data [3]. +C A QR factorization is used to compress the data. +C The fast QR algorithm uses a QR factorization which exploits +C the block-Hankel structure. Actually, the Cholesky factor of H'*H +C is computed. +C +C 2) For sequential data processing using QR algorithm, the QR +C decomposition is done sequentially, by updating the upper +C triangular factor R. This is also performed internally if the +C workspace is not large enough to accommodate an entire batch. +C +C 3) For non-sequential or sequential data processing using +C Cholesky algorithm, the correlation matrix of input-output data is +C computed (sequentially, if requested), taking advantage of the +C block Hankel structure [7]. Then, the Cholesky factor of the +C correlation matrix is found, if possible. +C +C REFERENCES +C +C [1] Verhaegen M., and Dewilde, P. +C Subspace Model Identification. Part 1: The output-error +C state-space model identification class of algorithms. +C Int. J. Control, 56, pp. 1187-1210, 1992. +C +C [2] Verhaegen M. +C Subspace Model Identification. Part 3: Analysis of the +C ordinary output-error state-space model identification +C algorithm. +C Int. J. Control, 58, pp. 555-586, 1993. +C +C [3] Verhaegen M. +C Identification of the deterministic part of MIMO state space +C models given in innovations form from input-output data. +C Automatica, Vol.30, No.1, pp.61-74, 1994. +C +C [4] Van Overschee, P., and De Moor, B. +C N4SID: Subspace Algorithms for the Identification of +C Combined Deterministic-Stochastic Systems. +C Automatica, Vol.30, No.1, pp. 75-93, 1994. +C +C [5] Peternell, K., Scherrer, W. and Deistler, M. +C Statistical Analysis of Novel Subspace Identification Methods. +C Signal Processing, 52, pp. 161-177, 1996. +C +C [6] Sima, V. +C Subspace-based Algorithms for Multivariable System +C Identification. +C Studies in Informatics and Control, 5, pp. 335-344, 1996. +C +C [7] Sima, V. +C Cholesky or QR Factorization for Data Compression in +C Subspace-based Identification ? +C Proceedings of the Second NICONET Workshop on ``Numerical +C Control Software: SLICOT, a Useful Tool in Industry'', +C December 3, 1999, INRIA Rocquencourt, France, pp. 75-80, 1999. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable (when QR algorithm is +C used), reliable and efficient. The fast Cholesky or QR algorithms +C are more efficient, but the accuracy could diminish by forming the +C correlation matrix. +C 2 +C The QR algorithm needs 0(t(2(m+l)s) ) floating point operations. +C 2 3 +C The Cholesky algorithm needs 0(2t(m+l) s)+0((2(m+l)s) ) floating +C point operations. +C 2 3 2 +C The fast QR algorithm needs 0(2t(m+l) s)+0(4(m+l) s ) floating +C point operations. +C +C FURTHER COMMENTS +C +C For ALG = 'Q', BATCH = 'O' and LDR < NS, or BATCH <> 'O', the +C calculations could be rather inefficient if only minimal workspace +C (see argument LDWORK) is provided. It is advisable to provide as +C much workspace as possible. Almost optimal efficiency can be +C obtained for LDWORK = (NS+2)*(2*(M+L)*NOBR), assuming that the +C cache size is large enough to accommodate R, U, Y, and DWORK. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. +C +C REVISIONS +C +C Feb. 2000, Aug. 2000, Feb. 2004. +C +C KEYWORDS +C +C Cholesky decomposition, Hankel matrix, identification methods, +C multivariable systems, QR decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + INTEGER MAXCYC + PARAMETER ( MAXCYC = 100 ) +C .. Scalar Arguments .. + INTEGER INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, NOBR, + $ NSMP + CHARACTER ALG, BATCH, CONCT, METH +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION DWORK(*), R(LDR, *), U(LDU, *), Y(LDY, *) +C .. Local Scalars .. + DOUBLE PRECISION UPD, TEMP + INTEGER I, ICOL, ICYCLE, ID, IERR, II, INICYC, INIT, + $ INITI, INU, INY, IREV, ISHFT2, ISHFTU, ISHFTY, + $ ITAU, J, JD, JWORK, LDRWMX, LDRWRK, LLDRW, + $ LMNOBR, LNOBR, MAXWRK, MINWRK, MLDRW, MMNOBR, + $ MNOBR, NCYCLE, NICYCL, NOBR2, NOBR21, NOBRM1, + $ NR, NS, NSF, NSL, NSLAST, NSMPSM + LOGICAL CHALG, CONNEC, FIRST, FQRALG, INTERM, LAST, + $ LINR, MOESP, N4SID, ONEBCH, QRALG +C .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEQRF, DGER, DLACPY, + $ DLASET, DPOTRF, DSWAP, DSYRK, IB01MY, MB04OD, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Save Statement .. +C ICYCLE is used to count the cycles for BATCH = 'I'. It is +C reinitialized at each MAXCYC cycles. +C MAXWRK is used to store the optimal workspace. +C NSMPSM is used to sum up the NSMP values for BATCH <> 'O'. + SAVE ICYCLE, MAXWRK, NSMPSM +C .. +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MOESP = LSAME( METH, 'M' ) + N4SID = LSAME( METH, 'N' ) + FQRALG = LSAME( ALG, 'F' ) + QRALG = LSAME( ALG, 'Q' ) + CHALG = LSAME( ALG, 'C' ) + ONEBCH = LSAME( BATCH, 'O' ) + FIRST = LSAME( BATCH, 'F' ) .OR. ONEBCH + INTERM = LSAME( BATCH, 'I' ) + LAST = LSAME( BATCH, 'L' ) .OR. ONEBCH + IF( .NOT.ONEBCH ) THEN + CONNEC = LSAME( CONCT, 'C' ) + ELSE + CONNEC = .FALSE. + END IF +C + MNOBR = M*NOBR + LNOBR = L*NOBR + LMNOBR = LNOBR + MNOBR + MMNOBR = MNOBR + MNOBR + NOBRM1 = NOBR - 1 + NOBR21 = NOBR + NOBRM1 + NOBR2 = NOBR21 + 1 + IWARN = 0 + INFO = 0 + IERR = 0 + IF( FIRST ) THEN + ICYCLE = 1 + MAXWRK = 1 + NSMPSM = 0 + END IF + NSMPSM = NSMPSM + NSMP + NR = LMNOBR + LMNOBR +C +C Check the scalar input parameters. +C + IF( .NOT.( MOESP .OR. N4SID ) ) THEN + INFO = -1 + ELSE IF( .NOT.( FQRALG .OR. QRALG .OR. CHALG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( FIRST .OR. INTERM .OR. LAST ) ) THEN + INFO = -3 + ELSE IF( .NOT. ONEBCH ) THEN + IF( .NOT.( CONNEC .OR. LSAME( CONCT, 'N' ) ) ) + $ INFO = -4 + END IF + IF( INFO.EQ.0 ) THEN + IF( NOBR.LE.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( L.LE.0 ) THEN + INFO = -7 + ELSE IF( NSMP.LT.NOBR2 .OR. + $ ( LAST .AND. NSMPSM.LT.NR+NOBR21 ) ) THEN + INFO = -8 + ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN + INFO = -10 + ELSE IF( LDY.LT.NSMP ) THEN + INFO = -12 + ELSE IF( LDR.LT.NR ) THEN + INFO = -14 + ELSE +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe +C the minimal amount of workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + NS = NSMP - NOBR21 + IF ( CHALG ) THEN + IF ( .NOT.ONEBCH .AND. CONNEC ) THEN + MINWRK = 2*( NR - M - L ) + ELSE + MINWRK = 1 + END IF + ELSE IF ( FQRALG ) THEN + IF ( .NOT.ONEBCH .AND. CONNEC ) THEN + MINWRK = NR*( M + L + 3 ) + ELSE IF ( FIRST .OR. INTERM ) THEN + MINWRK = NR*( M + L + 1 ) + ELSE + MINWRK = 2*NR*( M + L + 1 ) + NR + END IF + ELSE + MINWRK = 2*NR + MAXWRK = NR + NR*ILAENV( 1, 'DGEQRF', ' ', NS, NR, -1, + $ -1 ) + IF ( FIRST ) THEN + IF ( LDR.LT.NS ) THEN + MINWRK = MINWRK + NR + MAXWRK = NS*NR + MAXWRK + END IF + ELSE + IF ( CONNEC ) THEN + MINWRK = MINWRK*( NOBR + 1 ) + ELSE + MINWRK = MINWRK + NR + END IF + MAXWRK = NS*NR + MAXWRK + END IF + END IF + MAXWRK = MAX( MINWRK, MAXWRK ) +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -17 + DWORK( 1 ) = MINWRK + END IF + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01MD', -INFO ) + RETURN + END IF +C + IF ( CHALG ) THEN +C +C Compute the R factor from a Cholesky factorization of the +C input-output data correlation matrix. +C +C Set the parameters for constructing the correlations of the +C current block. +C + LDRWRK = 2*NOBR2 - 2 + IF( FIRST ) THEN + UPD = ZERO + ELSE + UPD = ONE + END IF +C + IF( .NOT.FIRST .AND. CONNEC ) THEN +C +C Restore the saved (M+L)*(2*NOBR-1) "connection" elements of +C U and Y into their appropriate position in sequential +C processing. The process is performed column-wise, in +C reverse order, first for Y and then for U. +C Workspace: need (4*NOBR-2)*(M+L). +C + IREV = NR - M - L - NOBR21 + 1 + ICOL = 2*( NR - M - L ) - LDRWRK + 1 +C + DO 10 J = 2, M + L + DO 5 I = NOBR21 - 1, 0, -1 + DWORK(ICOL+I) = DWORK(IREV+I) + 5 CONTINUE + IREV = IREV - NOBR21 + ICOL = ICOL - LDRWRK + 10 CONTINUE +C + IF ( M.GT.0 ) + $ CALL DLACPY( 'Full', NOBR21, M, U, LDU, DWORK(NOBR2), + $ LDRWRK ) + CALL DLACPY( 'Full', NOBR21, L, Y, LDY, + $ DWORK(LDRWRK*M+NOBR2), LDRWRK ) + END IF +C + IF ( M.GT.0 ) THEN +C +C Let Guu(i,j) = Guu0(i,j) + u_i*u_j' + u_(i+1)*u_(j+1)' + +C ... + u_(i+NS-1)*u_(j+NS-1)', +C where u_i' is the i-th row of U, j = 1 : 2s, i = 1 : j, +C NS = NSMP - 2s + 1, and Guu0(i,j) is a zero matrix for +C BATCH = 'O' or 'F', and it is the matrix Guu(i,j) computed +C till the current block for BATCH = 'I' or 'L'. The matrix +C Guu(i,j) is m-by-m, and Guu(j,j) is symmetric. The +C upper triangle of the U-U correlations, Guu, is computed +C (or updated) column-wise in the array R, that is, in the +C order Guu(1,1), Guu(1,2), Guu(2,2), ..., Guu(2s,2s). +C Only the submatrices of the first block-row are fully +C computed (or updated). The remaining ones are determined +C exploiting the block-Hankel structure, using the updating +C formula +C +C Guu(i+1,j+1) = Guu0(i+1,j+1) - Guu0(i,j) + Guu(i,j) + +C u_(i+NS)*u_(j+NS)' - u_i*u_j'. +C + IF( .NOT.FIRST ) THEN +C +C Subtract the contribution of the previous block of data +C in sequential processing. The columns must be processed +C in backward order. +C + DO 20 I = NOBR21*M, 1, -1 + CALL DAXPY( I, -ONE, R(1,I), 1, R(M+1,M+I), 1 ) + 20 CONTINUE +C + END IF +C +C Compute/update Guu(1,1). +C + IF( .NOT.FIRST .AND. CONNEC ) + $ CALL DSYRK( 'Upper', 'Transpose', M, NOBR21, ONE, DWORK, + $ LDRWRK, UPD, R, LDR ) + CALL DSYRK( 'Upper', 'Transpose', M, NS, ONE, U, LDU, UPD, + $ R, LDR ) +C + JD = 1 +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 70 J = 2, NOBR2 + JD = JD + M + ID = M + 1 +C +C Compute/update Guu(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NS, ONE, + $ U, LDU, U(J,1), LDU, UPD, R(1,JD), LDR ) +C +C Compute/update Guu(2:j,j), exploiting the +C block-Hankel structure. +C + IF( FIRST ) THEN +C + DO 30 I = JD - M, JD - 1 + CALL DCOPY( I, R(1,I), 1, R(M+1,M+I), 1 ) + 30 CONTINUE +C + ELSE +C + DO 40 I = JD - M, JD - 1 + CALL DAXPY( I, ONE, R(1,I), 1, R(M+1,M+I), 1 ) + 40 CONTINUE +C + END IF +C + DO 50 I = 2, J - 1 + CALL DGER( M, M, ONE, U(NS+I-1,1), LDU, + $ U(NS+J-1,1), LDU, R(ID,JD), LDR ) + CALL DGER( M, M, -ONE, U(I-1,1), LDU, U(J-1,1), + $ LDU, R(ID,JD), LDR ) + ID = ID + M + 50 CONTINUE +C + DO 60 I = 1, M + CALL DAXPY( I, U(NS+J-1,I), U(NS+J-1,1), LDU, + $ R(JD,JD+I-1), 1 ) + CALL DAXPY( I, -U(J-1,I), U(J-1,1), LDU, + $ R(JD,JD+I-1), 1 ) + 60 CONTINUE +C + 70 CONTINUE +C + ELSE +C + DO 120 J = 2, NOBR2 + JD = JD + M + ID = M + 1 +C +C Compute/update Guu(1,j) for sequential processing +C with connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NOBR21, + $ ONE, DWORK, LDRWRK, DWORK(J), LDRWRK, UPD, + $ R(1,JD), LDR ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NS, ONE, + $ U, LDU, U(J,1), LDU, ONE, R(1,JD), LDR ) +C +C Compute/update Guu(2:j,j) for sequential processing +C with connected blocks, exploiting the block-Hankel +C structure. +C + IF( FIRST ) THEN +C + DO 80 I = JD - M, JD - 1 + CALL DCOPY( I, R(1,I), 1, R(M+1,M+I), 1 ) + 80 CONTINUE +C + ELSE +C + DO 90 I = JD - M, JD - 1 + CALL DAXPY( I, ONE, R(1,I), 1, R(M+1,M+I), 1 ) + 90 CONTINUE +C + END IF +C + DO 100 I = 2, J - 1 + CALL DGER( M, M, ONE, U(NS+I-1,1), LDU, + $ U(NS+J-1,1), LDU, R(ID,JD), LDR ) + CALL DGER( M, M, -ONE, DWORK(I-1), LDRWRK, + $ DWORK(J-1), LDRWRK, R(ID,JD), LDR ) + ID = ID + M + 100 CONTINUE +C + DO 110 I = 1, M + CALL DAXPY( I, U(NS+J-1,I), U(NS+J-1,1), LDU, + $ R(JD,JD+I-1), 1 ) + CALL DAXPY( I, -DWORK((I-1)*LDRWRK+J-1), + $ DWORK(J-1), LDRWRK, R(JD,JD+I-1), 1 ) + 110 CONTINUE +C + 120 CONTINUE +C + END IF +C + IF ( LAST .AND. MOESP ) THEN +C +C Interchange past and future parts for MOESP algorithm. +C (Only the upper triangular parts are interchanged, and +C the (1,2) part is transposed in-situ.) +C + TEMP = R(1,1) + R(1,1) = R(MNOBR+1,MNOBR+1) + R(MNOBR+1,MNOBR+1) = TEMP +C + DO 130 J = 2, MNOBR + CALL DSWAP( J, R(1,J), 1, R(MNOBR+1,MNOBR+J), 1 ) + CALL DSWAP( J-1, R(1,MNOBR+J), 1, R(J,MNOBR+1), LDR ) + 130 CONTINUE +C + END IF +C +C Let Guy(i,j) = Guy0(i,j) + u_i*y_j' + u_(i+1)*y_(j+1)' + +C ... + u_(i+NS-1)*y_(j+NS-1)', +C where u_i' is the i-th row of U, y_j' is the j-th row +C of Y, j = 1 : 2s, i = 1 : 2s, NS = NSMP - 2s + 1, and +C Guy0(i,j) is a zero matrix for BATCH = 'O' or 'F', and it +C is the matrix Guy(i,j) computed till the current block for +C BATCH = 'I' or 'L'. Guy(i,j) is m-by-L. The U-Y +C correlations, Guy, are computed (or updated) column-wise +C in the array R. Only the submatrices of the first block- +C column and block-row are fully computed (or updated). The +C remaining ones are determined exploiting the block-Hankel +C structure, using the updating formula +C +C Guy(i+1,j+1) = Guy0(i+1,j+1) - Guy0(i,j) + Guy(i,j) + +C u_(i+NS)*y(j+NS)' - u_i*y_j'. +C + II = MMNOBR - M + IF( .NOT.FIRST ) THEN +C +C Subtract the contribution of the previous block of data +C in sequential processing. The columns must be processed +C in backward order. +C + DO 140 I = NR - L, MMNOBR + 1, -1 + CALL DAXPY( II, -ONE, R(1,I), 1, R(M+1,L+I), 1 ) + 140 CONTINUE +C + END IF +C +C Compute/update the first block-column of Guy, Guy(i,1). +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 150 I = 1, NOBR2 + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, + $ U(I,1), LDU, Y, LDY, UPD, + $ R((I-1)*M+1,MMNOBR+1), LDR ) + 150 CONTINUE +C + ELSE +C + DO 160 I = 1, NOBR2 + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR21, + $ ONE, DWORK(I), LDRWRK, DWORK(LDRWRK*M+1), + $ LDRWRK, UPD, R((I-1)*M+1,MMNOBR+1), LDR ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, + $ U(I,1), LDU, Y, LDY, ONE, + $ R((I-1)*M+1,MMNOBR+1), LDR ) + 160 CONTINUE +C + END IF +C + JD = MMNOBR + 1 +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 200 J = 2, NOBR2 + JD = JD + L + ID = M + 1 +C +C Compute/update Guy(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, + $ U, LDU, Y(J,1), LDY, UPD, R(1,JD), LDR ) +C +C Compute/update Guy(2:2*s,j), exploiting the +C block-Hankel structure. +C + IF( FIRST ) THEN +C + DO 170 I = JD - L, JD - 1 + CALL DCOPY( II, R(1,I), 1, R(M+1,L+I), 1 ) + 170 CONTINUE +C + ELSE +C + DO 180 I = JD - L, JD - 1 + CALL DAXPY( II, ONE, R(1,I), 1, R(M+1,L+I), 1 ) + 180 CONTINUE +C + END IF +C + DO 190 I = 2, NOBR2 + CALL DGER( M, L, ONE, U(NS+I-1,1), LDU, + $ Y(NS+J-1,1), LDY, R(ID,JD), LDR ) + CALL DGER( M, L, -ONE, U(I-1,1), LDU, Y(J-1,1), + $ LDY, R(ID,JD), LDR ) + ID = ID + M + 190 CONTINUE +C + 200 CONTINUE +C + ELSE +C + DO 240 J = 2, NOBR2 + JD = JD + L + ID = M + 1 +C +C Compute/update Guy(1,j) for sequential processing +C with connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR21, + $ ONE, DWORK, LDRWRK, DWORK(LDRWRK*M+J), + $ LDRWRK, UPD, R(1,JD), LDR ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, + $ U, LDU, Y(J,1), LDY, ONE, R(1,JD), LDR ) +C +C Compute/update Guy(2:2*s,j) for sequential +C processing with connected blocks, exploiting the +C block-Hankel structure. +C + IF( FIRST ) THEN +C + DO 210 I = JD - L, JD - 1 + CALL DCOPY( II, R(1,I), 1, R(M+1,L+I), 1 ) + 210 CONTINUE +C + ELSE +C + DO 220 I = JD - L, JD - 1 + CALL DAXPY( II, ONE, R(1,I), 1, R(M+1,L+I), 1 ) + 220 CONTINUE +C + END IF +C + DO 230 I = 2, NOBR2 + CALL DGER( M, L, ONE, U(NS+I-1,1), LDU, + $ Y(NS+J-1,1), LDY, R(ID,JD), LDR ) + CALL DGER( M, L, -ONE, DWORK(I-1), LDRWRK, + $ DWORK(LDRWRK*M+J-1), LDRWRK, R(ID,JD), + $ LDR ) + ID = ID + M + 230 CONTINUE +C + 240 CONTINUE +C + END IF +C + IF ( LAST .AND. MOESP ) THEN +C +C Interchange past and future parts of U-Y correlations +C for MOESP algorithm. +C + DO 250 J = MMNOBR + 1, NR + CALL DSWAP( MNOBR, R(1,J), 1, R(MNOBR+1,J), 1 ) + 250 CONTINUE +C + END IF + END IF +C +C Let Gyy(i,j) = Gyy0(i,j) + y_i*y_i' + y_(i+1)*y_(i+1)' + ... + +C y_(i+NS-1)*y_(i+NS-1)', +C where y_i' is the i-th row of Y, j = 1 : 2s, i = 1 : j, +C NS = NSMP - 2s + 1, and Gyy0(i,j) is a zero matrix for +C BATCH = 'O' or 'F', and it is the matrix Gyy(i,j) computed till +C the current block for BATCH = 'I' or 'L'. Gyy(i,j) is L-by-L, +C and Gyy(j,j) is symmetric. The upper triangle of the Y-Y +C correlations, Gyy, is computed (or updated) column-wise in +C the corresponding part of the array R, that is, in the order +C Gyy(1,1), Gyy(1,2), Gyy(2,2), ..., Gyy(2s,2s). Only the +C submatrices of the first block-row are fully computed (or +C updated). The remaining ones are determined exploiting the +C block-Hankel structure, using the updating formula +C +C Gyy(i+1,j+1) = Gyy0(i+1,j+1) - Gyy0(i,j) + Gyy(i,j) + +C y_(i+NS)*y_(j+NS)' - y_i*y_j'. +C + JD = MMNOBR + 1 +C + IF( .NOT.FIRST ) THEN +C +C Subtract the contribution of the previous block of data +C in sequential processing. The columns must be processed in +C backward order. +C + DO 260 I = NR - L, MMNOBR + 1, -1 + CALL DAXPY( I-MMNOBR, -ONE, R(JD,I), 1, R(JD+L,L+I), 1 ) + 260 CONTINUE +C + END IF +C +C Compute/update Gyy(1,1). +C + IF( .NOT.FIRST .AND. CONNEC ) + $ CALL DSYRK( 'Upper', 'Transpose', L, NOBR21, ONE, + $ DWORK(LDRWRK*M+1), LDRWRK, UPD, R(JD,JD), LDR ) + CALL DSYRK( 'Upper', 'Transpose', L, NS, ONE, Y, LDY, UPD, + $ R(JD,JD), LDR ) +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 310 J = 2, NOBR2 + JD = JD + L + ID = MMNOBR + L + 1 +C +C Compute/update Gyy(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NS, ONE, Y, + $ LDY, Y(J,1), LDY, UPD, R(MMNOBR+1,JD), LDR ) +C +C Compute/update Gyy(2:j,j), exploiting the block-Hankel +C structure. +C + IF( FIRST ) THEN +C + DO 270 I = JD - L, JD - 1 + CALL DCOPY( I-MMNOBR, R(MMNOBR+1,I), 1, + $ R(MMNOBR+L+1,L+I), 1 ) + 270 CONTINUE +C + ELSE +C + DO 280 I = JD - L, JD - 1 + CALL DAXPY( I-MMNOBR, ONE, R(MMNOBR+1,I), 1, + $ R(MMNOBR+L+1,L+I), 1 ) + 280 CONTINUE +C + END IF +C + DO 290 I = 2, J - 1 + CALL DGER( L, L, ONE, Y(NS+I-1,1), LDY, Y(NS+J-1,1), + $ LDY, R(ID,JD), LDR ) + CALL DGER( L, L, -ONE, Y(I-1,1), LDY, Y(J-1,1), LDY, + $ R(ID,JD), LDR ) + ID = ID + L + 290 CONTINUE +C + DO 300 I = 1, L + CALL DAXPY( I, Y(NS+J-1,I), Y(NS+J-1,1), LDY, + $ R(JD,JD+I-1), 1 ) + CALL DAXPY( I, -Y(J-1,I), Y(J-1,1), LDY, R(JD,JD+I-1), + $ 1 ) + 300 CONTINUE +C + 310 CONTINUE +C + ELSE +C + DO 360 J = 2, NOBR2 + JD = JD + L + ID = MMNOBR + L + 1 +C +C Compute/update Gyy(1,j) for sequential processing with +C connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NOBR21, + $ ONE, DWORK(LDRWRK*M+1), LDRWRK, + $ DWORK(LDRWRK*M+J), LDRWRK, UPD, + $ R(MMNOBR+1,JD), LDR ) + CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NS, ONE, Y, + $ LDY, Y(J,1), LDY, ONE, R(MMNOBR+1,JD), LDR ) +C +C Compute/update Gyy(2:j,j) for sequential processing +C with connected blocks, exploiting the block-Hankel +C structure. +C + IF( FIRST ) THEN +C + DO 320 I = JD - L, JD - 1 + CALL DCOPY( I-MMNOBR, R(MMNOBR+1,I), 1, + $ R(MMNOBR+L+1,L+I), 1 ) + 320 CONTINUE +C + ELSE +C + DO 330 I = JD - L, JD - 1 + CALL DAXPY( I-MMNOBR, ONE, R(MMNOBR+1,I), 1, + $ R(MMNOBR+L+1,L+I), 1 ) + 330 CONTINUE +C + END IF +C + DO 340 I = 2, J - 1 + CALL DGER( L, L, ONE, Y(NS+I-1,1), LDY, Y(NS+J-1,1), + $ LDY, R(ID,JD), LDR ) + CALL DGER( L, L, -ONE, DWORK(LDRWRK*M+I-1), LDRWRK, + $ DWORK(LDRWRK*M+J-1), LDRWRK, R(ID,JD), + $ LDR ) + ID = ID + L + 340 CONTINUE +C + DO 350 I = 1, L + CALL DAXPY( I, Y(NS+J-1,I), Y(NS+J-1,1), LDY, + $ R(JD,JD+I-1), 1 ) + CALL DAXPY( I, -DWORK(LDRWRK*(M+I-1)+J-1), + $ DWORK(LDRWRK*M+J-1), LDRWRK, R(JD,JD+I-1), + $ 1 ) + 350 CONTINUE +C + 360 CONTINUE +C + END IF +C + IF ( .NOT.LAST ) THEN + IF ( CONNEC ) THEN +C +C For sequential processing with connected data blocks, +C save the remaining ("connection") elements of U and Y +C in the first (M+L)*(2*NOBR-1) locations of DWORK. +C + IF ( M.GT.0 ) + $ CALL DLACPY( 'Full', NOBR21, M, U(NS+1,1), LDU, DWORK, + $ NOBR21 ) + CALL DLACPY( 'Full', NOBR21, L, Y(NS+1,1), LDY, + $ DWORK(MMNOBR-M+1), NOBR21 ) + END IF +C +C Return to get new data. +C + ICYCLE = ICYCLE + 1 + IF ( ICYCLE.GT.MAXCYC ) + $ IWARN = 1 + RETURN +C + ELSE +C +C Try to compute the Cholesky factor of the correlation +C matrix. +C + CALL DPOTRF( 'Upper', NR, R, LDR, IERR ) + GO TO 370 + END IF + ELSE IF ( FQRALG ) THEN +C +C Compute the R factor from a fast QR factorization of the +C input-output data correlation matrix. +C + CALL IB01MY( METH, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU, + $ Y, LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN, + $ IERR ) + IF( .NOT.LAST ) + $ RETURN + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + END IF +C + 370 CONTINUE +C + IF( IERR.NE.0 ) THEN +C +C Error return from a fast factorization algorithm of the +C input-output data correlation matrix. +C + IF( ONEBCH ) THEN + QRALG = .TRUE. + IWARN = 2 + MINWRK = 2*NR + MAXWRK = NR + NR*ILAENV( 1, 'DGEQRF', ' ', NS, NR, -1, + $ -1 ) + IF ( LDR.LT.NS ) THEN + MINWRK = MINWRK + NR + MAXWRK = NS*NR + MAXWRK + END IF + MAXWRK = MAX( MINWRK, MAXWRK ) +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -17 +C +C Return: Not enough workspace. +C + DWORK( 1 ) = MINWRK + CALL XERBLA( 'IB01MD', -INFO ) + RETURN + END IF + ELSE + INFO = 1 + RETURN + END IF + END IF +C + IF ( QRALG ) THEN +C +C Compute the R factor from a QR factorization of the matrix H +C of concatenated block Hankel matrices. +C +C Construct the matrix H. +C +C Set the parameters for constructing the current segment of the +C Hankel matrix, taking the available memory space into account. +C INITI+1 points to the beginning rows of U and Y from which +C data are taken when NCYCLE > 1 inner cycles are needed, +C or for sequential processing with connected blocks. +C LDRWMX is the number of rows that can fit in the working space. +C LDRWRK is the actual number of rows processed in this space. +C NSLAST is the number of samples to be processed at the last +C inner cycle. +C + INITI = 0 + LDRWMX = LDWORK / NR - 2 + NCYCLE = 1 + NSLAST = NSMP + LINR = .FALSE. + IF ( FIRST ) THEN + LINR = LDR.GE.NS + LDRWRK = NS + ELSE IF ( CONNEC ) THEN + LDRWRK = NSMP + ELSE + LDRWRK = NS + END IF + INICYC = 1 +C + IF ( .NOT.LINR ) THEN + IF ( LDRWMX.LT.LDRWRK ) THEN +C +C Not enough working space for doing a single inner cycle. +C NCYCLE inner cycles are to be performed for the current +C data block using the working space. +C + NCYCLE = LDRWRK / LDRWMX + NSLAST = MOD( LDRWRK, LDRWMX ) + IF ( NSLAST.NE.0 ) THEN + NCYCLE = NCYCLE + 1 + ELSE + NSLAST = LDRWMX + END IF + LDRWRK = LDRWMX + NS = LDRWRK + IF ( FIRST ) INICYC = 2 + END IF + MLDRW = M*LDRWRK + LLDRW = L*LDRWRK + INU = MLDRW*NOBR + 1 + INY = MLDRW*NOBR2 + 1 + END IF +C +C Process the data given at the current call. +C + IF ( .NOT.FIRST .AND. CONNEC ) THEN +C +C Restore the saved (M+L)*(2*NOBR-1) "connection" elements of +C U and Y into their appropriate position in sequential +C processing. The process is performed column-wise, in +C reverse order, first for Y and then for U. +C + IREV = NR - M - L - NOBR21 + 1 + ICOL = INY + LLDRW - LDRWRK +C + DO 380 J = 1, L + DO 375 I = NOBR21 - 1, 0, -1 + DWORK(ICOL+I) = DWORK(IREV+I) + 375 CONTINUE + IREV = IREV - NOBR21 + ICOL = ICOL - LDRWRK + 380 CONTINUE +C + IF( MOESP ) THEN + ICOL = INU + MLDRW - LDRWRK + ELSE + ICOL = MLDRW - LDRWRK + 1 + END IF +C + DO 390 J = 1, M + DO 385 I = NOBR21 - 1, 0, -1 + DWORK(ICOL+I) = DWORK(IREV+I) + 385 CONTINUE + IREV = IREV - NOBR21 + ICOL = ICOL - LDRWRK + 390 CONTINUE +C + IF( MOESP ) + $ CALL DLACPY( 'Full', NOBRM1, M, DWORK(INU+NOBR), LDRWRK, + $ DWORK, LDRWRK ) + END IF +C +C Data compression using QR factorization. +C + IF ( FIRST ) THEN +C +C Non-sequential data processing or first block in +C sequential data processing: +C Use the general QR factorization algorithm. +C + IF ( LINR ) THEN +C +C Put the input-output data in the array R. +C + IF( M.GT.0 ) THEN + IF( MOESP ) THEN +C + DO 400 I = 1, NOBR + CALL DLACPY( 'Full', NS, M, U(NOBR+I,1), LDU, + $ R(1,M*(I-1)+1), LDR ) + 400 CONTINUE +C + DO 410 I = 1, NOBR + CALL DLACPY( 'Full', NS, M, U(I,1), LDU, + $ R(1,MNOBR+M*(I-1)+1), LDR ) + 410 CONTINUE +C + ELSE +C + DO 420 I = 1, NOBR2 + CALL DLACPY( 'Full', NS, M, U(I,1), LDU, + $ R(1,M*(I-1)+1), LDR ) + 420 CONTINUE +C + END IF + END IF +C + DO 430 I = 1, NOBR2 + CALL DLACPY( 'Full', NS, L, Y(I,1), LDY, + $ R(1,MMNOBR+L*(I-1)+1), LDR ) + 430 CONTINUE +C +C Workspace: need 4*(M+L)*NOBR, +C prefer 2*(M+L)*NOBR+2*(M+L)*NOBR*NB. +C + ITAU = 1 + JWORK = ITAU + NR + CALL DGEQRF( NS, NR, R, LDR, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + ELSE +C +C Put the input-output data in the array DWORK. +C + IF( M.GT.0 ) THEN + ISHFTU = 1 + IF( MOESP ) THEN + ISHFT2 = INU +C + DO 440 I = 1, NOBR + CALL DLACPY( 'Full', NS, M, U(NOBR+I,1), LDU, + $ DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 440 CONTINUE +C + DO 450 I = 1, NOBR + CALL DLACPY( 'Full', NS, M, U(I,1), LDU, + $ DWORK(ISHFT2), LDRWRK ) + ISHFT2 = ISHFT2 + MLDRW + 450 CONTINUE +C + ELSE +C + DO 460 I = 1, NOBR2 + CALL DLACPY( 'Full', NS, M, U(I,1), LDU, + $ DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 460 CONTINUE +C + END IF + END IF +C + ISHFTY = INY +C + DO 470 I = 1, NOBR2 + CALL DLACPY( 'Full', NS, L, Y(I,1), LDY, + $ DWORK(ISHFTY), LDRWRK ) + ISHFTY = ISHFTY + LLDRW + 470 CONTINUE +C +C Workspace: need 2*(M+L)*NOBR + 4*(M+L)*NOBR, +C prefer NS*2*(M+L)*NOBR + 2*(M+L)*NOBR +C + 2*(M+L)*NOBR*NB, +C used LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR, +C where NS = NSMP - 2*NOBR + 1, +C LDRWRK = min(NS, LDWORK/(2*(M+L)*NOBR)-2). +C + ITAU = LDRWRK*NR + 1 + JWORK = ITAU + NR + CALL DGEQRF( NS, NR, DWORK, LDRWRK, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + CALL DLACPY( 'Upper ', MIN(NS,NR), NR, DWORK, LDRWRK, R, + $ LDR ) + END IF +C + IF ( NS.LT.NR ) + $ CALL DLASET( 'Upper ', NR - NS, NR - NS, ZERO, ZERO, + $ R(NS+1,NS+1), LDR ) + INITI = INITI + NS + END IF +C + IF ( NCYCLE.GT.1 .OR. .NOT.FIRST ) THEN +C +C Remaining segments of the first data block or +C remaining segments/blocks in sequential data processing: +C Use a structure-exploiting QR factorization algorithm. +C + NSL = LDRWRK + IF ( .NOT.CONNEC ) NSL = NS + ITAU = LDRWRK*NR + 1 + JWORK = ITAU + NR +C + DO 560 NICYCL = INICYC, NCYCLE +C +C INIT denotes the beginning row where new data are put. +C + IF ( CONNEC .AND. NICYCL.EQ.1 ) THEN + INIT = NOBR2 + ELSE + INIT = 1 + END IF + IF ( NCYCLE.GT.1 .AND. NICYCL.EQ.NCYCLE ) THEN +C +C Last samples in the last data segment of a block. +C + NS = NSLAST + NSL = NSLAST + END IF +C +C Put the input-output data in the array DWORK. +C + NSF = NS + IF ( INIT.GT.1 .AND. NCYCLE.GT.1 ) NSF = NSF - NOBR21 + IF ( M.GT.0 ) THEN + ISHFTU = INIT +C + IF( MOESP ) THEN + ISHFT2 = INIT + INU - 1 +C + DO 480 I = 1, NOBR + CALL DLACPY( 'Full', NSF, M, U(INITI+NOBR+I,1), + $ LDU, DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 480 CONTINUE +C + DO 490 I = 1, NOBR + CALL DLACPY( 'Full', NSF, M, U(INITI+I,1), LDU, + $ DWORK(ISHFT2), LDRWRK ) + ISHFT2 = ISHFT2 + MLDRW + 490 CONTINUE +C + ELSE +C + DO 500 I = 1, NOBR2 + CALL DLACPY( 'Full', NSF, M, U(INITI+I,1), LDU, + $ DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 500 CONTINUE +C + END IF + END IF +C + ISHFTY = INIT + INY - 1 +C + DO 510 I = 1, NOBR2 + CALL DLACPY( 'Full', NSF, L, Y(INITI+I,1), LDY, + $ DWORK(ISHFTY), LDRWRK ) + ISHFTY = ISHFTY + LLDRW + 510 CONTINUE +C + IF ( INIT.GT.1 ) THEN +C +C Prepare the connection to the previous block of data +C in sequential processing. +C + IF( MOESP .AND. M.GT.0 ) + $ CALL DLACPY( 'Full', NOBR, M, U, LDU, DWORK(NOBR), + $ LDRWRK ) +C +C Shift the elements from the connection to the previous +C block of data in sequential processing. +C + IF ( M.GT.0 ) THEN + ISHFTU = MLDRW + 1 +C + IF( MOESP ) THEN + ISHFT2 = MLDRW + INU +C + DO 520 I = 1, NOBRM1 + CALL DLACPY( 'Full', NOBR21, M, + $ DWORK(ISHFTU-MLDRW+1), LDRWRK, + $ DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 520 CONTINUE +C + DO 530 I = 1, NOBRM1 + CALL DLACPY( 'Full', NOBR21, M, + $ DWORK(ISHFT2-MLDRW+1), LDRWRK, + $ DWORK(ISHFT2), LDRWRK ) + ISHFT2 = ISHFT2 + MLDRW + 530 CONTINUE +C + ELSE +C + DO 540 I = 1, NOBR21 + CALL DLACPY( 'Full', NOBR21, M, + $ DWORK(ISHFTU-MLDRW+1), LDRWRK, + $ DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 540 CONTINUE +C + END IF + END IF +C + ISHFTY = LLDRW + INY +C + DO 550 I = 1, NOBR21 + CALL DLACPY( 'Full', NOBR21, L, + $ DWORK(ISHFTY-LLDRW+1), LDRWRK, + $ DWORK(ISHFTY), LDRWRK ) + ISHFTY = ISHFTY + LLDRW + 550 CONTINUE +C + END IF +C +C Workspace: need LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR. +C + CALL MB04OD( 'Full', NR, 0, NSL, R, LDR, DWORK, LDRWRK, + $ DUM, NR, DUM, NR, DWORK(ITAU), DWORK(JWORK) + $ ) + INITI = INITI + NSF + 560 CONTINUE +C + END IF +C + IF ( .NOT.LAST ) THEN + IF ( CONNEC ) THEN +C +C For sequential processing with connected data blocks, +C save the remaining ("connection") elements of U and Y +C in the first (M+L)*(2*NOBR-1) locations of DWORK. +C + IF ( M.GT.0 ) + $ CALL DLACPY( 'Full', NOBR21, M, U(INITI+1,1), LDU, + $ DWORK, NOBR21 ) + CALL DLACPY( 'Full', NOBR21, L, Y(INITI+1,1), LDY, + $ DWORK(MMNOBR-M+1), NOBR21 ) + END IF +C +C Return to get new data. +C + ICYCLE = ICYCLE + 1 + IF ( ICYCLE.LE.MAXCYC ) + $ RETURN + IWARN = 1 + ICYCLE = 1 +C + END IF +C + END IF +C +C Return optimal workspace in DWORK(1). +C + DWORK( 1 ) = MAXWRK + IF ( LAST ) THEN + ICYCLE = 1 + MAXWRK = 1 + NSMPSM = 0 + END IF + RETURN +C +C *** Last line of IB01MD *** + END diff --git a/mex/sources/libslicot/IB01MY.f b/mex/sources/libslicot/IB01MY.f new file mode 100644 index 000000000..a76f452a3 --- /dev/null +++ b/mex/sources/libslicot/IB01MY.f @@ -0,0 +1,1094 @@ + SUBROUTINE IB01MY( METH, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU, + $ Y, LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct an upper triangular factor R of the concatenated +C block Hankel matrices using input-output data, via a fast QR +C algorithm based on displacement rank. The input-output data can, +C optionally, be processed sequentially. +C +C ARGUMENTS +C +C Mode Parameters +C +C METH CHARACTER*1 +C Specifies the subspace identification method to be used, +C as follows: +C = 'M': MOESP algorithm with past inputs and outputs; +C = 'N': N4SID algorithm. +C +C BATCH CHARACTER*1 +C Specifies whether or not sequential data processing is to +C be used, and, for sequential processing, whether or not +C the current data block is the first block, an intermediate +C block, or the last block, as follows: +C = 'F': the first block in sequential data processing; +C = 'I': an intermediate block in sequential data +C processing; +C = 'L': the last block in sequential data processing; +C = 'O': one block only (non-sequential data processing). +C NOTE that when 100 cycles of sequential data processing +C are completed for BATCH = 'I', a warning is +C issued, to prevent for an infinite loop. +C +C CONCT CHARACTER*1 +C Specifies whether or not the successive data blocks in +C sequential data processing belong to a single experiment, +C as follows: +C = 'C': the current data block is a continuation of the +C previous data block and/or it will be continued +C by the next data block; +C = 'N': there is no connection between the current data +C block and the previous and/or the next ones. +C This parameter is not used if BATCH = 'O'. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the input and output +C block Hankel matrices to be processed. NOBR > 0. +C (In the MOESP theory, NOBR should be larger than n, the +C estimated dimension of state vector.) +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C When M = 0, no system inputs are processed. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C NSMP (input) INTEGER +C The number of rows of matrices U and Y (number of +C samples, t). (When sequential data processing is used, +C NSMP is the number of samples of the current data +C block.) +C NSMP >= 2*(M+L+1)*NOBR - 1, for non-sequential +C processing; +C NSMP >= 2*NOBR, for sequential processing. +C The total number of samples when calling the routine with +C BATCH = 'L' should be at least 2*(M+L+1)*NOBR - 1. +C The NSMP argument may vary from a cycle to another in +C sequential data processing, but NOBR, M, and L should +C be kept constant. For efficiency, it is advisable to use +C NSMP as large as possible. +C +C U (input) DOUBLE PRECISION array, dimension (LDU,M) +C The leading NSMP-by-M part of this array must contain the +C t-by-m input-data sequence matrix U, +C U = [u_1 u_2 ... u_m]. Column j of U contains the +C NSMP values of the j-th input component for consecutive +C time increments. +C If M = 0, this array is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= NSMP, if M > 0; +C LDU >= 1, if M = 0. +C +C Y (input) DOUBLE PRECISION array, dimension (LDY,L) +C The leading NSMP-by-L part of this array must contain the +C t-by-l output-data sequence matrix Y, +C Y = [y_1 y_2 ... y_l]. Column j of Y contains the +C NSMP values of the j-th output component for consecutive +C time increments. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= NSMP. +C +C R (output) DOUBLE PRECISION array, dimension +C ( LDR,2*(M+L)*NOBR ) +C If INFO = 0 and BATCH = 'L' or 'O', the leading +C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this +C array contains the upper triangular factor R from the +C QR factorization of the concatenated block Hankel +C matrices. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= 2*(M+L)*NOBR. +C +C Workspace +C +C IWORK INTEGER array, dimension (M+L) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -16, DWORK(1) returns the minimum +C value of LDWORK. +C The first (M+L)*2*NOBR*(M+L+c) elements of DWORK should +C be preserved during successive calls of the routine +C with BATCH = 'F' or 'I', till the final call with +C BATCH = 'L', where +C c = 1, if the successive data blocks do not belong to a +C single experiment (CONCT = 'N'); +C c = 2, if the successive data blocks belong to a single +C experiment (CONCT = 'C'). +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= (M+L)*2*NOBR*(M+L+3), +C if BATCH <> 'O' and CONCT = 'C'; +C LDWORK >= (M+L)*2*NOBR*(M+L+1), +C if BATCH = 'F' or 'I' and CONCT = 'N'; +C LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, +C if BATCH = 'L' and CONCT = 'N', +C or BATCH = 'O'. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: the number of 100 cycles in sequential data +C processing has been exhausted without signaling +C that the last block of data was get. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the fast QR factorization algorithm failed. The +C matrix H'*H is not (numerically) positive definite. +C +C METHOD +C +C Consider the t x 2(m+l)s matrix H of concatenated block Hankel +C matrices +C +C H = [ Uf' Up' Y' ], for METH = 'M', +C s+1,2s,t 1,s,t 1,2s,t +C +C H = [ U' Y' ], for METH = 'N', +C 1,2s,t 1,2s,t +C +C where Up , Uf , U , and Y are block +C 1,s,t s+1,2s,t 1,2s,t 1,2s,t +C Hankel matrices defined in terms of the input and output data [3]. +C The fast QR algorithm uses a factorization of H'*H which exploits +C the block-Hankel structure, via a displacement rank technique [5]. +C +C REFERENCES +C +C [1] Verhaegen M., and Dewilde, P. +C Subspace Model Identification. Part 1: The output-error +C state-space model identification class of algorithms. +C Int. J. Control, 56, pp. 1187-1210, 1992. +C +C [2] Verhaegen M. +C Subspace Model Identification. Part 3: Analysis of the +C ordinary output-error state-space model identification +C algorithm. +C Int. J. Control, 58, pp. 555-586, 1993. +C +C [3] Verhaegen M. +C Identification of the deterministic part of MIMO state space +C models given in innovations form from input-output data. +C Automatica, Vol.30, No.1, pp.61-74, 1994. +C +C [4] Van Overschee, P., and De Moor, B. +C N4SID: Subspace Algorithms for the Identification of +C Combined Deterministic-Stochastic Systems. +C Automatica, Vol.30, No.1, pp. 75-93, 1994. +C +C [5] Kressner, D., Mastronardi, N., Sima, V., Van Dooren, P., and +C Van Huffel, S. +C A Fast Algorithm for Subspace State-space System +C Identification via Exploitation of the Displacement Structure. +C J. Comput. Appl. Math., Vol.132, No.1, pp. 71-81, 2001. +C +C NUMERICAL ASPECTS +C +C The implemented method is reliable and efficient. Numerical +C difficulties are possible when the matrix H'*H is nearly rank +C defficient. The method cannot be used if the matrix H'*H is not +C numerically positive definite. +C 2 3 2 +C The algorithm requires 0(2t(m+l) s)+0(4(m+l) s ) floating point +C operations. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Universiteit Leuven, June 2000. +C Partly based on Matlab codes developed by N. Mastronardi, +C Katholieke Universiteit Leuven, February 2000. +C +C REVISIONS +C +C V. Sima, July 2000, August 2000, Feb. 2004, May 2009. +C +C KEYWORDS +C +C Displacement rank, Hankel matrix, Householder transformation, +C identification methods, multivariable systems. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + INTEGER MAXCYC + PARAMETER ( MAXCYC = 100 ) +C .. Scalar Arguments .. + INTEGER INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, NOBR, + $ NSMP + CHARACTER BATCH, CONCT, METH +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION DWORK(*), R(LDR, *), U(LDU, *), Y(LDY, *) +C .. Local Scalars .. + DOUBLE PRECISION BETA, CS, SN, UPD, TAU + INTEGER I, ICJ, ICOL, ICONN, ICYCLE, IERR, IMAX, ING, + $ INGC, INGP, IPG, IPGC, IPY, IREV, ITAU, J, JD, + $ JDS, JWORK, K, LDRWRK, LLNOBR, LNOBR, LNRG, + $ MAXWRK, MINWRK, MMNOBR, MNOBR, MNRG, NOBR2, + $ NOBR21, NR, NRG, NS, NSM, NSMPSM + LOGICAL CONNEC, FIRST, INTERM, LAST, MOESP, N4SID, + $ ONEBCH +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + EXTERNAL IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEQRF, DLACPY, DLARF, DLARFG, + $ DLASET, DORMQR, DSCAL, DSWAP, DSYRK, MA02ED, + $ MA02FD, MB04ID, MB04OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX, SQRT +C .. Save Statement .. +C ICYCLE is used to count the cycles for BATCH = 'I'. +C MAXWRK is used to store the optimal workspace. +C NSMPSM is used to sum up the NSMP values for BATCH <> 'O'. + SAVE ICYCLE, MAXWRK, NSMPSM +C .. +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MOESP = LSAME( METH, 'M' ) + N4SID = LSAME( METH, 'N' ) + ONEBCH = LSAME( BATCH, 'O' ) + FIRST = LSAME( BATCH, 'F' ) .OR. ONEBCH + INTERM = LSAME( BATCH, 'I' ) + LAST = LSAME( BATCH, 'L' ) .OR. ONEBCH + IF( .NOT.ONEBCH ) THEN + CONNEC = LSAME( CONCT, 'C' ) + ELSE + CONNEC = .FALSE. + END IF + MNOBR = M*NOBR + LNOBR = L*NOBR + MMNOBR = MNOBR + MNOBR + LLNOBR = LNOBR + LNOBR + NOBR2 = 2*NOBR + NOBR21 = NOBR2 - 1 + IWARN = 0 + INFO = 0 + IF( FIRST ) THEN + ICYCLE = 1 + MAXWRK = 1 + NSMPSM = 0 + END IF + NSMPSM = NSMPSM + NSMP + NR = MMNOBR + LLNOBR +C +C Check the scalar input parameters. +C + IF( .NOT.( MOESP .OR. N4SID ) ) THEN + INFO = -1 + ELSE IF( .NOT.( FIRST .OR. INTERM .OR. LAST ) ) THEN + INFO = -2 + ELSE IF( .NOT. ONEBCH ) THEN + IF( .NOT.( CONNEC .OR. LSAME( CONCT, 'N' ) ) ) + $ INFO = -3 + END IF + IF( INFO.EQ.0 ) THEN + IF( NOBR.LE.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( L.LE.0 ) THEN + INFO = -6 + ELSE IF( NSMP.LT.NOBR2 .OR. + $ ( LAST .AND. NSMPSM.LT.NR+NOBR21 ) ) THEN + INFO = -7 + ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN + INFO = -9 + ELSE IF( LDY.LT.NSMP ) THEN + INFO = -11 + ELSE IF( LDR.LT.NR ) THEN + INFO = -13 + ELSE +C +C Compute workspace. +C NRG is the number of positive (or negative) generators. +C + NRG = M + L + 1 + IF ( .NOT.ONEBCH .AND. CONNEC ) THEN + MINWRK = NR*( NRG + 2 ) + ELSE IF ( FIRST .OR. INTERM ) THEN + MINWRK = NR*NRG + ELSE + MINWRK = 2*NR*NRG + NR + END IF + MAXWRK = MAX( MINWRK, MAXWRK ) +C + IF( LDWORK.LT.MINWRK ) + $ INFO = -16 + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + NSMPSM = 0 + IF ( INFO.EQ.-16 ) + $ DWORK( 1 ) = MINWRK + CALL XERBLA( 'IB01MY', -INFO ) + RETURN + END IF +C +C Compute the R factor from a fast QR factorization of the +C matrix H, a concatenation of two block Hankel matrices. +C Specifically, a displacement rank technique is applied to +C the block Toeplitz matrix, G = (P*H)'*(P*H), where P is a +C 2-by-2 block diagonal matrix, having as diagonal blocks identity +C matrices with columns taken in the reverse order. +C The technique builds and processes the generators of G. The +C matrices G and G1 = H'*H have the same R factor. +C +C Set the parameters for constructing the correlations of the +C current block. +C NSM is the number of processed samples in U and Y, t - 2s. +C IPG and ING are pointers to the "positive" and "negative" +C generators, stored row-wise in the workspace. All "positive" +C generators are stored before any "negative" generators. +C If BATCH <> 'O' and CONCT = 'C', the "connection" elements of +C two successive batches are stored in the same workspace as the +C "negative" generators (which will be computed later on). +C IPY is a pointer to the Y part of the "positive" generators. +C LDRWRK is used as a leading dimension for the workspace part used +C to store the "connection" elements. +C + NS = NSMP - NOBR21 + NSM = NS - 1 + MNRG = M*NRG + LNRG = L*NRG +C + LDRWRK = 2*NOBR2 + IF( FIRST ) THEN + UPD = ZERO + ELSE + UPD = ONE + END IF + DUM(1) = ZERO +C + IPG = 1 + IPY = IPG + M + ING = IPG + NRG*NR + ICONN = ING +C + IF( .NOT.FIRST .AND. CONNEC ) THEN +C +C Restore the saved (M+L)*2*NOBR "connection" elements of +C U and Y into their appropriate position in sequential +C processing. The process is performed column-wise, in +C reverse order, first for Y and then for U. +C ICONN is a pointer to the first saved "connection" element. +C Workspace: need (M+L)*2*NOBR*(M+L+3). +C + IREV = ICONN + NR + ICOL = ICONN + 2*NR +C + DO 10 I = 2, M + L + IREV = IREV - NOBR2 + ICOL = ICOL - LDRWRK + CALL DCOPY( NOBR2, DWORK(IREV), 1, DWORK(ICOL), 1 ) + 10 CONTINUE +C + IF ( M.GT.0 ) + $ CALL DLACPY( 'Full', NOBR2, M, U, LDU, DWORK(ICONN+NOBR2), + $ LDRWRK ) + CALL DLACPY( 'Full', NOBR2, L, Y, LDY, + $ DWORK(ICONN+LDRWRK*M+NOBR2), LDRWRK ) + END IF +C + IF ( M.GT.0 ) THEN +C +C Let Guu(i,j) = Guu0(i,j) + u_i*u_j' + u_(i+1)*u_(j+1)' + +C ... + u_(i+NSM-1)*u_(j+NSM-1)', +C where u_i' is the i-th row of U, j = 1 : 2s, i = 1 : j, +C NSM = NSMP - 2s, and Guu0(i,j) is a zero matrix for +C BATCH = 'O' or 'F', and it is the matrix Guu(i,j) computed +C till the current block for BATCH = 'I' or 'L'. The matrix +C Guu(i,j) is m-by-m, and Guu(j,j) is symmetric. The +C submatrices of the first block-row, Guu(1,j), are needed only. +C +C Compute/update Guu(1,1). +C + IF( .NOT.FIRST .AND. CONNEC ) + $ CALL DSYRK( 'Upper', 'Transpose', M, NOBR2, ONE, + $ DWORK(ICONN), LDRWRK, UPD, DWORK(IPG), NRG ) + CALL DSYRK( 'Upper', 'Transpose', M, NSM, ONE, U, LDU, UPD, + $ DWORK(IPG), NRG ) + CALL MA02ED( 'Upper', M, DWORK(IPG), NRG ) +C + JD = 1 +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 20 J = 2, NOBR2 + JD = JD + M +C +C Compute/update Guu(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NSM, ONE, + $ U, LDU, U(J,1), LDU, UPD, + $ DWORK(IPG+(JD-1)*NRG), NRG ) + 20 CONTINUE +C + ELSE +C + DO 30 J = 2, NOBR2 + JD = JD + M +C +C Compute/update Guu(1,j) for sequential processing +C with connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NOBR2, + $ ONE, DWORK(ICONN), LDRWRK, DWORK(ICONN+J-1), + $ LDRWRK, UPD, DWORK(IPG+(JD-1)*NRG), NRG ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NSM, ONE, + $ U, LDU, U(J,1), LDU, ONE, + $ DWORK(IPG+(JD-1)*NRG), NRG ) + 30 CONTINUE +C + END IF +C +C Let Guy(i,j) = Guy0(i,j) + u_i*y_j' + u_(i+1)*y_(j+1)' + +C ... + u_(i+NSM-1)*y_(j+NSM-1)', +C where u_i' is the i-th row of U, y_j' is the j-th row +C of Y, j = 1 : 2s, i = 1 : 2s, NSM = NSMP - 2s, and +C Guy0(i,j) is a zero matrix for BATCH = 'O' or 'F', and it +C is the matrix Guy(i,j) computed till the current block for +C BATCH = 'I' or 'L'. Guy(i,j) is m-by-L. The submatrices +C of the first block-row, Guy(1,j), as well as the transposes +C of the submatrices of the first block-column, i.e., Gyu(1,j), +C are needed only. +C + JD = MMNOBR + 1 +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 40 J = 1, NOBR2 +C +C Compute/update Guy(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NSM, ONE, + $ U, LDU, Y(J,1), LDY, UPD, + $ DWORK(IPG+(JD-1)*NRG), NRG ) + JD = JD + L + 40 CONTINUE +C + ELSE +C + DO 50 J = 1, NOBR2 +C +C Compute/update Guy(1,j) for sequential processing +C with connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR2, + $ ONE, DWORK(ICONN), LDRWRK, + $ DWORK(ICONN+LDRWRK*M+J-1), LDRWRK, UPD, + $ DWORK(IPG+(JD-1)*NRG), NRG ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NSM, ONE, + $ U, LDU, Y(J,1), LDY, ONE, + $ DWORK(IPG+(JD-1)*NRG), NRG ) + JD = JD + L + 50 CONTINUE +C + END IF +C +C Now, the first M "positive" generators have been built. +C Transpose Guy(1,1) in the first block of the Y part of the +C "positive" generators. +C + DO 60 J = 1, L + CALL DCOPY( M, DWORK(IPG+(MMNOBR+J-1)*NRG), 1, + $ DWORK(IPY+J-1), NRG ) + 60 CONTINUE +C + JD = 1 +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 70 J = 2, NOBR2 + JD = JD + M +C +C Compute/update Gyu(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NSM, ONE, + $ Y, LDY, U(J,1), LDU, UPD, + $ DWORK(IPY+(JD-1)*NRG), NRG ) + 70 CONTINUE +C + ELSE +C + DO 80 J = 2, NOBR2 + JD = JD + M +C +C Compute/update Gyu(1,j) for sequential processing +C with connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NOBR2, + $ ONE, DWORK(ICONN+LDRWRK*M), LDRWRK, + $ DWORK(ICONN+J-1), LDRWRK, UPD, + $ DWORK(IPY+(JD-1)*NRG), NRG ) + CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NSM, ONE, + $ Y, LDY, U(J,1), LDU, ONE, + $ DWORK(IPY+(JD-1)*NRG), NRG ) + 80 CONTINUE +C + END IF +C + END IF +C +C Let Gyy(i,j) = Gyy0(i,j) + y_i*y_i' + y_(i+1)*y_(i+1)' + ... + +C y_(i+NSM-1)*y_(i+NSM-1)', +C where y_i' is the i-th row of Y, j = 1 : 2s, i = 1 : j, +C NSM = NSMP - 2s, and Gyy0(i,j) is a zero matrix for +C BATCH = 'O' or 'F', and it is the matrix Gyy(i,j) computed till +C the current block for BATCH = 'I' or 'L'. Gyy(i,j) is L-by-L, +C and Gyy(j,j) is symmetric. The submatrices of the first +C block-row, Gyy(1,j), are needed only. +C + JD = MMNOBR + 1 +C +C Compute/update Gyy(1,1). +C + IF( .NOT.FIRST .AND. CONNEC ) + $ CALL DSYRK( 'Upper', 'Transpose', L, NOBR2, ONE, + $ DWORK(ICONN+LDRWRK*M), LDRWRK, UPD, + $ DWORK(IPY+MMNOBR*NRG), NRG ) + CALL DSYRK( 'Upper', 'Transpose', L, NSM, ONE, Y, LDY, UPD, + $ DWORK(IPY+MMNOBR*NRG), NRG ) + CALL MA02ED( 'Upper', L, DWORK(IPY+MMNOBR*NRG), NRG ) +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 90 J = 2, NOBR2 + JD = JD + L +C +C Compute/update Gyy(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NSM, ONE, Y, + $ LDY, Y(J,1), LDY, UPD, DWORK(IPY+(JD-1)*NRG), + $ NRG ) + 90 CONTINUE +C + ELSE +C + DO 100 J = 2, NOBR2 + JD = JD + L +C +C Compute/update Gyy(1,j) for sequential processing with +C connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NOBR2, ONE, + $ DWORK(ICONN+LDRWRK*M), LDRWRK, + $ DWORK(ICONN+LDRWRK*M+J-1), LDRWRK, UPD, + $ DWORK(IPY+(JD-1)*NRG), NRG ) + CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NSM, ONE, Y, + $ LDY, Y(J,1), LDY, ONE, DWORK(IPY+(JD-1)*NRG), + $ NRG ) + 100 CONTINUE +C + END IF +C + IF ( .NOT.LAST ) THEN + IF ( FIRST ) THEN +C +C For sequential processing, save the first 2*NOBR-1 rows of +C the first block of U and Y in the appropriate +C (M+L)*(2*NOBR-1) locations of DWORK starting at (1+M)*NRG. +C These will be used to construct the last negative generator. +C + JD = NRG + IF ( M.GT.0 ) THEN + CALL DCOPY( M, DUM, 0, DWORK(JD), NRG ) +C + DO 110 J = 1, NOBR21 + JD = JD + MNRG + CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) + 110 CONTINUE +C + JD = JD + MNRG + END IF + CALL DCOPY( L, DUM, 0, DWORK(JD), NRG ) +C + DO 120 J = 1, NOBR21 + JD = JD + LNRG + CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) + 120 CONTINUE +C + END IF +C + IF ( CONNEC ) THEN +C +C For sequential processing with connected data blocks, +C save the remaining ("connection") elements of U and Y +C in (M+L)*2*NOBR locations of DWORK starting at ICONN. +C + IF ( M.GT.0 ) + $ CALL DLACPY( 'Full', NOBR2, M, U(NS,1), LDU, + $ DWORK(ICONN), NOBR2 ) + CALL DLACPY( 'Full', NOBR2, L, Y(NS,1), LDY, + $ DWORK(ICONN+MMNOBR), NOBR2 ) + END IF +C +C Return to get new data. +C + ICYCLE = ICYCLE + 1 + IF ( ICYCLE.GT.MAXCYC ) + $ IWARN = 1 + RETURN + END IF +C + IF ( LAST ) THEN +C +C Try to compute the R factor. +C +C Scale the first M+L positive generators and set the first +C M+L negative generators. +C Workspace: need (M+L)*4*NOBR*(M+L+1)+M+L. +C + JWORK = NRG*2*NR + 1 + CALL DCOPY( M, DWORK(IPG), NRG+1, DWORK(JWORK), 1 ) + CALL DCOPY( L, DWORK(IPY+MMNOBR*NRG), NRG+1, DWORK(JWORK+M), + $ 1 ) +C + DO 130 I = 1, M + L + IWORK(I) = IDAMAX( M+L, DWORK(JWORK), 1 ) + DWORK(JWORK+IWORK(I)-1) = ZERO + 130 CONTINUE +C + DO 150 I = 1, M + L + IMAX = IWORK(I) + IF ( IMAX.LE.M ) THEN + ICOL = IMAX + ELSE + ICOL = MMNOBR - M + IMAX + END IF + BETA = SQRT( ABS( DWORK(IPG+IMAX-1+(ICOL-1)*NRG) ) ) + IF ( BETA.EQ.ZERO ) THEN +C +C Error exit. +C + INFO = 1 + RETURN + END IF + CALL DSCAL( NR, ONE / BETA, DWORK(IPG+IMAX-1), NRG ) + CALL DCOPY( NR, DWORK(IPG+IMAX-1), NRG, DWORK(ING+IMAX-1), + $ NRG ) + DWORK(IPG+IMAX-1+(ICOL-1)*NRG) = BETA + DWORK(ING+IMAX-1+(ICOL-1)*NRG) = ZERO +C + DO 140 J = I + 1, M + L + DWORK(IPG+IWORK(J)-1+(ICOL-1)*NRG) = ZERO + 140 CONTINUE +C + 150 CONTINUE +C +C Compute the last two generators. +C + IF ( .NOT.FIRST ) THEN +C +C For sequential processing, move the stored last negative +C generator. +C + CALL DCOPY( NR, DWORK(NRG), NRG, DWORK(ING+NRG-1), NRG ) + END IF +C + JD = NRG + IF ( M.GT.0 ) THEN +C + DO 160 J = NS, NSMP + CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) + JD = JD + MNRG + 160 CONTINUE +C + END IF +C + DO 170 J = NS, NSMP + CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) + JD = JD + LNRG + 170 CONTINUE +C + IF ( FIRST ) THEN + IF ( M.GT.0 ) THEN + CALL DCOPY( M, DUM, 0, DWORK(JD), NRG ) +C + DO 180 J = 1, NOBR21 + JD = JD + MNRG + CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) + 180 CONTINUE +C + JD = JD + MNRG + END IF + CALL DCOPY( L, DUM, 0, DWORK(JD), NRG ) +C + DO 190 J = 1, NOBR21 + JD = JD + LNRG + CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) + 190 CONTINUE +C + END IF +C + ITAU = JWORK + IPGC = IPG + MMNOBR*NRG +C + IF ( M.GT.0 ) THEN +C +C Process the input part of the generators. +C + JWORK = ITAU + M +C +C Reduce the first M columns of the matrix G1 of positive +C generators to an upper triangular form. +C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*M; +C prefer (M+L)*4*NOBR*(M+L+1)+M+M*NB. +C + INGC = ING + CALL DGEQRF( NRG, M, DWORK(IPG), NRG, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR; +C prefer (M+L)*4*NOBR*(M+L+1)+M+ +C ((M+L)*2*NOBR-M)*NB. +C + CALL DORMQR( 'Left', 'Transpose', NRG, NR-M, M, DWORK(IPG), + $ NRG, DWORK(ITAU), DWORK(IPG+MNRG), NRG, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Annihilate, column by column, the first M columns of the +C matrix G2 of negative generators, using Householder +C transformations and modified hyperbolic plane rotations. +C In the DLARF calls, ITAU is a pointer to the workspace +C array. +C + DO 210 J = 1, M + CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) + BETA = DWORK(INGC) + DWORK(INGC) = ONE + INGP = INGC + NRG + CALL DLARF( 'Left', NRG, NR-J, DWORK(INGC), 1, TAU, + $ DWORK(INGP), NRG, DWORK(ITAU) ) + DWORK(INGC) = BETA +C +C Compute the coefficients of the modified hyperbolic +C rotation. +C + CALL MA02FD( DWORK(IPG+(J-1)*(NRG+1)), DWORK(INGC), CS, + $ SN, IERR ) + IF( IERR.NE.0 ) THEN +C +C Error return: the matrix H'*H is not (numerically) +C positive definite. +C + INFO = 1 + RETURN + END IF +C + DO 200 I = J*NRG, ( NR - 1 )*NRG, NRG + DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - + $ SN * DWORK(ING+I) ) / CS + DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + + $ CS * DWORK(ING+I) + 200 CONTINUE +C + INGC = INGP + 210 CONTINUE +C +C Save one block row of R, and shift the generators for the +C calculation of the following row. +C + CALL DLACPY( 'Upper', M, NR, DWORK(IPG), NRG, R, LDR ) +C + DO 220 I = ( MMNOBR - M )*NRG, MNRG, -MNRG + CALL DLACPY( 'Full', M, M, DWORK(IPG+I-MNRG), NRG, + $ DWORK(IPG+I), NRG ) + 220 CONTINUE +C + DO 230 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG + CALL DLACPY( 'Full', M, L, DWORK(IPG+I-LNRG), NRG, + $ DWORK(IPG+I), NRG ) + 230 CONTINUE +C + CALL DLASET( 'Full', M, L, ZERO, ZERO, DWORK(IPGC), NRG ) +C +C Update the input part of generators using Schur algorithm. +C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*NOBR*(M+L)-M. +C + JDS = MNRG + ICOL = M +C + DO 280 K = 2, NOBR2 + CALL MB04OD( 'Full', M, NR-ICOL-M, L+1, DWORK(IPG+JDS), + $ NRG, DWORK(IPY+JDS), NRG, + $ DWORK(IPG+JDS+MNRG), NRG, + $ DWORK(IPY+JDS+MNRG), NRG, DWORK(ITAU), + $ DWORK(JWORK) ) +C + DO 250 J = 1, M + ICJ = ICOL + J + CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) + BETA = DWORK(INGC) + DWORK(INGC) = ONE + INGP = INGC + NRG + CALL DLARF( 'Left', NRG, NR-ICJ, DWORK(INGC), 1, TAU, + $ DWORK(INGP), NRG, DWORK(ITAU) ) + DWORK(INGC) = BETA +C +C Compute the coefficients of the modified hyperbolic +C rotation. +C + CALL MA02FD( DWORK(IPG+J-1+(ICJ-1)*NRG), DWORK(INGC), + $ CS, SN, IERR ) + IF( IERR.NE.0 ) THEN +C +C Error return: the matrix H'*H is not (numerically) +C positive definite. +C + INFO = 1 + RETURN + END IF +C + DO 240 I = ICJ*NRG, ( NR - 1 )*NRG, NRG + DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - + $ SN * DWORK(ING+I) ) / CS + DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + + $ CS * DWORK(ING+I) + 240 CONTINUE +C + INGC = INGP + 250 CONTINUE +C +C Save one block row of R, and shift the generators for the +C calculation of the following row. +C + CALL DLACPY( 'Upper', M, NR-ICOL, DWORK(IPG+JDS), NRG, + $ R(ICOL+1,ICOL+1), LDR ) + ICOL = ICOL + M +C + DO 260 I = ( MMNOBR - M )*NRG, ICOL*NRG, -MNRG + CALL DLACPY( 'Full', M, M, DWORK(IPG+I-MNRG), NRG, + $ DWORK(IPG+I), NRG ) + 260 CONTINUE +C + DO 270 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG + CALL DLACPY( 'Full', M, L, DWORK(IPG+I-LNRG), NRG, + $ DWORK(IPG+I), NRG ) + 270 CONTINUE +C + CALL DLASET( 'Full', M, L, ZERO, ZERO, DWORK(IPGC), NRG ) + JDS = JDS + MNRG + 280 CONTINUE +C + END IF +C +C Process the output part of the generators. +C + JWORK = ITAU + L +C +C Reduce the first L columns of the submatrix +C G1(1:M+L+1,2*M*NOBR+1:2*(M+L)*NOBR) to upper triangular form. +C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*L; +C prefer (M+L)*4*NOBR*(M+L+1)+L+L*NB. +C + INGC = ING + MMNOBR*NRG + CALL DGEQRF( NRG, L, DWORK(IPGC), NRG, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need (M+L)*4*NOBR*(M+L+1)+L*2*NOBR; +C prefer (M+L)*4*NOBR*(M+L+1)+L+(L*2*NOBR-L)*NB. +C + CALL DORMQR( 'Left', 'Transpose', NRG, LLNOBR-L, L, + $ DWORK(IPGC), NRG, DWORK(ITAU), DWORK(IPGC+LNRG), + $ NRG, DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Annihilate, column by column, the first L columns of the +C output part of the matrix G2 of negative generators, using +C Householder transformations and modified hyperbolic rotations. +C + DO 300 J = 1, L + CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) + BETA = DWORK(INGC) + DWORK(INGC) = ONE + INGP = INGC + NRG + CALL DLARF( 'Left', NRG, LLNOBR-J, DWORK(INGC), 1, TAU, + $ DWORK(INGP), NRG, DWORK(ITAU) ) + DWORK(INGC) = BETA +C +C Compute the coefficients of the modified hyperbolic +C rotation. +C + CALL MA02FD( DWORK(IPGC+(J-1)*(NRG+1)), DWORK(INGC), CS, SN, + $ IERR ) + IF( IERR.NE.0 ) THEN +C +C Error return: the matrix H'*H is not (numerically) +C positive definite. +C + INFO = 1 + RETURN + END IF +C + DO 290 I = ( J + MMNOBR )*NRG, ( NR - 1 )*NRG, NRG + DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - + $ SN * DWORK(ING+I) ) / CS + DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + + $ CS * DWORK(ING+I) + 290 CONTINUE +C + INGC = INGP + 300 CONTINUE +C +C Save one block row of R, and shift the generators for the +C calculation of the following row. +C + CALL DLACPY( 'Upper', L, LLNOBR, DWORK(IPGC), NRG, + $ R(MMNOBR+1,MMNOBR+1), LDR ) +C + DO 310 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG + CALL DLACPY( 'Full', L, L, DWORK(IPG+I-LNRG), NRG, + $ DWORK(IPG+I), NRG ) + 310 CONTINUE +C +C Update the output part of generators using the Schur algorithm. +C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*NOBR*L-L. +C + JDS = LNRG + ICOL = L +C + DO 350 K = 2, NOBR2 + CALL MB04OD( 'Full', L, LLNOBR-ICOL-L, M+1, DWORK(IPGC+JDS), + $ NRG, DWORK(IPGC+L+JDS), NRG, + $ DWORK(IPGC+JDS+LNRG), NRG, + $ DWORK(IPGC+L+JDS+LNRG), NRG, DWORK(ITAU), + $ DWORK(JWORK) ) +C + DO 330 J = 1, L + ICJ = ICOL + J + CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) + BETA = DWORK(INGC) + DWORK(INGC) = ONE + INGP = INGC + NRG + CALL DLARF( 'Left', NRG, LLNOBR-ICJ, DWORK(INGC), 1, + $ TAU, DWORK(INGP), NRG, DWORK(ITAU) ) + DWORK(INGC) = BETA +C +C Compute the coefficients of the modified hyperbolic +C rotation. +C + CALL MA02FD( DWORK(IPGC+J-1+(ICJ-1)*NRG), DWORK(INGC), + $ CS, SN, IERR ) + IF( IERR.NE.0 ) THEN +C +C Error return: the matrix H'*H is not (numerically) +C positive definite. +C + INFO = 1 + RETURN + END IF +C + DO 320 I = ( ICJ + MMNOBR )*NRG, ( NR - 1 )*NRG, NRG + DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - + $ SN * DWORK(ING+I) ) / CS + DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + + $ CS * DWORK(ING+I) + 320 CONTINUE +C + INGC = INGP + 330 CONTINUE +C +C Save one block row of R, and shift the generators for the +C calculation of the following row. +C + CALL DLACPY( 'Upper', L, LLNOBR-ICOL, DWORK(IPGC+JDS), NRG, + $ R(MMNOBR+ICOL+1,MMNOBR+ICOL+1), LDR ) +C + DO 340 I = ( NR - L )*NRG, ( MMNOBR + ICOL )*NRG, -LNRG + CALL DLACPY( 'Full', L, L, DWORK(IPG+I-LNRG), NRG, + $ DWORK(IPG+I), NRG ) + 340 CONTINUE +C + ICOL = ICOL + L + JDS = JDS + LNRG + 350 CONTINUE +C + IF ( MOESP .AND. M.GT.0 ) THEN +C +C For the MOESP algorithm, interchange the past and future +C input parts of the R factor, and compute the new R factor +C using a specialized QR factorization. A tailored fast +C QR factorization for the MOESP algorithm could be slightly +C more efficient. +C + DO 360 J = 1, MNOBR + CALL DSWAP( J, R(1,J), 1, R(1,MNOBR+J), 1 ) + CALL DCOPY( MNOBR, R(J+1,MNOBR+J), 1, R(J+1,J), 1 ) + CALL DCOPY( MMNOBR-J, DUM, 0, R(J+1,MNOBR+J), 1 ) + 360 CONTINUE +C +C Triangularize the first two block columns (using structure), +C and apply the transformation to the corresponding part of +C the remaining block columns. +C Workspace: need 2*(M+L)*NOBR. +C + ITAU = 1 + JWORK = ITAU + MMNOBR + CALL MB04ID( MMNOBR, MMNOBR, MNOBR-1, LLNOBR, R, LDR, + $ R(1,MMNOBR+1), LDR, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + END IF + END IF +C + NSMPSM = 0 + ICYCLE = 1 +C +C Return optimal workspace in DWORK(1). +C + DWORK( 1 ) = MAXWRK + MAXWRK = 1 + RETURN +C +C *** Last line of IB01MY *** + END diff --git a/mex/sources/libslicot/IB01ND.f b/mex/sources/libslicot/IB01ND.f new file mode 100644 index 000000000..ad315b4cd --- /dev/null +++ b/mex/sources/libslicot/IB01ND.f @@ -0,0 +1,731 @@ + SUBROUTINE IB01ND( METH, JOBD, NOBR, M, L, R, LDR, SV, TOL, IWORK, + $ DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find the singular value decomposition (SVD) giving the system +C order, using the triangular factor of the concatenated block +C Hankel matrices. Related preliminary calculations needed for +C computing the system matrices are also performed. +C +C ARGUMENTS +C +C Mode Parameters +C +C METH CHARACTER*1 +C Specifies the subspace identification method to be used, +C as follows: +C = 'M': MOESP algorithm with past inputs and outputs; +C = 'N': N4SID algorithm. +C +C JOBD CHARACTER*1 +C Specifies whether or not the matrices B and D should later +C be computed using the MOESP approach, as follows: +C = 'M': the matrices B and D should later be computed +C using the MOESP approach; +C = 'N': the matrices B and D should not be computed using +C the MOESP approach. +C This parameter is not relevant for METH = 'N'. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the input and output +C block Hankel matrices. NOBR > 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C R (input/output) DOUBLE PRECISION array, dimension +C ( LDR,2*(M+L)*NOBR ) +C On entry, the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper +C triangular part of this array must contain the upper +C triangular factor R from the QR factorization of the +C concatenated block Hankel matrices. Denote R_ij, +C i,j = 1:4, the ij submatrix of R, partitioned by +C M*NOBR, M*NOBR, L*NOBR, and L*NOBR rows and columns. +C On exit, if INFO = 0, the leading +C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this +C array contains the matrix S, the processed upper +C triangular factor R, as required by other subroutines. +C Specifically, let S_ij, i,j = 1:4, be the ij submatrix +C of S, partitioned by M*NOBR, L*NOBR, M*NOBR, and +C L*NOBR rows and columns. The submatrix S_22 contains +C the matrix of left singular vectors needed subsequently. +C Useful information is stored in S_11 and in the +C block-column S_14 : S_44. For METH = 'M' and JOBD = 'M', +C the upper triangular part of S_31 contains the upper +C triangular factor in the QR factorization of the matrix +C R_1c = [ R_12' R_22' R_11' ]', and S_12 contains the +C corresponding leading part of the transformed matrix +C R_2c = [ R_13' R_23' R_14' ]'. For METH = 'N', the +C subarray S_41 : S_43 contains the transpose of the +C matrix contained in S_14 : S_34. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= MAX( 2*(M+L)*NOBR, 3*M*NOBR ), +C for METH = 'M' and JOBD = 'M'; +C LDR >= 2*(M+L)*NOBR, for METH = 'M' and JOBD = 'N' or +C for METH = 'N'. +C +C SV (output) DOUBLE PRECISION array, dimension ( L*NOBR ) +C The singular values of the relevant part of the triangular +C factor from the QR factorization of the concatenated block +C Hankel matrices. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets TOL > 0, then the given value +C of TOL is used as a lower bound for the reciprocal +C condition number; an m-by-n matrix whose estimated +C condition number is less than 1/TOL is considered to +C be of full rank. If the user sets TOL <= 0, then an +C implicitly computed, default tolerance, defined by +C TOLDEF = m*n*EPS, is used instead, where EPS is the +C relative machine precision (see LAPACK Library routine +C DLAMCH). +C This parameter is not used for METH = 'M'. +C +C Workspace +C +C IWORK INTEGER array, dimension ((M+L)*NOBR) +C This parameter is not referenced for METH = 'M'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and, for METH = 'N', DWORK(2) and DWORK(3) +C contain the reciprocal condition numbers of the +C triangular factors of the matrices U_f and r_1 [6]. +C On exit, if INFO = -12, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( (2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR ), +C if METH = 'M' and JOBD = 'M'; +C LDWORK >= 5*L*NOBR, if METH = 'M' and JOBD = 'N'; +C LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N'. +C For good performance, LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 4: the least squares problems with coefficient matrix +C U_f, used for computing the weighted oblique +C projection (for METH = 'N'), have a rank-deficient +C coefficient matrix; +C = 5: the least squares problem with coefficient matrix +C r_1 [6], used for computing the weighted oblique +C projection (for METH = 'N'), has a rank-deficient +C coefficient matrix. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 2: the singular value decomposition (SVD) algorithm did +C not converge. +C +C METHOD +C +C A singular value decomposition (SVD) of a certain matrix is +C computed, which reveals the order n of the system as the number +C of "non-zero" singular values. For the MOESP approach, this matrix +C is [ R_24' R_34' ]' := R(ms+1:(2m+l)s,(2m+l)s+1:2(m+l)s), +C where R is the upper triangular factor R constructed by SLICOT +C Library routine IB01MD. For the N4SID approach, a weighted +C oblique projection is computed from the upper triangular factor R +C and its SVD is then found. +C +C REFERENCES +C +C [1] Verhaegen M., and Dewilde, P. +C Subspace Model Identification. Part 1: The output-error +C state-space model identification class of algorithms. +C Int. J. Control, 56, pp. 1187-1210, 1992. +C +C [2] Verhaegen M. +C Subspace Model Identification. Part 3: Analysis of the +C ordinary output-error state-space model identification +C algorithm. +C Int. J. Control, 58, pp. 555-586, 1993. +C +C [3] Verhaegen M. +C Identification of the deterministic part of MIMO state space +C models given in innovations form from input-output data. +C Automatica, Vol.30, No.1, pp.61-74, 1994. +C +C [4] Van Overschee, P., and De Moor, B. +C N4SID: Subspace Algorithms for the Identification of +C Combined Deterministic-Stochastic Systems. +C Automatica, Vol.30, No.1, pp. 75-93, 1994. +C +C [5] Van Overschee, P., and De Moor, B. +C Subspace Identification for Linear Systems: Theory - +C Implementation - Applications. +C Kluwer Academic Publishers, Boston/London/Dordrecht, 1996. +C +C [6] Sima, V. +C Subspace-based Algorithms for Multivariable System +C Identification. +C Studies in Informatics and Control, 5, pp. 335-344, 1996. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C 3 +C The algorithm requires 0(((m+l)s) ) floating point operations. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. +C +C REVISIONS +C +C Feb. 2000, Feb. 2001, Feb. 2004, March 2005. +C +C KEYWORDS +C +C Identification methods, multivariable systems, QR decomposition, +C singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, LDR, LDWORK, M, NOBR + CHARACTER JOBD, METH +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), R(LDR, *), SV(*) + INTEGER IWORK(*) +C .. Local Scalars .. + DOUBLE PRECISION EPS, RCOND1, RCOND2, SVLMAX, THRESH, TOLL + INTEGER I, IERR, ITAU, ITAU2, ITAU3, J, JWORK, LLMNOB, + $ LLNOBR, LMMNOB, LMNOBR, LNOBR, MAXWRK, MINWRK, + $ MMNOBR, MNOBR, NR, NR2, NR3, NR4, NRSAVE, RANK, + $ RANK1 + LOGICAL JOBDM, MOESP, N4SID +C .. Local Arrays .. + DOUBLE PRECISION DUM(1), SVAL(3) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEQRF, DLACPY, DLASET, DORMQR, DSWAP, + $ DTRCON, MA02AD, MB03OD, MB03UD, MB04ID, MB04IY, + $ MB04OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MOESP = LSAME( METH, 'M' ) + N4SID = LSAME( METH, 'N' ) + JOBDM = LSAME( JOBD, 'M' ) + MNOBR = M*NOBR + LNOBR = L*NOBR + LLNOBR = LNOBR + LNOBR + LMNOBR = LNOBR + MNOBR + MMNOBR = MNOBR + MNOBR + LMMNOB = MMNOBR + LNOBR + NR = LMNOBR + LMNOBR + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT.( MOESP .OR. N4SID ) ) THEN + INFO = -1 + ELSE IF( MOESP .AND. .NOT.( JOBDM .OR. LSAME( JOBD, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( NOBR.LE.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( L.LE.0 ) THEN + INFO = -5 + ELSE IF( LDR.LT.NR .OR. ( MOESP .AND. JOBDM .AND. + $ LDR.LT.3*MNOBR ) ) THEN + INFO = -7 + ELSE +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + MINWRK = 1 + IF ( LDWORK.GE.1 ) THEN + IF ( MOESP ) THEN + MINWRK = 5*LNOBR + IF ( JOBDM ) + $ MINWRK = MAX( MMNOBR - NOBR, LMNOBR, MINWRK ) + MAXWRK = LNOBR + LNOBR*ILAENV( 1, 'DGEQRF', ' ', LMNOBR, + $ LNOBR, -1, -1 ) + ELSE +C + MINWRK = MAX( MINWRK, 5*LMNOBR + 1 ) + MAXWRK = MAX( MNOBR + MNOBR*ILAENV( 1, 'DGEQRF', ' ', + $ MMNOBR, MNOBR, -1, -1 ), + $ MNOBR + LLNOBR*ILAENV( 1, 'DORMQR', 'LT', + $ MMNOBR, LLNOBR, MNOBR, -1 ) ) + MAXWRK = MAX( MAXWRK, MNOBR + LNOBR*ILAENV( 1, 'DORMQR', + $ 'LN', MMNOBR, LNOBR, MNOBR, + $ -1 ) ) + MAXWRK = MAX( MAXWRK, LNOBR + LNOBR*ILAENV( 1, 'DGEQRF', + $ ' ', LMMNOB, LNOBR, -1, -1 ) ) + END IF + MAXWRK = MAX( MINWRK, MAXWRK ) + END IF +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -12 + DWORK( 1 ) = MINWRK + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01ND', -INFO ) + RETURN + END IF +C +C Compute pointers to the needed blocks of R. +C + NR2 = MNOBR + 1 + NR3 = MMNOBR + 1 + NR4 = LMMNOB + 1 + ITAU = 1 + JWORK = ITAU + MNOBR +C + IF( MOESP ) THEN +C +C MOESP approach. +C + IF( M.GT.0 .AND. JOBDM ) THEN +C +C Rearrange the blocks of R: +C Copy the (1,1) block into the position (3,2) and +C copy the (1,4) block into (3,3). +C + CALL DLACPY( 'Upper', MNOBR, MNOBR, R, LDR, R(NR3,NR2), + $ LDR ) + CALL DLACPY( 'Full', MNOBR, LNOBR, R(1,NR4), LDR, + $ R(NR3,NR3), LDR ) +C +C Using structure, triangularize the matrix +C R_1c = [ R_12' R_22' R_11' ]' +C and then apply the transformations to the matrix +c R_2c = [ R_13' R_23' R_14' ]'. +C Workspace: need M*NOBR + MAX(M-1,L)*NOBR. +C + CALL MB04OD( 'Upper', MNOBR, LNOBR, MNOBR, R(NR2,NR2), LDR, + $ R(NR3,NR2), LDR, R(NR2,NR3), LDR, R(NR3,NR3), + $ LDR, DWORK(ITAU), DWORK(JWORK) ) + CALL MB04ID( MMNOBR, MNOBR, MNOBR-1, LNOBR, R(1,NR2), LDR, + $ R(1,NR3), LDR, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Copy the leading M*NOBR x M*NOBR and M*NOBR x L*NOBR +C submatrices of R_1c and R_2c, respectively, into their +C final positions, required by SLICOT Library routine IB01PD. +C + CALL DLACPY( 'Upper', MNOBR, MNOBR, R(1,NR2), LDR, + $ R(LMNOBR+1,1), LDR ) + CALL DLACPY( 'Full', MNOBR, LNOBR, R(1,NR3), LDR, R(1,NR2), + $ LDR ) + END IF +C +C Copy [ R_24' R_34' ]' in [ R_22' R_32' ]'. +C + CALL DLACPY( 'Full', LMNOBR, LNOBR, R(NR2,NR4), LDR, + $ R(NR2,NR2), LDR ) +C +C Triangularize the matrix in [ R_22' R_32' ]'. +C Workspace: need 2*L*NOBR; prefer L*NOBR + L*NOBR*NB. +C + JWORK = ITAU + LNOBR + CALL DGEQRF( LMNOBR, LNOBR, R(NR2,NR2), LDR, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C + ELSE +C +C N4SID approach. +C + DUM(1) = ZERO + LLMNOB = LLNOBR + MNOBR +C +C Set the precision parameters. A threshold value EPS**(2/3) is +C used for deciding to use pivoting or not, where EPS is the +C relative machine precision (see LAPACK Library routine DLAMCH). +C + TOLL = TOL + EPS = DLAMCH( 'Precision' ) + THRESH = EPS**( TWO/THREE ) +C + IF( M.GT.0 ) THEN +C +C For efficiency of later calculations, interchange the first +C two block-columns. The corresponding submatrices are +C redefined according to their new position. +C + DO 10 I = 1, MNOBR + CALL DSWAP( I, R(1,I), 1, R(1,MNOBR+I), 1 ) + CALL DCOPY( MNOBR, R(I+1,MNOBR+I), 1, R(I+1,I), 1 ) + CALL DCOPY( MMNOBR-I, DUM, 0, R(I+1,MNOBR+I), 1 ) + 10 CONTINUE +C +C Now, +C +C U_f = [ R_11' R_21' 0 0 ]', +C U_p = [ R_12' 0 0 0 ]', +C Y_p = [ R_13' R_23' R_33' 0 ]', and +C Y_f = [ R_14' R_24' R_34' R_44' ]', +C +C where R_21, R_12, R_33, and R_44 are upper triangular. +C Define W_p := [ U_p Y_p ]. +C +C Prepare the computation of residuals of the two least +C squares problems giving the weighted oblique projection P: +C +C r_1 = W_p - U_f X_1, X_1 = arg min || U_f X - W_p ||, +C r_2 = Y_f - U_f X_2, X_2 = arg min || U_f X - Y_f ||, +C +C P = (arg min || r_1 X - r_2 ||)' r_1'. (1) +C +C Alternately, P' is given by the projection +C P' = Q_1 (Q_1)' r_2, +C where Q_1 contains the first k columns of the orthogonal +C matrix in the QR factorization of r_1, k := rank(r_1). +C +C Triangularize the matrix U_f = q r (using structure), and +C apply the transformation q' to the corresponding part of +C the matrices W_p, and Y_f. +C Workspace: need 2*(M+L)*NOBR. +C + CALL MB04ID( MMNOBR, MNOBR, MNOBR-1, LLMNOB, R, LDR, + $ R(1,NR2), LDR, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Save updated Y_f (transposed) in the last block-row of R. +C + CALL MA02AD( 'Full', LMMNOB, LNOBR, R(1,NR4), LDR, R(NR4,1), + $ LDR ) +C +C Check the condition of the triangular factor r and decide +C to use pivoting or not. +C Workspace: need 4*M*NOBR. +C + CALL DTRCON( '1-norm', 'Upper', 'NonUnit', MNOBR, R, LDR, + $ RCOND1, DWORK(JWORK), IWORK, IERR ) +C + IF( TOLL.LE.ZERO ) + $ TOLL = MNOBR*MNOBR*EPS + IF ( RCOND1.GT.MAX( TOLL, THRESH ) ) THEN +C +C U_f is considered full rank and no pivoting is used. +C + CALL DLASET( 'Full', MNOBR, LLMNOB, ZERO, ZERO, R(1,NR2), + $ LDR ) + ELSE +C +C Save information about q in the (2,1) block of R. +C Use QR factorization with column pivoting, r P = Q R. +C Information on Q is stored in the strict lower triangle +C of R_11 and in DWORK(ITAU2). +C + DO 20 I = 1, MNOBR - 1 + DO 15 J = MMNOBR, NR2, -1 + R(J,I) = R(J-MNOBR+I,I) + 15 CONTINUE + CALL DCOPY( MNOBR-I, DUM, 0, R(I+1,I), 1 ) + IWORK(I) = 0 + 20 CONTINUE +C + IWORK(MNOBR) = 0 +C +C Workspace: need 5*M*NOBR+1. +C prefer 4*M*NOBR + (M*NOBR+1)*NB. +C + ITAU2 = JWORK + JWORK = ITAU2 + MNOBR + SVLMAX = ZERO + CALL MB03OD( 'QR', MNOBR, MNOBR, R, LDR, IWORK, TOLL, + $ SVLMAX, DWORK(ITAU2), RANK, SVAL, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need 2*M*NOBR + (M+2*L)*NOBR; +C prefer 2*M*NOBR + (M+2*L)*NOBR*NB. +C + CALL DORMQR( 'Left', 'Transpose', MNOBR, LLMNOB, MNOBR, + $ R, LDR, DWORK(ITAU2), R(1,NR2), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF ( RANK.LT.MNOBR ) THEN +C +C The least squares problem is rank-deficient. +C + IWARN = 4 + END IF +C +C Determine residuals r_1 and r_2: premultiply by Q and +C then by q. +C Workspace: need 2*M*NOBR + (M+2*L)*NOBR); +C prefer 2*M*NOBR + (M+2*L)*NOBR*NB. +C + CALL DLASET( 'Full', RANK, LLMNOB, ZERO, ZERO, R(1,NR2), + $ LDR ) + CALL DORMQR( 'Left', 'NoTranspose', MNOBR, LLMNOB, MNOBR, + $ R, LDR, DWORK(ITAU2), R(1,NR2), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + JWORK = ITAU2 +C +C Restore the transformation q. +C + DO 30 I = 1, MNOBR - 1 + DO 25 J = NR2, MMNOBR + R(J-MNOBR+I,I) = R(J,I) + 25 CONTINUE + 30 CONTINUE +C + END IF +C +C Premultiply by the transformation q (apply transformations +C in backward order). +C Workspace: need M*NOBR + (M+2*L)*NOBR; +C prefer larger. +C + CALL MB04IY( 'Left', 'NoTranspose', MMNOBR, LLMNOB, MNOBR, + $ MNOBR-1, R, LDR, DWORK(ITAU), R(1,NR2), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + ELSE +C +C Save Y_f (transposed) in the last block-row of R. +C + CALL MA02AD( 'Full', LMMNOB, LNOBR, R(1,NR4), LDR, R(NR4,1), + $ LDR ) + RCOND1 = ONE + END IF +C +C Triangularize the matrix r_1 for determining the oblique +C projection P in least squares problem in (1). Exploit the +C fact that the third block-row of r_1 has the structure +C [ 0 T ], where T is an upper triangular matrix. Then apply +C the corresponding transformations Q' to the matrix r_2. +C Workspace: need 2*M*NOBR; +C prefer M*NOBR + M*NOBR*NB. +C + CALL DGEQRF( MMNOBR, MNOBR, R(1,NR2), LDR, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Workspace: need M*NOBR + 2*L*NOBR; +C prefer M*NOBR + 2*L*NOBR*NB. +C + CALL DORMQR( 'Left', 'Transpose', MMNOBR, LLNOBR, MNOBR, + $ R(1,NR2), LDR, DWORK(ITAU), R(1,NR3), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + NRSAVE = NR2 +C + ITAU2 = JWORK + JWORK = ITAU2 + LNOBR + CALL MB04ID( LMNOBR, LNOBR, LNOBR-1, LNOBR, R(NR2,NR3), LDR, + $ R(NR2,NR4), LDR, DWORK(ITAU2), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Check the condition of the triangular matrix of order (m+l)*s +C just determined, and decide to use pivoting or not. +C Workspace: need 4*(M+L)*NOBR. +C + CALL DTRCON( '1-norm', 'Upper', 'NonUnit', LMNOBR, R(1,NR2), + $ LDR, RCOND2, DWORK(JWORK), IWORK, IERR ) +C + IF( TOL.LE.ZERO ) + $ TOLL = LMNOBR*LMNOBR*EPS + IF ( RCOND2.LE.MAX( TOLL, THRESH ) ) THEN + IF ( M.GT.0 ) THEN +C +C Save information about Q in R_11 (in the strict lower +C triangle), R_21 and R_31 (transposed information). +C + CALL DLACPY( 'Lower', MMNOBR-1, MNOBR, R(2,NR2), LDR, + $ R(2,1), LDR ) + NRSAVE = 1 +C + DO 40 I = NR2, LMNOBR + CALL DCOPY( MNOBR, R(I+1,MNOBR+I), 1, R(MNOBR+I,1), + $ LDR ) + 40 CONTINUE +C + END IF +C + CALL DLASET( 'Lower', LMNOBR-1, LMNOBR-1, ZERO, ZERO, + $ R(2,NR2), LDR ) +C +C Use QR factorization with column pivoting. +C Workspace: need 5*(M+L)*NOBR+1. +C prefer 4*(M+L)*NOBR + ((M+L)*NOBR+1)*NB. +C + DO 50 I = 1, LMNOBR + IWORK(I) = 0 + 50 CONTINUE +C + ITAU3 = JWORK + JWORK = ITAU3 + LMNOBR + SVLMAX = ZERO + CALL MB03OD( 'QR', LMNOBR, LMNOBR, R(1,NR2), LDR, IWORK, + $ TOLL, SVLMAX, DWORK(ITAU3), RANK1, SVAL, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need 2*(M+L)*NOBR + L*NOBR; +C prefer 2*(M+L)*NOBR + L*NOBR*NB. +C + CALL DORMQR( 'Left', 'Transpose', LMNOBR, LNOBR, LMNOBR, + $ R(1,NR2), LDR, DWORK(ITAU3), R(1,NR4), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF ( RANK1.LT.LMNOBR ) THEN +C +C The least squares problem is rank-deficient. +C + IWARN = 5 + END IF +C +C Apply the orthogonal transformations, in backward order, to +C [r_2(1:rank(r_1),:)' 0]', to obtain P'. +C Workspace: need 2*(M+L)*NOBR + L*NOBR; +C prefer 2*(M+L)*NOBR + L*NOBR*NB. +C + CALL DLASET( 'Full', LMNOBR-RANK1, LNOBR, ZERO, ZERO, + $ R(RANK1+1,NR4), LDR ) + CALL DORMQR( 'Left', 'NoTranspose', LMNOBR, LNOBR, LMNOBR, + $ R(1,NR2), LDR, DWORK(ITAU3), R(1,NR4), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + JWORK = ITAU3 +C + IF ( M.GT.0 ) THEN +C +C Restore the saved transpose matrix from R_31. +C + DO 60 I = NR2, LMNOBR + CALL DCOPY( MNOBR, R(MNOBR+I,1), LDR, R(I+1,MNOBR+I), + $ 1 ) + 60 CONTINUE +C + END IF +C + END IF +C +C Workspace: need M*NOBR + L*NOBR; +C prefer larger. +C + CALL MB04IY( 'Left', 'NoTranspose', LMNOBR, LNOBR, LNOBR, + $ LNOBR-1, R(NR2,NR3), LDR, DWORK(ITAU2), + $ R(NR2,NR4), LDR, DWORK(JWORK), LDWORK-JWORK+1, + $ IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need M*NOBR + L*NOBR; +C prefer M*NOBR + L*NOBR*NB. +C + JWORK = ITAU2 + CALL DORMQR( 'Left', 'NoTranspose', MMNOBR, LNOBR, MNOBR, + $ R(1,NRSAVE), LDR, DWORK(ITAU), R(1,NR4), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Now, the matrix P' is available in R_14 : R_34. +C Triangularize the matrix P'. +C Workspace: need 2*L*NOBR; +C prefer L*NOBR + L*NOBR*NB. +C + JWORK = ITAU + LNOBR + CALL DGEQRF( LMMNOB, LNOBR, R(1,NR4), LDR, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Copy the triangular factor to its final position, R_22. +C + CALL DLACPY( 'Upper', LNOBR, LNOBR, R(1,NR4), LDR, R(NR2,NR2), + $ LDR ) +C +C Restore Y_f. +C + CALL MA02AD( 'Full', LNOBR, LMMNOB, R(NR4,1), LDR, R(1,NR4), + $ LDR ) + END IF +C +C Find the singular value decomposition of R_22. +C Workspace: need 5*L*NOBR. +C + CALL MB03UD( 'NoVectors', 'Vectors', LNOBR, R(NR2,NR2), LDR, + $ DUM, 1, SV, DWORK, LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C +C Transpose R(m*s+1:(m+L)*s,m*s+1:(m+L)*s) in-situ; its +C columns will then be the singular vectors needed subsequently. +C + DO 70 I = NR2+1, LMNOBR + CALL DSWAP( LMNOBR-I+1, R(I,I-1), 1, R(I-1,I), LDR ) + 70 CONTINUE +C +C Return optimal workspace in DWORK(1) and reciprocal condition +C numbers, if METH = 'N'. +C + DWORK(1) = MAXWRK + IF ( N4SID ) THEN + DWORK(2) = RCOND1 + DWORK(3) = RCOND2 + END IF + RETURN +C +C *** Last line of IB01ND *** + END diff --git a/mex/sources/libslicot/IB01OD.f b/mex/sources/libslicot/IB01OD.f new file mode 100644 index 000000000..69d22c5ea --- /dev/null +++ b/mex/sources/libslicot/IB01OD.f @@ -0,0 +1,214 @@ + SUBROUTINE IB01OD( CTRL, NOBR, L, SV, N, TOL, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the system order, based on the singular values of the +C relevant part of the triangular factor of the concatenated block +C Hankel matrices. +C +C ARGUMENTS +C +C Mode Parameters +C +C CTRL CHARACTER*1 +C Specifies whether or not the user's confirmation of the +C system order estimate is desired, as follows: +C = 'C': user's confirmation; +C = 'N': no confirmation. +C If CTRL = 'C', a reverse communication routine, IB01OY, +C is called, and, after inspecting the singular values and +C system order estimate, n, the user may accept n or set +C a new value. +C IB01OY is not called by the routine if CTRL = 'N'. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the processed input and +C output block Hankel matrices. NOBR > 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C SV (input) DOUBLE PRECISION array, dimension ( L*NOBR ) +C The singular values of the relevant part of the triangular +C factor from the QR factorization of the concatenated block +C Hankel matrices. +C +C N (output) INTEGER +C The estimated order of the system. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Absolute tolerance used for determining an estimate of +C the system order. If TOL >= 0, the estimate is +C indicated by the index of the last singular value greater +C than or equal to TOL. (Singular values less than TOL +C are considered as zero.) When TOL = 0, an internally +C computed default value, TOL = NOBR*EPS*SV(1), is used, +C where SV(1) is the maximal singular value, and EPS is +C the relative machine precision (see LAPACK Library routine +C DLAMCH). When TOL < 0, the estimate is indicated by the +C index of the singular value that has the largest +C logarithmic gap to its successor. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 3: all singular values were exactly zero, hence N = 0. +C (Both input and output were identically zero.) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The singular values are compared to the given, or default TOL, and +C the estimated order n is returned, possibly after user's +C confirmation. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. +C +C REVISIONS +C +C August 2000. +C +C KEYWORDS +C +C Identification methods, multivariable systems, singular value +C decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, N, NOBR + CHARACTER CTRL +C .. Array Arguments .. + DOUBLE PRECISION SV(*) +C .. Local Scalars .. + DOUBLE PRECISION GAP, RNRM, TOLL + INTEGER I, IERR, LNOBR + LOGICAL CONTRL +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL IB01OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, LOG10 +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + CONTRL = LSAME( CTRL, 'C' ) + LNOBR = L*NOBR + IWARN = 0 + INFO = 0 + IF( .NOT.( CONTRL .OR. LSAME( CTRL, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( NOBR.LE.0 ) THEN + INFO = -2 + ELSE IF( L.LE.0 ) THEN + INFO = -3 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01OD', -INFO ) + RETURN + END IF +C +C Set TOL if necessay. +C + TOLL = TOL + IF ( TOLL.EQ.ZERO) + $ TOLL = DLAMCH( 'Precision' )*SV(1)*DBLE( NOBR ) +C +C Obtain the system order. +C + N = 0 + IF ( SV(1).NE.ZERO ) THEN + N = NOBR + IF ( TOLL.GE.ZERO) THEN +C +C Estimate n based on the tolerance TOLL. +C + DO 10 I = 1, NOBR - 1 + IF ( SV(I+1).LT.TOLL ) THEN + N = I + GO TO 30 + END IF + 10 CONTINUE + ELSE +C +C Estimate n based on the largest logarithmic gap between +C two consecutive singular values. +C + GAP = ZERO + DO 20 I = 1, NOBR - 1 + RNRM = SV(I+1) + IF ( RNRM.NE.ZERO ) THEN + RNRM = LOG10( SV(I) ) - LOG10( RNRM ) + IF ( RNRM.GT.GAP ) THEN + GAP = RNRM + N = I + END IF + ELSE + IF ( GAP.EQ.ZERO ) + $ N = I + GO TO 30 + END IF + 20 CONTINUE + END IF + END IF +C + 30 CONTINUE + IF ( N.EQ.0 ) THEN +C +C Return with N = 0 if all singular values are zero. +C + IWARN = 3 + RETURN + END IF +C + IF ( CONTRL ) THEN +C +C Ask confirmation of the system order. +C + CALL IB01OY( LNOBR, NOBR-1, N, SV, IERR ) + END IF + RETURN +C +C *** Last line of IB01OD *** + END diff --git a/mex/sources/libslicot/IB01OY.f b/mex/sources/libslicot/IB01OY.f new file mode 100644 index 000000000..1e475d751 --- /dev/null +++ b/mex/sources/libslicot/IB01OY.f @@ -0,0 +1,175 @@ + SUBROUTINE IB01OY( NS, NMAX, N, SV, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To ask for user's confirmation of the system order found by +C SLICOT Library routine IB01OD. This routine may be modified, +C but its interface must be preserved. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NS (input) INTEGER +C The number of singular values. NS > 0. +C +C NMAX (input) INTEGER +C The maximum value of the system order. 0 <= NMAX <= NS. +C +C N (input/output) INTEGER +C On entry, the estimate of the system order computed by +C IB01OD routine. 0 <= N <= NS. +C On exit, the user's estimate of the system order, which +C could be identical with the input value of N. +C Note that the output value of N should be less than +C or equal to NMAX. +C +C SV (input) DOUBLE PRECISION array, dimension ( NS ) +C The singular values, in descending order, used for +C determining the system order. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Identification, parameter estimation, singular values, structure +C identification. +C +C ********************************************************************* +C +C .. Parameters .. + INTEGER INTRMN, OUTRMN + PARAMETER ( INTRMN = 5, OUTRMN = 6 ) +C INTRMN is the unit number for the (terminal) input device. +C OUTRMN is the unit number for the (terminal) output device. +C .. +C .. Scalar Arguments .. + INTEGER INFO, N, NMAX, NS +C .. +C .. Array Arguments .. + DOUBLE PRECISION SV( * ) +C .. +C .. Local Scalars .. + LOGICAL YES + INTEGER I + CHARACTER ANS +C .. +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. +C .. External Subroutines .. + EXTERNAL XERBLA +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + IF( NS.LE.0 ) THEN + INFO = -1 + ELSE IF( NMAX.LT.0 .OR. NMAX.GT.NS ) THEN + INFO = -2 + ELSE IF( N.LT.0 .OR. N.GT.NS ) THEN + INFO = -3 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01OY', -INFO ) + RETURN + END IF +C + WRITE( OUTRMN, '(/'' Singular values (in descending order) used'', + $ '' to estimate the system order:'', // + $ (5D15.8) )' ) ( SV(I), I = 1, NS ) + WRITE( OUTRMN, '(/'' Estimated order of the system, n = '', I5 )' + $ ) N + WRITE( OUTRMN, '(/'' Do you want this value of n to be used'', + $ '' to determine the system matrices?'' )' ) +C + 10 CONTINUE + WRITE( OUTRMN, '(/'' Type "yes" or "no": '' )' ) + READ ( INTRMN, '( A )' ) ANS + YES = LSAME( ANS, 'Y' ) + IF( YES ) THEN + IF( N.LE.NMAX ) THEN +C +C The value of n is adequate and has been confirmed. +C + RETURN + ELSE +C +C The estimated value of n is not acceptable. +C + WRITE( OUTRMN, '(/'' n should be less than or equal'', + $ '' to '', I5 )' ) NMAX + WRITE( OUTRMN, '( '' (It may be useful to restart'', + $ '' with a larger tolerance.)'' )' ) + GO TO 20 + END IF +C + ELSE IF( LSAME( ANS, 'N' ) ) THEN + GO TO 20 + ELSE +C +C Wrong answer should be re-entered. +C + GO TO 10 + END IF +C +C Enter the desired value of n. +C + 20 CONTINUE + WRITE( OUTRMN,'(/'' Enter the desired value of n (n <= '', I5, + $ ''); n = '' )' ) NMAX + READ ( INTRMN, * ) N + IF ( N.LT.0 ) THEN +C +C The specified value of n is not acceptable. +C + WRITE( OUTRMN, '(/'' n should be larger than zero.'' )' ) + GO TO 20 + ELSE IF ( N.GT.NMAX ) THEN +C +C The specified value of n is not acceptable. +C + WRITE( OUTRMN, '(/'' n should be less than or equal to '', + $ I5 )' ) NMAX + GO TO 20 + END IF +C + RETURN +C +C *** Last line of IB01OY *** + END diff --git a/mex/sources/libslicot/IB01PD.f b/mex/sources/libslicot/IB01PD.f new file mode 100644 index 000000000..45c3e0f11 --- /dev/null +++ b/mex/sources/libslicot/IB01PD.f @@ -0,0 +1,1232 @@ + SUBROUTINE IB01PD( METH, JOB, JOBCV, NOBR, N, M, L, NSMPL, R, + $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, + $ RY, LDRY, S, LDS, O, LDO, TOL, IWORK, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the matrices A, C, B, and D of a linear time-invariant +C (LTI) state space model, using the singular value decomposition +C information provided by other routines. Optionally, the system and +C noise covariance matrices, needed for the Kalman gain, are also +C determined. +C +C ARGUMENTS +C +C Mode Parameters +C +C METH CHARACTER*1 +C Specifies the subspace identification method to be used, +C as follows: +C = 'M': MOESP algorithm with past inputs and outputs; +C = 'N': N4SID algorithm. +C +C JOB CHARACTER*1 +C Specifies which matrices should be computed, as follows: +C = 'A': compute all system matrices, A, B, C, and D; +C = 'C': compute the matrices A and C only; +C = 'B': compute the matrix B only; +C = 'D': compute the matrices B and D only. +C +C JOBCV CHARACTER*1 +C Specifies whether or not the covariance matrices are to +C be computed, as follows: +C = 'C': the covariance matrices should be computed; +C = 'N': the covariance matrices should not be computed. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the input and output +C Hankel matrices processed by other routines. NOBR > 1. +C +C N (input) INTEGER +C The order of the system. NOBR > N > 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C NSMPL (input) INTEGER +C If JOBCV = 'C', the total number of samples used for +C calculating the covariance matrices. +C NSMPL >= 2*(M+L)*NOBR. +C This parameter is not meaningful if JOBCV = 'N'. +C +C R (input/workspace) DOUBLE PRECISION array, dimension +C ( LDR,2*(M+L)*NOBR ) +C On entry, the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR part +C of this array must contain the relevant data for the MOESP +C or N4SID algorithms, as constructed by SLICOT Library +C routines IB01AD or IB01ND. Let R_ij, i,j = 1:4, be the +C ij submatrix of R (denoted S in IB01AD and IB01ND), +C partitioned by M*NOBR, L*NOBR, M*NOBR, and L*NOBR +C rows and columns. The submatrix R_22 contains the matrix +C of left singular vectors used. Also needed, for +C METH = 'N' or JOBCV = 'C', are the submatrices R_11, +C R_14 : R_44, and, for METH = 'M' and JOB <> 'C', the +C submatrices R_31 and R_12, containing the processed +C matrices R_1c and R_2c, respectively, as returned by +C SLICOT Library routines IB01AD or IB01ND. +C Moreover, if METH = 'N' and JOB = 'A' or 'C', the +C block-row R_41 : R_43 must contain the transpose of the +C block-column R_14 : R_34 as returned by SLICOT Library +C routines IB01AD or IB01ND. +C The remaining part of R is used as workspace. +C On exit, part of this array is overwritten. Specifically, +C if METH = 'M', R_22 and R_31 are overwritten if +C JOB = 'B' or 'D', and R_12, R_22, R_14 : R_34, +C and possibly R_11 are overwritten if JOBCV = 'C'; +C if METH = 'N', all needed submatrices are overwritten. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= 2*(M+L)*NOBR. +C +C A (input or output) DOUBLE PRECISION array, dimension +C (LDA,N) +C On entry, if METH = 'N' and JOB = 'B' or 'D', the +C leading N-by-N part of this array must contain the system +C state matrix. +C If METH = 'M' or (METH = 'N' and JOB = 'A' or 'C'), +C this array need not be set on input. +C On exit, if JOB = 'A' or 'C' and INFO = 0, the +C leading N-by-N part of this array contains the system +C state matrix. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= N, if JOB = 'A' or 'C', or METH = 'N' and +C JOB = 'B' or 'D'; +C LDA >= 1, otherwise. +C +C C (input or output) DOUBLE PRECISION array, dimension +C (LDC,N) +C On entry, if METH = 'N' and JOB = 'B' or 'D', the +C leading L-by-N part of this array must contain the system +C output matrix. +C If METH = 'M' or (METH = 'N' and JOB = 'A' or 'C'), +C this array need not be set on input. +C On exit, if JOB = 'A' or 'C' and INFO = 0, or +C INFO = 3 (or INFO >= 0, for METH = 'M'), the leading +C L-by-N part of this array contains the system output +C matrix. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= L, if JOB = 'A' or 'C', or METH = 'N' and +C JOB = 'B' or 'D'; +C LDC >= 1, otherwise. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C If M > 0, JOB = 'A', 'B', or 'D' and INFO = 0, the +C leading N-by-M part of this array contains the system +C input matrix. If M = 0 or JOB = 'C', this array is +C not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= N, if M > 0 and JOB = 'A', 'B', or 'D'; +C LDB >= 1, if M = 0 or JOB = 'C'. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M) +C If M > 0, JOB = 'A' or 'D' and INFO = 0, the leading +C L-by-M part of this array contains the system input-output +C matrix. If M = 0 or JOB = 'C' or 'B', this array is +C not referenced. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= L, if M > 0 and JOB = 'A' or 'D'; +C LDD >= 1, if M = 0 or JOB = 'C' or 'B'. +C +C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) +C If JOBCV = 'C', the leading N-by-N part of this array +C contains the positive semidefinite state covariance matrix +C to be used as state weighting matrix when computing the +C Kalman gain. +C This parameter is not referenced if JOBCV = 'N'. +C +C LDQ INTEGER +C The leading dimension of the array Q. +C LDQ >= N, if JOBCV = 'C'; +C LDQ >= 1, if JOBCV = 'N'. +C +C RY (output) DOUBLE PRECISION array, dimension (LDRY,L) +C If JOBCV = 'C', the leading L-by-L part of this array +C contains the positive (semi)definite output covariance +C matrix to be used as output weighting matrix when +C computing the Kalman gain. +C This parameter is not referenced if JOBCV = 'N'. +C +C LDRY INTEGER +C The leading dimension of the array RY. +C LDRY >= L, if JOBCV = 'C'; +C LDRY >= 1, if JOBCV = 'N'. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,L) +C If JOBCV = 'C', the leading N-by-L part of this array +C contains the state-output cross-covariance matrix to be +C used as cross-weighting matrix when computing the Kalman +C gain. +C This parameter is not referenced if JOBCV = 'N'. +C +C LDS INTEGER +C The leading dimension of the array S. +C LDS >= N, if JOBCV = 'C'; +C LDS >= 1, if JOBCV = 'N'. +C +C O (output) DOUBLE PRECISION array, dimension ( LDO,N ) +C If METH = 'M' and JOBCV = 'C', or METH = 'N', +C the leading L*NOBR-by-N part of this array contains +C the estimated extended observability matrix, i.e., the +C first N columns of the relevant singular vectors. +C If METH = 'M' and JOBCV = 'N', this array is not +C referenced. +C +C LDO INTEGER +C The leading dimension of the array O. +C LDO >= L*NOBR, if JOBCV = 'C' or METH = 'N'; +C LDO >= 1, otherwise. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets TOL > 0, then the given value +C of TOL is used as a lower bound for the reciprocal +C condition number; an m-by-n matrix whose estimated +C condition number is less than 1/TOL is considered to +C be of full rank. If the user sets TOL <= 0, then an +C implicitly computed, default tolerance, defined by +C TOLDEF = m*n*EPS, is used instead, where EPS is the +C relative machine precision (see LAPACK Library routine +C DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = N, if METH = 'M' and M = 0 +C or JOB = 'C' and JOBCV = 'N'; +C LIWORK = M*NOBR+N, if METH = 'M', JOB = 'C', +C and JOBCV = 'C'; +C LIWORK = max(L*NOBR,M*NOBR), if METH = 'M', JOB <> 'C', +C and JOBCV = 'N'; +C LIWORK = max(L*NOBR,M*NOBR+N), if METH = 'M', JOB <> 'C', +C and JOBCV = 'C'; +C LIWORK = max(M*NOBR+N,M*(N+L)), if METH = 'N'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2), DWORK(3), DWORK(4), and +C DWORK(5) contain the reciprocal condition numbers of the +C triangular factors of the matrices, defined in the code, +C GaL (GaL = Un(1:(s-1)*L,1:n)), R_1c (if METH = 'M'), +C M (if JOBCV = 'C' or METH = 'N'), and Q or T (see +C SLICOT Library routines IB01PY or IB01PX), respectively. +C If METH = 'N', DWORK(3) is set to one without any +C calculations. Similarly, if METH = 'M' and JOBCV = 'N', +C DWORK(4) is set to one. If M = 0 or JOB = 'C', +C DWORK(3) and DWORK(5) are set to one. +C On exit, if INFO = -30, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( LDW1,LDW2 ), where, if METH = 'M', +C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N ), +C if JOB = 'C' or JOB = 'A' and M = 0; +C LDW1 >= max( 2*(L*NOBR-L)*N+N*N+7*N, +C (L*NOBR-L)*N+N+6*M*NOBR, (L*NOBR-L)*N+N+ +C max( L+M*NOBR, L*NOBR + +C max( 3*L*NOBR+1, M ) ) ) +C if M > 0 and JOB = 'A', 'B', or 'D'; +C LDW2 >= 0, if JOBCV = 'N'; +C LDW2 >= max( (L*NOBR-L)*N+Aw+2*N+max(5*N,(2*M+L)*NOBR+L), +C 4*(M*NOBR+N)+1, M*NOBR+2*N+L ), +C if JOBCV = 'C', +C where Aw = N+N*N, if M = 0 or JOB = 'C'; +C Aw = 0, otherwise; +C and, if METH = 'N', +C LDW1 >= max( (L*NOBR-L)*N+2*N+(2*M+L)*NOBR+L, +C 2*(L*NOBR-L)*N+N*N+8*N, N+4*(M*NOBR+N)+1, +C M*NOBR+3*N+L ); +C LDW2 >= 0, if M = 0 or JOB = 'C'; +C LDW2 >= M*NOBR*(N+L)*(M*(N+L)+1)+ +C max( (N+L)**2, 4*M*(N+L)+1 ), +C if M > 0 and JOB = 'A', 'B', or 'D'. +C For good performance, LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 4: a least squares problem to be solved has a +C rank-deficient coefficient matrix; +C = 5: the computed covariance matrices are too small. +C The problem seems to be a deterministic one. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 2: the singular value decomposition (SVD) algorithm did +C not converge; +C = 3: a singular upper triangular matrix was found. +C +C METHOD +C +C In the MOESP approach, the matrices A and C are first +C computed from an estimated extended observability matrix [1], +C and then, the matrices B and D are obtained by solving an +C extended linear system in a least squares sense. +C In the N4SID approach, besides the estimated extended +C observability matrix, the solutions of two least squares problems +C are used to build another least squares problem, whose solution +C is needed to compute the system matrices A, C, B, and D. The +C solutions of the two least squares problems are also optionally +C used by both approaches to find the covariance matrices. +C +C REFERENCES +C +C [1] Verhaegen M., and Dewilde, P. +C Subspace Model Identification. Part 1: The output-error state- +C space model identification class of algorithms. +C Int. J. Control, 56, pp. 1187-1210, 1992. +C +C [2] Van Overschee, P., and De Moor, B. +C N4SID: Two Subspace Algorithms for the Identification +C of Combined Deterministic-Stochastic Systems. +C Automatica, Vol.30, No.1, pp. 75-93, 1994. +C +C [3] Van Overschee, P. +C Subspace Identification : Theory - Implementation - +C Applications. +C Ph. D. Thesis, Department of Electrical Engineering, +C Katholieke Universiteit Leuven, Belgium, Feb. 1995. +C +C [4] Sima, V. +C Subspace-based Algorithms for Multivariable System +C Identification. +C Studies in Informatics and Control, 5, pp. 335-344, 1996. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C +C FURTHER COMMENTS +C +C In some applications, it is useful to compute the system matrices +C using two calls to this routine, the first one with JOB = 'C', +C and the second one with JOB = 'B' or 'D'. This is slightly less +C efficient than using a single call with JOB = 'A', because some +C calculations are repeated. If METH = 'N', all the calculations +C at the first call are performed again at the second call; +C moreover, it is required to save the needed submatrices of R +C before the first call and restore them before the second call. +C If the covariance matrices are desired, JOBCV should be set +C to 'C' at the second call. If B and D are both needed, they +C should be computed at once. +C It is possible to compute the matrices A and C using the MOESP +C algorithm (METH = 'M'), and the matrices B and D using the N4SID +C algorithm (METH = 'N'). This combination could be slightly more +C efficient than N4SID algorithm alone and it could be more accurate +C than MOESP algorithm. No saving/restoring is needed in such a +C combination, provided JOBCV is set to 'N' at the first call. +C Recommended usage: either one call with JOB = 'A', or +C first call with METH = 'M', JOB = 'C', JOBCV = 'N', +C second call with METH = 'M', JOB = 'D', JOBCV = 'C', or +C first call with METH = 'M', JOB = 'C', JOBCV = 'N', +C second call with METH = 'N', JOB = 'D', JOBCV = 'C'. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 1999. +C +C REVISIONS +C +C March 2000, Feb. 2001, Sep. 2001, March 2005. +C +C KEYWORDS +C +C Identification methods; least squares solutions; multivariable +C systems; QR decomposition; singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDO, LDQ, + $ LDR, LDRY, LDS, LDWORK, M, N, NOBR, NSMPL + CHARACTER JOB, JOBCV, METH +C .. Array Arguments .. + DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), + $ DWORK(*), O(LDO, *), Q(LDQ, *), R(LDR, *), + $ RY(LDRY, *), S(LDS, *) + INTEGER IWORK( * ) +C .. Local Scalars .. + DOUBLE PRECISION EPS, RCOND1, RCOND2, RCOND3, RCOND4, RNRM, + $ SVLMAX, THRESH, TOLL, TOLL1 + INTEGER I, IAW, ID, IERR, IGAL, IHOUS, ISV, ITAU, + $ ITAU1, ITAU2, IU, IUN2, IWARNL, IX, JWORK, + $ LDUN2, LDUNN, LDW, LMMNOB, LMMNOL, LMNOBR, + $ LNOBR, LNOBRN, MAXWRK, MINWRK, MNOBR, MNOBRN, + $ N2, NCOL, NN, NPL, NR, NR2, NR3, NR4, NR4MN, + $ NR4PL, NROW, RANK, RANK11, RANKM + CHARACTER FACT, JOBP, JOBPY + LOGICAL FULLR, MOESP, N4SID, SHIFT, WITHAL, WITHB, + $ WITHC, WITHCO, WITHD +C .. Local Array .. + DOUBLE PRECISION SVAL(3) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEQRF, DLACPY, DLASET, DORMQR, + $ DSYRK, DTRCON, DTRSM, DTRTRS, IB01PX, IB01PY, + $ MA02AD, MA02ED, MB02QY, MB02UD, MB03OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MOESP = LSAME( METH, 'M' ) + N4SID = LSAME( METH, 'N' ) + WITHAL = LSAME( JOB, 'A' ) + WITHC = LSAME( JOB, 'C' ) .OR. WITHAL + WITHD = LSAME( JOB, 'D' ) .OR. WITHAL + WITHB = LSAME( JOB, 'B' ) .OR. WITHD + WITHCO = LSAME( JOBCV, 'C' ) + MNOBR = M*NOBR + LNOBR = L*NOBR + LMNOBR = LNOBR + MNOBR + LMMNOB = LNOBR + 2*MNOBR + MNOBRN = MNOBR + N + LNOBRN = LNOBR - N + LDUN2 = LNOBR - L + LDUNN = LDUN2*N + LMMNOL = LMMNOB + L + NR = LMNOBR + LMNOBR + NPL = N + L + N2 = N + N + NN = N*N + MINWRK = 1 + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT.( MOESP .OR. N4SID ) ) THEN + INFO = -1 + ELSE IF( .NOT.( WITHB .OR. WITHC ) ) THEN + INFO = -2 + ELSE IF( .NOT.( WITHCO .OR. LSAME( JOBCV, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( NOBR.LE.1 ) THEN + INFO = -4 + ELSE IF( N.LE.0 .OR. N.GE.NOBR ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( L.LE.0 ) THEN + INFO = -7 + ELSE IF( WITHCO .AND. NSMPL.LT.NR ) THEN + INFO = -8 + ELSE IF( LDR.LT.NR ) THEN + INFO = -10 + ELSE IF( LDA.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. N4SID ) ) + $ .AND. LDA.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. N4SID ) ) + $ .AND. LDC.LT.L ) ) THEN + INFO = -14 + ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.N .AND. M.GT.0 ) ) + $ THEN + INFO = -16 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) + $ THEN + INFO = -18 + ELSE IF( LDQ.LT.1 .OR. ( WITHCO .AND. LDQ.LT.N ) ) THEN + INFO = -20 + ELSE IF( LDRY.LT.1 .OR. ( WITHCO .AND. LDRY.LT.L ) ) THEN + INFO = -22 + ELSE IF( LDS.LT.1 .OR. ( WITHCO .AND. LDS.LT.N ) ) THEN + INFO = -24 + ELSE IF( LDO.LT.1 .OR. ( ( WITHCO .OR. N4SID ) .AND. + $ LDO.LT.LNOBR ) ) THEN + INFO = -26 + ELSE +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IAW = 0 + MINWRK = LDUNN + 4*N + MAXWRK = LDUNN + N + N*ILAENV( 1, 'DGEQRF', ' ', LDUN2, N, -1, + $ -1 ) + IF( MOESP ) THEN + ID = 0 + IF( WITHC ) THEN + MINWRK = MAX( MINWRK, 2*LDUNN + N2, LDUNN + NN + 7*N ) + MAXWRK = MAX( MAXWRK, 2*LDUNN + N + N*ILAENV( 1, + $ 'DORMQR', 'LT', LDUN2, N, N, -1 ) ) + END IF + ELSE + ID = N + END IF +C + IF( ( M.GT.0 .AND. WITHB ) .OR. N4SID ) THEN + MINWRK = MAX( MINWRK, 2*LDUNN + NN + ID + 7*N ) + IF ( MOESP ) + $ MINWRK = MAX( MINWRK, LDUNN + N + 6*MNOBR, LDUNN + N + + $ MAX( L + MNOBR, LNOBR + + $ MAX( 3*LNOBR + 1, M ) ) ) + ELSE + IF( MOESP ) + $ IAW = N + NN + END IF +C + IF( N4SID .OR. WITHCO ) THEN + MINWRK = MAX( MINWRK, LDUNN + IAW + N2 + MAX( 5*N, LMMNOL ), + $ ID + 4*MNOBRN+1, ID + MNOBRN + NPL ) + MAXWRK = MAX( MAXWRK, LDUNN + IAW + N2 + + $ MAX( N*ILAENV( 1, 'DGEQRF', ' ', LNOBR, N, -1, + $ -1 ), LMMNOB* + $ ILAENV( 1, 'DORMQR', 'LT', LNOBR, + $ LMMNOB, N, -1 ), LMMNOL* + $ ILAENV( 1, 'DORMQR', 'LT', LDUN2, + $ LMMNOL, N, -1 ) ), + $ ID + N + N*ILAENV( 1, 'DGEQRF', ' ', LMNOBR, + $ N, -1, -1 ), + $ ID + N + NPL*ILAENV( 1, 'DORMQR', 'LT', + $ LMNOBR, NPL, N, -1 ) ) + IF( N4SID .AND. ( M.GT.0 .AND. WITHB ) ) + $ MINWRK = MAX( MINWRK, MNOBR*NPL*( M*NPL + 1 ) + + $ MAX( NPL**2, 4*M*NPL + 1 ) ) + END IF + MAXWRK = MAX( MINWRK, MAXWRK ) +C + IF ( LDWORK.LT.MINWRK ) THEN + INFO = -30 + DWORK( 1 ) = MINWRK + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01PD', -INFO ) + RETURN + END IF +C + NR2 = MNOBR + 1 + NR3 = LMNOBR + 1 + NR4 = LMMNOB + 1 +C +C Set the precision parameters. A threshold value EPS**(2/3) is +C used for deciding to use pivoting or not, where EPS is the +C relative machine precision (see LAPACK Library routine DLAMCH). +C + EPS = DLAMCH( 'Precision' ) + THRESH = EPS**( TWO/THREE ) + SVLMAX = ZERO + RCOND4 = ONE +C +C Let Un be the matrix of left singular vectors (stored in R_22). +C Copy un1 = GaL = Un(1:(s-1)*L,1:n) in the workspace. +C + IGAL = 1 + CALL DLACPY( 'Full', LDUN2, N, R(NR2,NR2), LDR, DWORK(IGAL), + $ LDUN2 ) +C +C Factor un1 = Q1*[r1' 0]' (' means transposition). +C Workspace: need L*(NOBR-1)*N+2*N, +C prefer L*(NOBR-1)*N+N+N*NB. +C + ITAU1 = IGAL + LDUNN + JWORK = ITAU1 + N + LDW = JWORK + CALL DGEQRF( LDUN2, N, DWORK(IGAL), LDUN2, DWORK(ITAU1), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Compute the reciprocal of the condition number of r1. +C Workspace: need L*(NOBR-1)*N+4*N. +C + CALL DTRCON( '1-norm', 'Upper', 'NonUnit', N, DWORK(IGAL), LDUN2, + $ RCOND1, DWORK(JWORK), IWORK, INFO ) +C + TOLL1 = TOL + IF( TOLL1.LE.ZERO ) + $ TOLL1 = NN*EPS +C + IF ( ( M.GT.0 .AND. WITHB ) .OR. N4SID ) THEN + JOBP = 'P' + IF ( WITHAL ) THEN + JOBPY = 'D' + ELSE + JOBPY = JOB + END IF + ELSE + JOBP = 'N' + END IF +C + IF ( MOESP ) THEN + NCOL = 0 + IUN2 = JWORK + IF ( WITHC ) THEN +C +C Set C = Un(1:L,1:n) and then compute the system matrix A. +C +C Set un2 = Un(L+1:L*s,1:n) in DWORK(IUN2). +C Workspace: need 2*L*(NOBR-1)*N+N. +C + CALL DLACPY( 'Full', L, N, R(NR2,NR2), LDR, C, LDC ) + CALL DLACPY( 'Full', LDUN2, N, R(NR2+L,NR2), LDR, + $ DWORK(IUN2), LDUN2 ) +C +C Note that un1 has already been factored as +C un1 = Q1*[r1' 0]' and usually (generically, assuming +C observability) has full column rank. +C Update un2 <-- Q1'*un2 in DWORK(IUN2) and save its +C first n rows in A. +C Workspace: need 2*L*(NOBR-1)*N+2*N; +C prefer 2*L*(NOBR-1)*N+N+N*NB. +C + JWORK = IUN2 + LDUNN + CALL DORMQR( 'Left', 'Transpose', LDUN2, N, N, DWORK(IGAL), + $ LDUN2, DWORK(ITAU1), DWORK(IUN2), LDUN2, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + CALL DLACPY( 'Full', N, N, DWORK(IUN2), LDUN2, A, LDA ) + NCOL = N + JWORK = IUN2 + END IF +C + IF ( RCOND1.GT.MAX( TOLL1, THRESH ) ) THEN +C +C The triangular factor r1 is considered to be of full rank. +C Solve for A (if requested), r1*A = un2(1:n,:) in A. +C + IF ( WITHC ) THEN + CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, N, + $ DWORK(IGAL), LDUN2, A, LDA, IERR ) + IF ( IERR.GT.0 ) THEN + INFO = 3 + RETURN + END IF + END IF + RANK = N + ELSE +C +C Rank-deficient triangular factor r1. Use SVD of r1, +C r1 = U*S*V', also for computing A (if requested) from +C r1*A = un2(1:n,:). Matrix U is computed in DWORK(IU), +C and V' overwrites r1. If B is requested, the +C pseudoinverse of r1 and then of GaL are also computed +C in R(NR3,NR2). +C Workspace: need c*L*(NOBR-1)*N+N*N+7*N, +C where c = 1 if B and D are not needed, +C c = 2 if B and D are needed; +C prefer larger. +C + IU = IUN2 + ISV = IU + NN + JWORK = ISV + N + IF ( M.GT.0 .AND. WITHB ) THEN +C +C Save the elementary reflectors used for computing r1, +C if B, D are needed. +C Workspace: need 2*L*(NOBR-1)*N+2*N+N*N. +C + IHOUS = JWORK + JWORK = IHOUS + LDUNN + CALL DLACPY( 'Lower', LDUN2, N, DWORK(IGAL), LDUN2, + $ DWORK(IHOUS), LDUN2 ) + ELSE + IHOUS = IGAL + END IF +C + CALL MB02UD( 'Not factored', 'Left', 'NoTranspose', JOBP, N, + $ NCOL, ONE, TOLL1, RANK, DWORK(IGAL), LDUN2, + $ DWORK(IU), N, DWORK(ISV), A, LDA, R(NR3,NR2), + $ LDR, DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + IF ( RANK.EQ.0 ) THEN + JOBP = 'N' + ELSE IF ( M.GT.0 .AND. WITHB ) THEN +C +C Compute pinv(GaL) in R(NR3,NR2) if B, D are needed. +C Workspace: need 2*L*(NOBR-1)*N+N*N+3*N; +C prefer 2*L*(NOBR-1)*N+N*N+2*N+N*NB. +C + CALL DLASET( 'Full', N, LDUN2-N, ZERO, ZERO, + $ R(NR3,NR2+N), LDR ) + CALL DORMQR( 'Right', 'Transpose', N, LDUN2, N, + $ DWORK(IHOUS), LDUN2, DWORK(ITAU1), + $ R(NR3,NR2), LDR, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF ( WITHCO ) THEN +C +C Save pinv(GaL) in DWORK(IGAL). +C + CALL DLACPY( 'Full', N, LDUN2, R(NR3,NR2), LDR, + $ DWORK(IGAL), N ) + END IF + JWORK = IUN2 + END IF + LDW = JWORK + END IF +C + IF ( M.GT.0 .AND. WITHB ) THEN +C +C Computation of B and D. +C +C Compute the reciprocal of the condition number of R_1c. +C Workspace: need L*(NOBR-1)*N+N+3*M*NOBR. +C + CALL DTRCON( '1-norm', 'Upper', 'NonUnit', MNOBR, R(NR3,1), + $ LDR, RCOND2, DWORK(JWORK), IWORK, IERR ) +C + TOLL = TOL + IF( TOLL.LE.ZERO ) + $ TOLL = MNOBR*MNOBR*EPS +C +C Compute the right hand side and solve for K (in R_23), +C K*R_1c' = u2'*R_2c', +C where u2 = Un(:,n+1:L*s), and K is (Ls-n) x ms. +C + CALL DGEMM( 'Transpose', 'Transpose', LNOBRN, MNOBR, LNOBR, + $ ONE, R(NR2,NR2+N), LDR, R(1,NR2), LDR, ZERO, + $ R(NR2,NR3), LDR ) +C + IF ( RCOND2.GT.MAX( TOLL, THRESH ) ) THEN +C +C The triangular factor R_1c is considered to be of full +C rank. Solve for K, K*R_1c' = u2'*R_2c'. +C + CALL DTRSM( 'Right', 'Upper', 'Transpose', 'Non-unit', + $ LNOBRN, MNOBR, ONE, R(NR3,1), LDR, + $ R(NR2,NR3), LDR ) + ELSE +C +C Rank-deficient triangular factor R_1c. Use SVD of R_1c +C for computing K from K*R_1c' = u2'*R_2c', where +C R_1c = U1*S1*V1'. Matrix U1 is computed in R_33, +C and V1' overwrites R_1c. +C Workspace: need L*(NOBR-1)*N+N+6*M*NOBR; +C prefer larger. +C + ISV = LDW + JWORK = ISV + MNOBR + CALL MB02UD( 'Not factored', 'Right', 'Transpose', + $ 'No pinv', LNOBRN, MNOBR, ONE, TOLL, RANK11, + $ R(NR3,1), LDR, R(NR3,NR3), LDR, DWORK(ISV), + $ R(NR2,NR3), LDR, DWORK(JWORK), 1, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + JWORK = LDW + END IF +C +C Compute the triangular factor of the structured matrix Q +C and apply the transformations to the matrix Kexpand, where +C Q and Kexpand are defined in SLICOT Library routine +C IB01PY. Compute also the matrices B, D. +C Workspace: need L*(NOBR-1)*N+N+max(L+M*NOBR,L*NOBR+ +C max(3*L*NOBR+1,M)); +C prefer larger. +C + IF ( WITHCO ) + $ CALL DLACPY( 'Full', LNOBR, N, R(NR2,NR2), LDR, O, LDO ) + CALL IB01PY( METH, JOBPY, NOBR, N, M, L, RANK, R(NR2,NR2), + $ LDR, DWORK(IGAL), LDUN2, DWORK(ITAU1), + $ R(NR3,NR2), LDR, R(NR2,NR3), LDR, R(NR4,NR2), + $ LDR, R(NR4,NR3), LDR, B, LDB, D, LDD, TOL, + $ IWORK, DWORK(JWORK), LDWORK-JWORK+1, IWARN, + $ INFO ) + IF ( INFO.NE.0 ) + $ RETURN + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + RCOND4 = DWORK(JWORK+1) + IF ( WITHCO ) + $ CALL DLACPY( 'Full', LNOBR, N, O, LDO, R(NR2,1), LDR ) +C + ELSE + RCOND2 = ONE + END IF +C + IF ( .NOT.WITHCO ) THEN + RCOND3 = ONE + GO TO 30 + END IF + ELSE +C +C For N4SID, set RCOND2 to one. +C + RCOND2 = ONE + END IF +C +C If needed, save the first n columns, representing Gam, of the +C matrix of left singular vectors, Un, in R_21 and in O. +C + IF ( N4SID .OR. ( WITHC .AND. .NOT.WITHAL ) ) THEN + IF ( M.GT.0 ) + $ CALL DLACPY( 'Full', LNOBR, N, R(NR2,NR2), LDR, R(NR2,1), + $ LDR ) + CALL DLACPY( 'Full', LNOBR, N, R(NR2,NR2), LDR, O, LDO ) + END IF +C +C Computations for covariance matrices, and system matrices (N4SID). +C Solve the least squares problems Gam*Y = R4(1:L*s,1:(2*m+L)*s), +C GaL*X = R4(L+1:L*s,:), where +C GaL = Gam(1:L*(s-1),:), Gam has full column rank, and +C R4 = [ R_14' R_24' R_34' R_44L' ], R_44L = R_44(1:L,:), as +C returned by SLICOT Library routine IB01ND. +C First, find the QR factorization of Gam, Gam = Q*R. +C Workspace: need L*(NOBR-1)*N+Aw+3*N; +C prefer L*(NOBR-1)*N+Aw+2*N+N*NB, where +C Aw = N+N*N, if (M = 0 or JOB = 'C'), rank(r1) < N, +C and METH = 'M'; +C Aw = 0, otherwise. +C + ITAU2 = LDW + JWORK = ITAU2 + N + CALL DGEQRF( LNOBR, N, R(NR2,1), LDR, DWORK(ITAU2), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C For METH = 'M' or when JOB = 'B' or 'D', transpose +C [ R_14' R_24' R_34' ]' in the last block-row of R, obtaining Z, +C and for METH = 'N' and JOB = 'A' or 'C', use the matrix Z +C already available in the last block-row of R, and then apply +C the transformations, Z <-- Q'*Z. +C Workspace: need L*(NOBR-1)*N+Aw+2*N+(2*M+L)*NOBR; +C prefer L*(NOBR-1)*N+Aw+2*N+(2*M+L)*NOBR*NB. +C + IF ( MOESP .OR. ( WITHB .AND. .NOT. WITHAL ) ) + $ CALL MA02AD( 'Full', LMMNOB, LNOBR, R(1,NR4), LDR, R(NR4,1), + $ LDR ) + CALL DORMQR( 'Left', 'Transpose', LNOBR, LMMNOB, N, R(NR2,1), LDR, + $ DWORK(ITAU2), R(NR4,1), LDR, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C +C Solve for Y, RY = Z in Z and save the transpose of the +C solution Y in the second block-column of R. +C + CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, LMMNOB, + $ R(NR2,1), LDR, R(NR4,1), LDR, IERR ) + IF ( IERR.GT.0 ) THEN + INFO = 3 + RETURN + END IF + CALL MA02AD( 'Full', N, LMMNOB, R(NR4,1), LDR, R(1,NR2), LDR ) + NR4MN = NR4 - N + NR4PL = NR4 + L + NROW = LMMNOL +C +C SHIFT is .TRUE. if some columns of R_14 : R_44L should be +C shifted to the right, to avoid overwriting useful information. +C + SHIFT = M.EQ.0 .AND. LNOBR.LT.N2 +C + IF ( RCOND1.GT.MAX( TOLL1, THRESH ) ) THEN +C +C The triangular factor r1 of GaL (GaL = Q1*r1) is +C considered to be of full rank. +C +C Transpose [ R_14' R_24' R_34' R_44L' ]'(:,L+1:L*s) in the +C last block-row of R (beginning with the (L+1)-th row), +C obtaining Z1, and then apply the transformations, +C Z1 <-- Q1'*Z1. +C Workspace: need L*(NOBR-1)*N+Aw+2*N+ (2*M+L)*NOBR + L; +C prefer L*(NOBR-1)*N+Aw+2*N+((2*M+L)*NOBR + L)*NB. +C + CALL MA02AD( 'Full', LMMNOL, LDUN2, R(1,NR4PL), LDR, + $ R(NR4PL,1), LDR ) + CALL DORMQR( 'Left', 'Transpose', LDUN2, LMMNOL, N, + $ DWORK(IGAL), LDUN2, DWORK(ITAU1), R(NR4PL,1), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Solve for X, r1*X = Z1 in Z1, and copy the transpose of X +C into the last part of the third block-column of R. +C + CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, LMMNOL, + $ DWORK(IGAL), LDUN2, R(NR4PL,1), LDR, IERR ) + IF ( IERR.GT.0 ) THEN + INFO = 3 + RETURN + END IF +C + IF ( SHIFT ) THEN + NR4MN = NR4 +C + DO 10 I = L - 1, 0, -1 + CALL DCOPY( LMMNOL, R(1,NR4+I), 1, R(1,NR4+N+I), 1 ) + 10 CONTINUE +C + END IF + CALL MA02AD( 'Full', N, LMMNOL, R(NR4PL,1), LDR, R(1,NR4MN), + $ LDR ) + NROW = 0 + END IF +C + IF ( N4SID .OR. NROW.GT.0 ) THEN +C +C METH = 'N' or rank-deficient triangular factor r1. +C For METH = 'N', use SVD of r1, r1 = U*S*V', for computing +C X' from X'*GaL' = Z1', if rank(r1) < N. Matrix U is +C computed in DWORK(IU) and V' overwrites r1. Then, the +C pseudoinverse of GaL is determined in R(NR4+L,NR2). +C For METH = 'M', the pseudoinverse of GaL is already available +C if M > 0 and B is requested; otherwise, the SVD of r1 is +C available in DWORK(IU), DWORK(ISV), and DWORK(IGAL). +C Workspace for N4SID: need 2*L*(NOBR-1)*N+N*N+8*N; +C prefer larger. +C + IF ( MOESP ) THEN + FACT = 'F' + IF ( M.GT.0 .AND. WITHB ) + $ CALL DLACPY( 'Full', N, LDUN2, DWORK(IGAL), N, + $ R(NR4PL,NR2), LDR ) + ELSE +C +C Save the elementary reflectors used for computing r1. +C + IHOUS = JWORK + CALL DLACPY( 'Lower', LDUN2, N, DWORK(IGAL), LDUN2, + $ DWORK(IHOUS), LDUN2 ) + FACT = 'N' + IU = IHOUS + LDUNN + ISV = IU + NN + JWORK = ISV + N + END IF +C + CALL MB02UD( FACT, 'Right', 'Transpose', JOBP, NROW, N, ONE, + $ TOLL1, RANK, DWORK(IGAL), LDUN2, DWORK(IU), N, + $ DWORK(ISV), R(1,NR4PL), LDR, R(NR4PL,NR2), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF ( NROW.GT.0 ) THEN + IF ( SHIFT ) THEN + NR4MN = NR4 + CALL DLACPY( 'Full', LMMNOL, L, R(1,NR4), LDR, + $ R(1,NR4-L), LDR ) + CALL DLACPY( 'Full', LMMNOL, N, R(1,NR4PL), LDR, + $ R(1,NR4MN), LDR ) + CALL DLACPY( 'Full', LMMNOL, L, R(1,NR4-L), LDR, + $ R(1,NR4+N), LDR ) + ELSE + CALL DLACPY( 'Full', LMMNOL, N, R(1,NR4PL), LDR, + $ R(1,NR4MN), LDR ) + END IF + END IF +C + IF ( N4SID ) THEN + IF ( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Compute pinv(GaL) in R(NR4+L,NR2). +C Workspace: need 2*L*(NOBR-1)*N+3*N; +C prefer 2*L*(NOBR-1)*N+2*N+N*NB. +C + JWORK = IU + CALL DLASET( 'Full', N, LDUN2-N, ZERO, ZERO, R(NR4PL,NR2+N), + $ LDR ) + CALL DORMQR( 'Right', 'Transpose', N, LDUN2, N, + $ DWORK(IHOUS), LDUN2, DWORK(ITAU1), + $ R(NR4PL,NR2), LDR, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + END IF + END IF +C +C For METH = 'N', find part of the solution (corresponding to A +C and C) and, optionally, for both METH = 'M', or METH = 'N', +C find the residual of the least squares problem that gives the +C covariances, M*V = N, where +C ( R_11 ) +C M = ( Y' ), N = ( X' R4'(:,1:L) ), V = V(n+m*s, n+L), +C ( 0 0 ) +C with M((2*m+L)*s+L, n+m*s), N((2*m+L)*s+L, n+L), R4' being +C stored in the last block-column of R. The last L rows of M +C are not explicitly considered. Note that, for efficiency, the +C last m*s columns of M are in the first positions of arrray R. +C This permutation does not affect the residual, only the +C solution. (The solution is not needed for METH = 'M'.) +C Note that R_11 corresponds to the future outputs for both +C METH = 'M', or METH = 'N' approaches. (For METH = 'N', the +C first two block-columns have been interchanged.) +C For METH = 'N', A and C are obtained as follows: +C [ A' C' ] = V(m*s+1:m*s+n,:). +C +C First, find the QR factorization of Y'(m*s+1:(2*m+L)*s,:) +C and apply the transformations to the corresponding part of N. +C Compress the workspace for N4SID by moving the scalar reflectors +C corresponding to Q. +C Workspace: need d*N+2*N; +C prefer d*N+N+N*NB; +C where d = 0, for MOESP, and d = 1, for N4SID. +C + IF ( MOESP ) THEN + ITAU = 1 + ELSE + CALL DCOPY( N, DWORK(ITAU2), 1, DWORK, 1 ) + ITAU = N + 1 + END IF +C + JWORK = ITAU + N + CALL DGEQRF( LMNOBR, N, R(NR2,NR2), LDR, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Workspace: need d*N+N+(N+L); +C prefer d*N+N+(N+L)*NB. +C + CALL DORMQR( 'Left', 'Transpose', LMNOBR, NPL, N, R(NR2,NR2), LDR, + $ DWORK(ITAU), R(NR2,NR4MN), LDR, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C + CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, R(NR4+1,NR4), LDR ) +C +C Now, matrix M with permuted block-columns has been +C triangularized. +C Compute the reciprocal of the condition number of its +C triangular factor in R(1:m*s+n,1:m*s+n). +C Workspace: need d*N+3*(M*NOBR+N). +C + JWORK = ITAU + CALL DTRCON( '1-norm', 'Upper', 'NonUnit', MNOBRN, R, LDR, RCOND3, + $ DWORK(JWORK), IWORK, INFO ) +C + TOLL = TOL + IF( TOLL.LE.ZERO ) + $ TOLL = MNOBRN*MNOBRN*EPS + IF ( RCOND3.GT.MAX( TOLL, THRESH ) ) THEN +C +C The triangular factor is considered to be of full rank. +C Solve for V(m*s+1:m*s+n,:), giving [ A' C' ]. +C + FULLR = .TRUE. + RANKM = MNOBRN + IF ( N4SID ) + $ CALL DTRSM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, + $ NPL, ONE, R(NR2,NR2), LDR, R(NR2,NR4MN), LDR ) + ELSE + FULLR = .FALSE. +C +C Use QR factorization (with pivoting). For METH = 'N', save +C (and then restore) information about the QR factorization of +C Gam, for later use. Note that R_11 could be modified by +C MB03OD, but the corresponding part of N is also modified +C accordingly. +C Workspace: need d*N+4*(M*NOBR+N)+1; +C prefer d*N+3*(M*NOBR+N)+(M*NOBR+N+1)*NB. +C + DO 20 I = 1, MNOBRN + IWORK(I) = 0 + 20 CONTINUE +C + IF ( N4SID .AND. ( M.GT.0 .AND. WITHB ) ) + $ CALL DLACPY( 'Full', LNOBR, N, R(NR2,1), LDR, R(NR4,1), + $ LDR ) + JWORK = ITAU + MNOBRN + CALL DLASET( 'Lower', MNOBRN-1, MNOBRN, ZERO, ZERO, R(2,1), + $ LDR ) + CALL MB03OD( 'QR', MNOBRN, MNOBRN, R, LDR, IWORK, TOLL, + $ SVLMAX, DWORK(ITAU), RANKM, SVAL, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need d*N+M*NOBR+N+N+L; +C prefer d*N+M*NOBR+N+(N+L)*NB. +C + CALL DORMQR( 'Left', 'Transpose', MNOBRN, NPL, MNOBRN, + $ R, LDR, DWORK(ITAU), R(1,NR4MN), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + END IF +C + IF ( WITHCO ) THEN +C +C The residual (transposed) of the least squares solution +C (multiplied by a matrix with orthogonal columns) is stored +C in the rows RANKM+1:(2*m+L)*s+L of V, and it should be +C squared-up for getting the covariance matrices. (Generically, +C RANKM = m*s+n.) +C + RNRM = ONE/DBLE( NSMPL ) + IF ( MOESP ) THEN + CALL DSYRK( 'Upper', 'Transpose', NPL, LMMNOL-RANKM, RNRM, + $ R(RANKM+1,NR4MN), LDR, ZERO, R, LDR ) + CALL DLACPY( 'Upper', N, N, R, LDR, Q, LDQ ) + CALL DLACPY( 'Full', N, L, R(1,N+1), LDR, S, LDS ) + CALL DLACPY( 'Upper', L, L, R(N+1,N+1), LDR, RY, LDRY ) + ELSE + CALL DSYRK( 'Upper', 'Transpose', NPL, LMMNOL-RANKM, RNRM, + $ R(RANKM+1,NR4MN), LDR, ZERO, DWORK(JWORK), NPL ) + CALL DLACPY( 'Upper', N, N, DWORK(JWORK), NPL, Q, LDQ ) + CALL DLACPY( 'Full', N, L, DWORK(JWORK+N*NPL), NPL, S, + $ LDS ) + CALL DLACPY( 'Upper', L, L, DWORK(JWORK+N*(NPL+1)), NPL, RY, + $ LDRY ) + END IF + CALL MA02ED( 'Upper', N, Q, LDQ ) + CALL MA02ED( 'Upper', L, RY, LDRY ) +C +C Check the magnitude of the residual. +C + RNRM = DLANGE( '1-norm', LMMNOL-RANKM, NPL, R(RANKM+1,NR4MN), + $ LDR, DWORK(JWORK) ) + IF ( RNRM.LT.THRESH ) + $ IWARN = 5 + END IF +C + IF ( N4SID ) THEN + IF ( .NOT.FULLR ) THEN + IWARN = 4 +C +C Compute part of the solution of the least squares problem, +C M*V = N, for the rank-deficient problem. +C Remark: this computation should not be performed before the +C symmetric updating operation above. +C Workspace: need M*NOBR+3*N+L; +C prefer larger. +C + CALL MB03OD( 'No QR', N, N, R(NR2,NR2), LDR, IWORK, TOLL1, + $ SVLMAX, DWORK(ITAU), RANKM, SVAL, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + CALL MB02QY( N, N, NPL, RANKM, R(NR2,NR2), LDR, IWORK, + $ R(NR2,NR4MN), LDR, DWORK(ITAU+MNOBR), + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + JWORK = ITAU + IF ( M.GT.0 .AND. WITHB ) + $ CALL DLACPY( 'Full', LNOBR, N, R(NR4,1), LDR, R(NR2,1), + $ LDR ) + END IF +C + IF ( WITHC ) THEN +C +C Obtain A and C, noting that block-permutations have been +C implicitly used. +C + CALL MA02AD( 'Full', N, N, R(NR2,NR4MN), LDR, A, LDA ) + CALL MA02AD( 'Full', N, L, R(NR2,NR4MN+N), LDR, C, LDC ) + ELSE +C +C Use the given A and C. +C + CALL MA02AD( 'Full', N, N, A, LDA, R(NR2,NR4MN), LDR ) + CALL MA02AD( 'Full', L, N, C, LDC, R(NR2,NR4MN+N), LDR ) + END IF +C + IF ( M.GT.0 .AND. WITHB ) THEN +C +C Obtain B and D. +C First, compute the transpose of the matrix K as +C N(1:m*s,:) - M(1:m*s,m*s+1:m*s+n)*[A' C'], in the first +C m*s rows of R(1,NR4MN). +C + CALL DGEMM ( 'NoTranspose', 'NoTranspose', MNOBR, NPL, N, + $ -ONE, R(1,NR2), LDR, R(NR2,NR4MN), LDR, ONE, + $ R(1,NR4MN), LDR ) +C +C Denote M = pinv(GaL) and construct +C +C [ [ A ] -1 ] [ R ] +C and L = [ [ ] R 0 ] Q', where Gam = Q * [ ]. +C [ [ C ] ] [ 0 ] +C +C Then, solve the least squares problem. +C + CALL DLACPY( 'Full', N, N, A, LDA, R(NR2,NR4), LDR ) + CALL DLACPY( 'Full', L, N, C, LDC, R(NR2+N,NR4), LDR ) + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', + $ NPL, N, ONE, R(NR2,1), LDR, R(NR2,NR4), LDR ) + CALL DLASET( 'Full', NPL, LNOBRN, ZERO, ZERO, R(NR2,NR4+N), + $ LDR ) +C +C Workspace: need 2*N+L; prefer N + (N+L)*NB. +C + CALL DORMQR( 'Right', 'Transpose', NPL, LNOBR, N, R(NR2,1), + $ LDR, DWORK, R(NR2,NR4), LDR, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C +C Obtain the matrix K by transposition, and find B and D. +C Workspace: need NOBR*(M*(N+L))**2+M*NOBR*(N+L)+ +C max((N+L)**2,4*M*(N+L)+1); +C prefer larger. +C + CALL MA02AD( 'Full', MNOBR, NPL, R(1,NR4MN), LDR, + $ R(NR2,NR3), LDR ) + IX = MNOBR*NPL**2*M + 1 + JWORK = IX + MNOBR*NPL + CALL IB01PX( JOBPY, NOBR, N, M, L, R, LDR, O, LDO, + $ R(NR2,NR4), LDR, R(NR4PL,NR2), LDR, R(NR2,NR3), + $ LDR, DWORK, MNOBR*NPL, DWORK(IX), B, LDB, D, + $ LDD, TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, + $ IWARNL, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + IWARN = MAX( IWARN, IWARNL ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + RCOND4 = DWORK(JWORK+1) +C + END IF + END IF +C + 30 CONTINUE +C +C Return optimal workspace in DWORK(1) and reciprocal condition +C numbers in the next locations. +C + DWORK(1) = MAXWRK + DWORK(2) = RCOND1 + DWORK(3) = RCOND2 + DWORK(4) = RCOND3 + DWORK(5) = RCOND4 + RETURN +C +C *** Last line of IB01PD *** + END diff --git a/mex/sources/libslicot/IB01PX.f b/mex/sources/libslicot/IB01PX.f new file mode 100644 index 000000000..cf19feb43 --- /dev/null +++ b/mex/sources/libslicot/IB01PX.f @@ -0,0 +1,474 @@ + SUBROUTINE IB01PX( JOB, NOBR, N, M, L, UF, LDUF, UN, LDUN, UL, + $ LDUL, PGAL, LDPGAL, K, LDK, R, LDR, X, B, LDB, + $ D, LDD, TOL, IWORK, DWORK, LDWORK, IWARN, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To build and solve the least squares problem T*X = Kv, and +C estimate the matrices B and D of a linear time-invariant (LTI) +C state space model, using the solution X, and the singular +C value decomposition information and other intermediate results, +C provided by other routines. +C +C The matrix T is computed as a sum of Kronecker products, +C +C T = T + kron(Uf(:,(i-1)*m+1:i*m),N_i), for i = 1 : s, +C +C (with T initialized by zero), where Uf is the triangular +C factor of the QR factorization of the future input part (see +C SLICOT Library routine IB01ND), N_i is given by the i-th block +C row of the matrix +C +C [ Q_11 Q_12 ... Q_1,s-2 Q_1,s-1 Q_1s ] [ I_L 0 ] +C [ Q_12 Q_13 ... Q_1,s-1 Q_1s 0 ] [ ] +C N = [ Q_13 Q_14 ... Q_1s 0 0 ] * [ ], +C [ : : : : : ] [ ] +C [ Q_1s 0 ... 0 0 0 ] [ 0 GaL ] +C +C and where +C +C [ -L_1|1 ] [ M_i-1 - L_1|i ] +C Q_11 = [ ], Q_1i = [ ], i = 2:s, +C [ I_L - L_2|1 ] [ -L_2|i ] +C +C are (n+L)-by-L matrices, and GaL is built from the first n +C relevant singular vectors, GaL = Un(1:L(s-1),1:n), computed +C by IB01ND. +C +C The vector Kv is vec(K), with the matrix K defined by +C +C K = [ K_1 K_2 K_3 ... K_s ], +C +C where K_i = K(:,(i-1)*m+1:i*m), i = 1:s, is (n+L)-by-m. +C The given matrices are Uf, GaL, and +C +C [ L_1|1 ... L_1|s ] +C L = [ ], (n+L)-by-L*s, +C [ L_2|1 ... L_2|s ] +C +C M = [ M_1 ... M_s-1 ], n-by-L*(s-1), and +C K, (n+L)-by-m*s. +C +C Matrix M is the pseudoinverse of the matrix GaL, computed by +C SLICOT Library routine IB01PD. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies which of the matrices B and D should be +C computed, as follows: +C = 'B': compute the matrix B, but not the matrix D; +C = 'D': compute both matrices B and D. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the input and output +C Hankel matrices processed by other routines. NOBR > 1. +C +C N (input) INTEGER +C The order of the system. NOBR > N > 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C UF (input/output) DOUBLE PRECISION array, dimension +C ( LDUF,M*NOBR ) +C On entry, the leading M*NOBR-by-M*NOBR upper triangular +C part of this array must contain the upper triangular +C factor of the QR factorization of the future input part, +C as computed by SLICOT Library routine IB01ND. +C The strict lower triangle need not be set to zero. +C On exit, the leading M*NOBR-by-M*NOBR upper triangular +C part of this array is unchanged, and the strict lower +C triangle is set to zero. +C +C LDUF INTEGER +C The leading dimension of the array UF. +C LDUF >= MAX( 1, M*NOBR ). +C +C UN (input) DOUBLE PRECISION array, dimension ( LDUN,N ) +C The leading L*(NOBR-1)-by-N part of this array must +C contain the matrix GaL, i.e., the leading part of the +C first N columns of the matrix Un of relevant singular +C vectors. +C +C LDUN INTEGER +C The leading dimension of the array UN. +C LDUN >= L*(NOBR-1). +C +C UL (input/output) DOUBLE PRECISION array, dimension +C ( LDUL,L*NOBR ) +C On entry, the leading (N+L)-by-L*NOBR part of this array +C must contain the given matrix L. +C On exit, if M > 0, the leading (N+L)-by-L*NOBR part of +C this array is overwritten by the matrix +C [ Q_11 Q_12 ... Q_1,s-2 Q_1,s-1 Q_1s ]. +C +C LDUL INTEGER +C The leading dimension of the array UL. LDUL >= N+L. +C +C PGAL (input) DOUBLE PRECISION array, dimension +C ( LDPGAL,L*(NOBR-1) ) +C The leading N-by-L*(NOBR-1) part of this array must +C contain the pseudoinverse of the matrix GaL, computed by +C SLICOT Library routine IB01PD. +C +C LDPGAL INTEGER +C The leading dimension of the array PGAL. LDPGAL >= N. +C +C K (input) DOUBLE PRECISION array, dimension ( LDK,M*NOBR ) +C The leading (N+L)-by-M*NOBR part of this array must +C contain the given matrix K. +C +C LDK INTEGER +C The leading dimension of the array K. LDK >= N+L. +C +C R (output) DOUBLE PRECISION array, dimension ( LDR,M*(N+L) ) +C The leading (N+L)*M*NOBR-by-M*(N+L) part of this array +C contains details of the complete orthogonal factorization +C of the coefficient matrix T of the least squares problem +C which is solved for getting the system matrices B and D. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= MAX( 1, (N+L)*M*NOBR ). +C +C X (output) DOUBLE PRECISION array, dimension +C ( (N+L)*M*NOBR ) +C The leading M*(N+L) elements of this array contain the +C least squares solution of the system T*X = Kv. +C The remaining elements are used as workspace (to store the +C corresponding part of the vector Kv = vec(K)). +C +C B (output) DOUBLE PRECISION array, dimension ( LDB,M ) +C The leading N-by-M part of this array contains the system +C input matrix. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= N. +C +C D (output) DOUBLE PRECISION array, dimension ( LDD,M ) +C If JOB = 'D', the leading L-by-M part of this array +C contains the system input-output matrix. +C If JOB = 'B', this array is not referenced. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= L, if JOB = 'D'; +C LDD >= 1, if JOB = 'B'. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets TOL > 0, then the given value +C of TOL is used as a lower bound for the reciprocal +C condition number; an m-by-n matrix whose estimated +C condition number is less than 1/TOL is considered to +C be of full rank. If the user sets TOL <= 0, then an +C implicitly computed, default tolerance, defined by +C TOLDEF = m*n*EPS, is used instead, where EPS is the +C relative machine precision (see LAPACK Library routine +C DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension ( M*(N+L) ) +C +C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and, if M > 0, DWORK(2) contains the +C reciprocal condition number of the triangular factor of +C the matrix T. +C On exit, if INFO = -26, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( (N+L)*(N+L), 4*M*(N+L)+1 ). +C For good performance, LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 4: the least squares problem to be solved has a +C rank-deficient coefficient matrix. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix T is computed, evaluating the sum of Kronecker +C products, and then the linear system T*X = Kv is solved in a +C least squares sense. The matrices B and D are then directly +C obtained from the least squares solution. +C +C REFERENCES +C +C [1] Verhaegen M., and Dewilde, P. +C Subspace Model Identification. Part 1: The output-error +C state-space model identification class of algorithms. +C Int. J. Control, 56, pp. 1187-1210, 1992. +C +C [2] Van Overschee, P., and De Moor, B. +C N4SID: Two Subspace Algorithms for the Identification +C of Combined Deterministic-Stochastic Systems. +C Automatica, Vol.30, No.1, pp. 75-93, 1994. +C +C [3] Van Overschee, P. +C Subspace Identification : Theory - Implementation - +C Applications. +C Ph. D. Thesis, Department of Electrical Engineering, +C Katholieke Universiteit Leuven, Belgium, Feb. 1995. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Universiteit Leuven, Feb. 2000. +C +C REVISIONS +C +C V. Sima, Katholieke Universiteit Leuven, Sep. 2001. +C +C KEYWORDS +C +C Identification methods; least squares solutions; multivariable +C systems; QR decomposition; singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, LDB, LDD, LDK, LDPGAL, LDR, + $ LDUF, LDUL, LDUN, LDWORK, M, N, NOBR + CHARACTER JOB +C .. Array Arguments .. + DOUBLE PRECISION B(LDB, *), D(LDD, *), DWORK(*), K(LDK, *), + $ PGAL(LDPGAL, *), R(LDR, *), UF(LDUF, *), + $ UL(LDUL, *), UN(LDUN, *), X(*) + INTEGER IWORK( * ) +C .. Local Scalars .. + DOUBLE PRECISION RCOND, TOLL + INTEGER I, IERR, J, JWORK, LDUN2, LNOBR, LP1, MAXWRK, + $ MINWRK, MKRON, MNOBR, NKRON, NP1, NPL, RANK + LOGICAL WITHB, WITHD +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DGELSY, DGEMM, DLACPY, DLASET, DTRCON, MB01VD, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + WITHD = LSAME( JOB, 'D' ) + WITHB = LSAME( JOB, 'B' ) .OR. WITHD + MNOBR = M*NOBR + LNOBR = L*NOBR + LDUN2 = LNOBR - L + LP1 = L + 1 + NP1 = N + 1 + NPL = N + L + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT.WITHB ) THEN + INFO = -1 + ELSE IF( NOBR.LE.1 ) THEN + INFO = -2 + ELSE IF( N.GE.NOBR .OR. N.LE.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( L.LE.0 ) THEN + INFO = -5 + ELSE IF( LDUF.LT.MAX( 1, MNOBR ) ) THEN + INFO = -7 + ELSE IF( LDUN.LT.LDUN2 ) THEN + INFO = -9 + ELSE IF( LDUL.LT.NPL ) THEN + INFO = -11 + ELSE IF( LDPGAL.LT.N ) THEN + INFO = -13 + ELSE IF( LDK.LT.NPL ) THEN + INFO = -15 + ELSE IF( LDR.LT.MAX( 1, MNOBR*NPL ) ) THEN + INFO = -17 + ELSE IF( LDB.LT.N ) THEN + INFO = -20 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L ) ) THEN + INFO = -22 + ELSE +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + MINWRK = MAX( NPL*NPL, 4*M*NPL + 1 ) +C + IF ( LDWORK.LT.MINWRK ) THEN + INFO = -26 + DWORK( 1 ) = MINWRK + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01PX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( M.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Construct the matrix [ Q_11 Q_12 ... Q_1,s-1 Q_1s ] in UL. +C + DO 20 J = 1, L +C + DO 10 I = 1, NPL + UL(I,J) = -UL(I,J) + 10 CONTINUE +C + UL(N+J,J) = ONE + UL(N+J,J) + 20 CONTINUE +C + DO 50 J = LP1, LNOBR +C + DO 30 I = 1, N + UL(I,J) = PGAL(I,J-L) - UL(I,J) + 30 CONTINUE +C + DO 40 I = NP1, NPL + UL(I,J) = -UL(I,J) + 40 CONTINUE +C + 50 CONTINUE +C +C Compute the coefficient matrix T using Kronecker products. +C Workspace: (N+L)*(N+L). +C In the same loop, vectorize K in X. +C + CALL DLASET( 'Full', MNOBR*NPL, M*NPL, ZERO, ZERO, R, LDR ) + CALL DLASET( 'Lower', MNOBR-1, MNOBR-1, ZERO, ZERO, UF(2,1), + $ LDUF ) + JWORK = NPL*L + 1 +C + DO 60 I = 1, NOBR + CALL DLACPY( 'Full', NPL, L, UL(1,(I-1)*L+1), LDUL, DWORK, + $ NPL ) + IF ( I.LT.NOBR ) THEN + CALL DGEMM ( 'NoTranspose', 'NoTranspose', NPL, N, + $ L*(NOBR-I), ONE, UL(1,I*L+1), LDUL, UN, LDUN, + $ ZERO, DWORK(JWORK), NPL ) + ELSE + CALL DLASET( 'Full', NPL, N, ZERO, ZERO, DWORK(JWORK), NPL ) + END IF + CALL MB01VD( 'NoTranspose', 'NoTranspose', MNOBR, M, NPL, + $ NPL, ONE, ONE, UF(1,(I-1)*M+1), LDUF, DWORK, + $ NPL, R, LDR, MKRON, NKRON, IERR ) + CALL DLACPY( 'Full', NPL, M, K(1,(I-1)*M+1), LDK, + $ X((I-1)*NKRON+1), NPL ) + 60 CONTINUE +C +C Compute the tolerance. +C + TOLL = TOL + IF( TOLL.LE.ZERO ) + $ TOLL = MKRON*NKRON*DLAMCH( 'Precision' ) +C +C Solve the least square problem T*X = vec(K). +C Workspace: need 4*M*(N+L)+1; +C prefer 3*M*(N+L)+(M*(N+L)+1)*NB. +C + DO 70 I = 1, NKRON + IWORK(I) = 0 + 70 CONTINUE +C + CALL DGELSY( MKRON, NKRON, 1, R, LDR, X, MKRON, IWORK, TOLL, RANK, + $ DWORK, LDWORK, IERR ) + MAXWRK = DWORK(1) +C +C Compute the reciprocal of the condition number of the triangular +C factor R of T. +C Workspace: need 3*M*(N+L). +C + CALL DTRCON( '1-norm', 'Upper', 'NonUnit', NKRON, R, LDR, RCOND, + $ DWORK, IWORK, IERR ) +C + IF ( RANK.LT.NKRON ) THEN +C +C The least squares problem is rank-deficient. +C + IWARN = 4 + END IF +C +C Construct the matrix D, if needed. +C + IF ( WITHD ) + $ CALL DLACPY( 'Full', L, M, X, NPL, D, LDD ) +C +C Construct the matrix B. +C + CALL DLACPY( 'Full', N, M, X(LP1), NPL, B, LDB ) +C +C Return optimal workspace in DWORK(1) and reciprocal condition +C number in DWORK(2). +C + DWORK(1) = MAX( MINWRK, MAXWRK ) + DWORK(2) = RCOND +C + RETURN +C +C *** Last line of IB01PX *** + END diff --git a/mex/sources/libslicot/IB01PY.f b/mex/sources/libslicot/IB01PY.f new file mode 100644 index 000000000..4b4ff2f5e --- /dev/null +++ b/mex/sources/libslicot/IB01PY.f @@ -0,0 +1,768 @@ + SUBROUTINE IB01PY( METH, JOB, NOBR, N, M, L, RANKR1, UL, LDUL, + $ R1, LDR1, TAU1, PGAL, LDPGAL, K, LDK, R, LDR, + $ H, LDH, B, LDB, D, LDD, TOL, IWORK, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C 1. To compute the triangular (QR) factor of the p-by-L*s +C structured matrix Q, +C +C [ Q_1s Q_1,s-1 Q_1,s-2 ... Q_12 Q_11 ] +C [ 0 Q_1s Q_1,s-1 ... Q_13 Q_12 ] +C Q = [ 0 0 Q_1s ... Q_14 Q_13 ], +C [ : : : : : ] +C [ 0 0 0 ... 0 Q_1s ] +C +C and apply the transformations to the p-by-m matrix Kexpand, +C +C [ K_1 ] +C [ K_2 ] +C Kexpand = [ K_3 ], +C [ : ] +C [ K_s ] +C +C where, for MOESP approach (METH = 'M'), p = s*(L*s-n), and +C Q_1i = u2(L*(i-1)+1:L*i,:)' is (Ls-n)-by-L, for i = 1:s, +C u2 = Un(1:L*s,n+1:L*s), K_i = K(:,(i-1)*m+1:i*m) (i = 1:s) +C is (Ls-n)-by-m, and for N4SID approach (METH = 'N'), p = s*(n+L), +C and +C +C [ -L_1|1 ] [ M_i-1 - L_1|i ] +C Q_11 = [ ], Q_1i = [ ], i = 2:s, +C [ I_L - L_2|1 ] [ -L_2|i ] +C +C are (n+L)-by-L matrices, and +C K_i = K(:,(i-1)*m+1:i*m), i = 1:s, is (n+L)-by-m. +C The given matrices are: +C For METH = 'M', u2 = Un(1:L*s,n+1:L*s), +C K(1:Ls-n,1:m*s); +C +C [ L_1|1 ... L_1|s ] +C For METH = 'N', L = [ ], (n+L)-by-L*s, +C [ L_2|1 ... L_2|s ] +C +C M = [ M_1 ... M_s-1 ], n-by-L*(s-1), and +C K, (n+L)-by-m*s. +C Matrix M is the pseudoinverse of the matrix GaL, +C built from the first n relevant singular +C vectors, GaL = Un(1:L(s-1),1:n), and computed +C by SLICOT Library routine IB01PD for METH = 'N'. +C +C Matrix Q is triangularized (in R), exploiting its structure, +C and the transformations are applied from the left to Kexpand. +C +C 2. To estimate the matrices B and D of a linear time-invariant +C (LTI) state space model, using the factor R, transformed matrix +C Kexpand, and the singular value decomposition information provided +C by other routines. +C +C IB01PY routine is intended for speed and efficient use of the +C memory space. It is generally not recommended for METH = 'N', as +C IB01PX routine can produce more accurate results. +C +C ARGUMENTS +C +C Mode Parameters +C +C METH CHARACTER*1 +C Specifies the subspace identification method to be used, +C as follows: +C = 'M': MOESP algorithm with past inputs and outputs; +C = 'N': N4SID algorithm. +C +C JOB CHARACTER*1 +C Specifies whether or not the matrices B and D should be +C computed, as follows: +C = 'B': compute the matrix B, but not the matrix D; +C = 'D': compute both matrices B and D; +C = 'N': do not compute the matrices B and D, but only the +C R factor of Q and the transformed Kexpand. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the input and output +C Hankel matrices processed by other routines. NOBR > 1. +C +C N (input) INTEGER +C The order of the system. NOBR > N > 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C RANKR1 (input) INTEGER +C The effective rank of the upper triangular matrix r1, +C i.e., the triangular QR factor of the matrix GaL, +C computed by SLICOT Library routine IB01PD. It is also +C the effective rank of the matrix GaL. 0 <= RANKR1 <= N. +C If JOB = 'N', or M = 0, or METH = 'N', this +C parameter is not used. +C +C UL (input/workspace) DOUBLE PRECISION array, dimension +C ( LDUL,L*NOBR ) +C On entry, if METH = 'M', the leading L*NOBR-by-L*NOBR +C part of this array must contain the matrix Un of +C relevant singular vectors. The first N columns of UN +C need not be specified for this routine. +C On entry, if METH = 'N', the leading (N+L)-by-L*NOBR +C part of this array must contain the given matrix L. +C On exit, the leading LDF-by-L*(NOBR-1) part of this array +C is overwritten by the matrix F of the algorithm in [4], +C where LDF = MAX( 1, L*NOBR-N-L ), if METH = 'M'; +C LDF = N, if METH = 'N'. +C +C LDUL INTEGER +C The leading dimension of the array UL. +C LDUL >= L*NOBR, if METH = 'M'; +C LDUL >= N+L, if METH = 'N'. +C +C R1 (input) DOUBLE PRECISION array, dimension ( LDR1,N ) +C If JOB <> 'N', M > 0, METH = 'M', and RANKR1 = N, +C the leading L*(NOBR-1)-by-N part of this array must +C contain details of the QR factorization of the matrix +C GaL, as computed by SLICOT Library routine IB01PD. +C Specifically, the leading N-by-N upper triangular part +C must contain the upper triangular factor r1 of GaL, +C and the lower L*(NOBR-1)-by-N trapezoidal part, together +C with array TAU1, must contain the factored form of the +C orthogonal matrix Q1 in the QR factorization of GaL. +C If JOB = 'N', or M = 0, or METH = 'N', or METH = 'M' +C and RANKR1 < N, this array is not referenced. +C +C LDR1 INTEGER +C The leading dimension of the array R1. +C LDR1 >= L*(NOBR-1), if JOB <> 'N', M > 0, METH = 'M', +C and RANKR1 = N; +C LDR1 >= 1, otherwise. +C +C TAU1 (input) DOUBLE PRECISION array, dimension ( N ) +C If JOB <> 'N', M > 0, METH = 'M', and RANKR1 = N, +C this array must contain the scalar factors of the +C elementary reflectors used in the QR factorization of the +C matrix GaL, computed by SLICOT Library routine IB01PD. +C If JOB = 'N', or M = 0, or METH = 'N', or METH = 'M' +C and RANKR1 < N, this array is not referenced. +C +C PGAL (input) DOUBLE PRECISION array, dimension +C ( LDPGAL,L*(NOBR-1) ) +C If METH = 'N', or JOB <> 'N', M > 0, METH = 'M' and +C RANKR1 < N, the leading N-by-L*(NOBR-1) part of this +C array must contain the pseudoinverse of the matrix GaL, +C as computed by SLICOT Library routine IB01PD. +C If METH = 'M' and JOB = 'N', or M = 0, or +C RANKR1 = N, this array is not referenced. +C +C LDPGAL INTEGER +C The leading dimension of the array PGAL. +C LDPGAL >= N, if METH = 'N', or JOB <> 'N', M > 0, +C and METH = 'M' and RANKR1 < N; +C LDPGAL >= 1, otherwise. +C +C K (input/output) DOUBLE PRECISION array, dimension +C ( LDK,M*NOBR ) +C On entry, the leading (p/s)-by-M*NOBR part of this array +C must contain the given matrix K defined above. +C On exit, the leading (p/s)-by-M*NOBR part of this array +C contains the transformed matrix K. +C +C LDK INTEGER +C The leading dimension of the array K. LDK >= p/s. +C +C R (output) DOUBLE PRECISION array, dimension ( LDR,L*NOBR ) +C If JOB = 'N', or M = 0, or Q has full rank, the +C leading L*NOBR-by-L*NOBR upper triangular part of this +C array contains the R factor of the QR factorization of +C the matrix Q. +C If JOB <> 'N', M > 0, and Q has not a full rank, the +C leading L*NOBR-by-L*NOBR upper trapezoidal part of this +C array contains details of the complete orhogonal +C factorization of the matrix Q, as constructed by SLICOT +C Library routines MB03OD and MB02QY. +C +C LDR INTEGER +C The leading dimension of the array R. LDR >= L*NOBR. +C +C H (output) DOUBLE PRECISION array, dimension ( LDH,M ) +C If JOB = 'N' or M = 0, the leading L*NOBR-by-M part +C of this array contains the updated part of the matrix +C Kexpand corresponding to the upper triangular factor R +C in the QR factorization of the matrix Q. +C If JOB <> 'N', M > 0, and METH = 'N' or METH = 'M' +C and RANKR1 < N, the leading L*NOBR-by-M part of this +C array contains the minimum norm least squares solution of +C the linear system Q*X = Kexpand, from which the matrices +C B and D are found. The first NOBR-1 row blocks of X +C appear in the reverse order in H. +C If JOB <> 'N', M > 0, METH = 'M' and RANKR1 = N, the +C leading L*(NOBR-1)-by-M part of this array contains the +C matrix product Q1'*X, and the subarray +C L*(NOBR-1)+1:L*NOBR-by-M contains the corresponding +C submatrix of X, with X defined in the phrase above. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= L*NOBR. +C +C B (output) DOUBLE PRECISION array, dimension ( LDB,M ) +C If M > 0, JOB = 'B' or 'D' and INFO = 0, the leading +C N-by-M part of this array contains the system input +C matrix. +C If M = 0 or JOB = 'N', this array is not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= N, if M > 0 and JOB = 'B' or 'D'; +C LDB >= 1, if M = 0 or JOB = 'N'. +C +C D (output) DOUBLE PRECISION array, dimension ( LDD,M ) +C If M > 0, JOB = 'D' and INFO = 0, the leading +C L-by-M part of this array contains the system input-output +C matrix. +C If M = 0 or JOB = 'B' or 'N', this array is not +C referenced. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= L, if M > 0 and JOB = 'D'; +C LDD >= 1, if M = 0 or JOB = 'B' or 'N'. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets TOL > 0, then the given value +C of TOL is used as a lower bound for the reciprocal +C condition number; an m-by-n matrix whose estimated +C condition number is less than 1/TOL is considered to +C be of full rank. If the user sets TOL <= 0, then an +C implicitly computed, default tolerance, defined by +C TOLDEF = m*n*EPS, is used instead, where EPS is the +C relative machine precision (see LAPACK Library routine +C DLAMCH). +C This parameter is not used if M = 0 or JOB = 'N'. +C +C Workspace +C +C IWORK INTEGER array, dimension ( LIWORK ) +C where LIWORK >= 0, if JOB = 'N', or M = 0; +C LIWORK >= L*NOBR, if JOB <> 'N', and M > 0. +C +C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and, if JOB <> 'N', and M > 0, DWORK(2) +C contains the reciprocal condition number of the triangular +C factor of the matrix R. +C On exit, if INFO = -28, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 2*L, L*NOBR, L+M*NOBR ), +C if JOB = 'N', or M = 0; +C LDWORK >= MAX( L+M*NOBR, L*NOBR + MAX( 3*L*NOBR+1, M ) ), +C if JOB <> 'N', and M > 0. +C For good performance, LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 4: the least squares problem to be solved has a +C rank-deficient coefficient matrix. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 3: a singular upper triangular matrix was found. +C +C METHOD +C +C The QR factorization is computed exploiting the structure, +C as described in [4]. +C The matrices B and D are then obtained by solving certain +C linear systems in a least squares sense. +C +C REFERENCES +C +C [1] Verhaegen M., and Dewilde, P. +C Subspace Model Identification. Part 1: The output-error +C state-space model identification class of algorithms. +C Int. J. Control, 56, pp. 1187-1210, 1992. +C +C [2] Van Overschee, P., and De Moor, B. +C N4SID: Two Subspace Algorithms for the Identification +C of Combined Deterministic-Stochastic Systems. +C Automatica, Vol.30, No.1, pp. 75-93, 1994. +C +C [3] Van Overschee, P. +C Subspace Identification : Theory - Implementation - +C Applications. +C Ph. D. Thesis, Department of Electrical Engineering, +C Katholieke Universiteit Leuven, Belgium, Feb. 1995. +C +C [4] Sima, V. +C Subspace-based Algorithms for Multivariable System +C Identification. +C Studies in Informatics and Control, 5, pp. 335-344, 1996. +C +C NUMERICAL ASPECTS +C +C The implemented method for computing the triangular factor and +C updating Kexpand is numerically stable. +C +C FURTHER COMMENTS +C +C The computed matrices B and D are not the least squares solutions +C delivered by either MOESP or N4SID algorithms, except for the +C special case n = s - 1, L = 1. However, the computed B and D are +C frequently good enough estimates, especially for METH = 'M'. +C Better estimates could be obtained by calling SLICOT Library +C routine IB01PX, but it is less efficient, and requires much more +C workspace. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 1999. +C +C REVISIONS +C +C Feb. 2000, Sep. 2001, March 2005. +C +C KEYWORDS +C +C Identification methods; least squares solutions; multivariable +C systems; QR decomposition; singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, LDB, LDD, LDH, LDK, LDPGAL, + $ LDR, LDR1, LDUL, LDWORK, M, N, NOBR, RANKR1 + CHARACTER JOB, METH +C .. Array Arguments .. + DOUBLE PRECISION B(LDB, *), D(LDD, *), DWORK(*), H(LDH, *), + $ K(LDK, *), PGAL(LDPGAL, *), R(LDR, *), + $ R1(LDR1, *), TAU1(*), UL(LDUL, *) + INTEGER IWORK( * ) +C .. Local Scalars .. + DOUBLE PRECISION EPS, RCOND, SVLMAX, THRESH, TOLL + INTEGER I, IERR, ITAU, J, JI, JL, JM, JWORK, LDUN2, + $ LNOBR, LP1, MAXWRK, MINWRK, MNOBR, NOBRH, + $ NROW, NROWML, RANK + LOGICAL MOESP, N4SID, WITHB, WITHD +C .. Local Array .. + DOUBLE PRECISION SVAL(3) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DGEQRF, DLACPY, DLASET, DORMQR, DSWAP, + $ DTRCON, DTRSM, DTRTRS, MA02AD, MB02QY, MB03OD, + $ MB04OD, MB04OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MOD +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MOESP = LSAME( METH, 'M' ) + N4SID = LSAME( METH, 'N' ) + WITHD = LSAME( JOB, 'D' ) + WITHB = LSAME( JOB, 'B' ) .OR. WITHD + MNOBR = M*NOBR + LNOBR = L*NOBR + LDUN2 = LNOBR - L + LP1 = L + 1 + IF ( MOESP ) THEN + NROW = LNOBR - N + ELSE + NROW = N + L + END IF + NROWML = NROW - L + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT.( MOESP .OR. N4SID ) ) THEN + INFO = -1 + ELSE IF( .NOT.( WITHB .OR. LSAME( JOB, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( NOBR.LE.1 ) THEN + INFO = -3 + ELSE IF( N.GE.NOBR .OR. N.LE.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( L.LE.0 ) THEN + INFO = -6 + ELSE IF( ( MOESP .AND. WITHB .AND. M.GT.0 ) .AND. + $ ( RANKR1.LT.ZERO .OR. RANKR1.GT.N ) ) THEN + INFO = -7 + ELSE IF( ( MOESP .AND. LDUL.LT.LNOBR ) .OR. + $ ( N4SID .AND. LDUL.LT.NROW ) ) THEN + INFO = -9 + ELSE IF( LDR1.LT.1 .OR. ( M.GT.0 .AND. WITHB .AND. MOESP .AND. + $ LDR1.LT.LDUN2 .AND. RANKR1.EQ.N ) ) THEN + INFO = -11 + ELSE IF( LDPGAL.LT.1 .OR. + $ ( LDPGAL.LT.N .AND. ( N4SID .OR. ( WITHB .AND. M.GT.0 + $ .AND. ( MOESP .AND. RANKR1.LT.N ) ) ) ) ) + $ THEN + INFO = -14 + ELSE IF( LDK.LT.NROW ) THEN + INFO = -16 + ELSE IF( LDR.LT.LNOBR ) THEN + INFO = -18 + ELSE IF( LDH.LT.LNOBR ) THEN + INFO = -20 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. WITHB .AND. LDB.LT.N ) ) + $ THEN + INFO = -22 + ELSE IF( LDD.LT.1 .OR. ( M.GT.0 .AND. WITHD .AND. LDD.LT.L ) ) + $ THEN + INFO = -24 + ELSE +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + MINWRK = MAX( 2*L, LNOBR, L + MNOBR ) + MAXWRK = MINWRK + MAXWRK = MAX( MAXWRK, L + L*ILAENV( 1, 'DGEQRF', ' ', NROW, L, + $ -1, -1 ) ) + MAXWRK = MAX( MAXWRK, L + LDUN2*ILAENV( 1, 'DORMQR', 'LT', + $ NROW, LDUN2, L, -1 ) ) + MAXWRK = MAX( MAXWRK, L + MNOBR*ILAENV( 1, 'DORMQR', 'LT', + $ NROW, MNOBR, L, -1 ) ) +C + IF( M.GT.0 .AND. WITHB ) THEN + MINWRK = MAX( MINWRK, 4*LNOBR+1, LNOBR + M ) + MAXWRK = MAX( MINWRK, MAXWRK, LNOBR + + $ M*ILAENV( 1, 'DORMQR', 'LT', LNOBR, M, LNOBR, + $ -1 ) ) + END IF +C + IF ( LDWORK.LT.MINWRK ) THEN + INFO = -28 + DWORK( 1 ) = MINWRK + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01PY', -INFO ) + RETURN + END IF +C +C Construct in R the first block-row of Q, i.e., the +C (p/s)-by-L*s matrix [ Q_1s ... Q_12 Q_11 ], where +C Q_1i, defined above, is (p/s)-by-L, for i = 1:s. +C + IF ( MOESP ) THEN +C + DO 10 I = 1, NOBR + CALL MA02AD( 'Full', L, NROW, UL(L*(I-1)+1,N+1), LDUL, + $ R(1,L*(NOBR-I)+1), LDR ) + 10 CONTINUE +C + ELSE + JL = LNOBR + JM = LDUN2 +C + DO 50 JI = 1, LDUN2, L +C + DO 40 J = JI + L - 1, JI, -1 +C + DO 20 I = 1, N + R(I,J) = PGAL(I,JM) - UL(I,JL) + 20 CONTINUE +C + DO 30 I = N + 1, NROW + R(I,J) = -UL(I,JL) + 30 CONTINUE +C + JL = JL - 1 + JM = JM - 1 + 40 CONTINUE +C + 50 CONTINUE +C + DO 70 J = LNOBR, LDUN2 + 1, -1 +C + DO 60 I = 1, NROW + R(I,J) = -UL(I,JL) + 60 CONTINUE +C + JL = JL - 1 + R(N+J-LDUN2,J) = ONE + R(N+J-LDUN2,J) + 70 CONTINUE + END IF +C +C Triangularize the submatrix Q_1s using an orthogonal matrix S. +C Workspace: need 2*L, prefer L+L*NB. +C + ITAU = 1 + JWORK = ITAU + L +C + CALL DGEQRF( NROW, L, R, LDR, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C +C Apply the transformation S' to the matrix +C [ Q_1,s-1 ... Q_11 ]. Therefore, +C +C [ R P_s-1 P_s-2 ... P_2 P_1 ] +C S'[ Q_1,s ... Q_11 ] = [ ]. +C [ 0 F_s-1 F_s-2 ... F_2 F_1 ] +C +C Workspace: need L*NOBR, prefer L+(L*NOBR-L)*NB. +C + CALL DORMQR( 'Left', 'Transpose', NROW, LDUN2, L, R, LDR, + $ DWORK(ITAU), R(1,LP1), LDR, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C +C Apply the transformation S' to each of the submatrices K_i of +C Kexpand = [ K_1' K_2' ... K_s' ]', K_i = K(:,(i-1)*m+1:i*m) +C (i = 1:s) being (p/s)-by-m. Denote ( H_i' G_i' )' = S'K_i +C (i = 1:s), where H_i has L rows. +C Finally, H_i is saved in H(L*(i-1)+1:L*i,1:m), i = 1:s. +C (G_i is in K(L+1:p/s,(i-1)*m+1:i*m), i = 1:s.) +C Workspace: need L+M*NOBR, prefer L+M*NOBR*NB. +C + CALL DORMQR( 'Left', 'Transpose', NROW, MNOBR, L, R, LDR, + $ DWORK(ITAU), K, LDK, DWORK(JWORK), LDWORK-JWORK+1, + $ IERR ) +C +C Put the rows to be annihilated (matrix F) in UL(1:p/s-L,1:L*s-L). +C + CALL DLACPY( 'Full', NROWML, LDUN2, R(LP1,LP1), LDR, UL, LDUL ) +C +C Now, the structure of the transformed matrices is: +C +C [ R P_s-1 P_s-2 ... P_2 P_1 ] [ H_1 ] +C [ 0 R P_s-1 ... P_3 P_2 ] [ H_2 ] +C [ 0 0 R ... P_4 P_3 ] [ H_3 ] +C [ : : : : : ] [ : ] +C [ 0 0 0 ... R P_s-1 ] [ H_s-1 ] +C Q = [ 0 0 0 ... 0 R ], Kexpand = [ H_s ], +C [ 0 F_s-1 F_s-2 ... F_2 F_1 ] [ G_1 ] +C [ 0 0 F_s-1 ... F_3 F_2 ] [ G_2 ] +C [ : : : : : ] [ : ] +C [ 0 0 0 ... 0 F_s-1 ] [ G_s-1 ] +C [ 0 0 0 ... 0 0 ] [ G_s ] +C +C where the block-rows have been permuted, to better exploit the +C structure. The block-rows having R on the diagonal are dealt +C with successively in the array R. +C The F submatrices are stored in the array UL, as a block-row. +C +C Copy H_1 in H(1:L,1:m). +C + CALL DLACPY( 'Full', L, M, K, LDK, H, LDH ) +C +C Triangularize the transformed matrix exploiting its structure. +C Workspace: need L+MAX(L-1,L*NOBR-2*L,M*(NOBR-1)). +C + DO 90 I = 1, NOBR - 1 +C +C Copy part of the preceding block-row and then annihilate the +C current submatrix F_s-i using an orthogonal matrix modifying +C the corresponding submatrix R. Simultaneously, apply the +C transformation to the corresponding block-rows of the matrices +C R and F. +C + CALL DLACPY( 'Upper', L, LNOBR-L*I, R(L*(I-1)+1,L*(I-1)+1), + $ LDR, R(L*I+1,L*I+1), LDR ) + CALL MB04OD( 'Full', L, LNOBR-L*(I+1), NROWML, R(L*I+1,L*I+1), + $ LDR, UL(1,L*(I-1)+1), LDUL, R(L*I+1,L*(I+1)+1), + $ LDR, UL(1,L*I+1), LDUL, DWORK(ITAU), DWORK(JWORK) + $ ) +C +C Apply the transformation to the corresponding block-rows of +C the matrix G and copy H_(i+1) in H(L*i+1:L*(i+1),1:m). +C + DO 80 J = 1, L + CALL MB04OY( NROWML, M*(NOBR-I), UL(1,L*(I-1)+J), DWORK(J), + $ K(J,M*I+1), LDK, K(LP1,1), LDK, DWORK(JWORK) ) + 80 CONTINUE +C + CALL DLACPY( 'Full', L, M, K(1,M*I+1), LDK, H(L*I+1,1), LDH ) + 90 CONTINUE +C +C Return if only the factorization is needed. +C + IF( M.EQ.0 .OR. .NOT.WITHB ) THEN + DWORK(1) = MAXWRK + RETURN + END IF +C +C Set the precision parameters. A threshold value EPS**(2/3) is +C used for deciding to use pivoting or not, where EPS is the +C relative machine precision (see LAPACK Library routine DLAMCH). +C + EPS = DLAMCH( 'Precision' ) + THRESH = EPS**( TWO/THREE ) + TOLL = TOL + IF( TOLL.LE.ZERO ) + $ TOLL = LNOBR*LNOBR*EPS + SVLMAX = ZERO +C +C Compute the reciprocal of the condition number of the triangular +C factor R of Q. +C Workspace: need 3*L*NOBR. +C + CALL DTRCON( '1-norm', 'Upper', 'NonUnit', LNOBR, R, LDR, RCOND, + $ DWORK, IWORK, IERR ) +C + IF ( RCOND.GT.MAX( TOLL, THRESH ) ) THEN +C +C The triangular factor R is considered to be of full rank. +C Solve for X, R*X = H. +C + CALL DTRSM( 'Left', 'Upper', 'NoTranspose', 'Non-unit', + $ LNOBR, M, ONE, R, LDR, H, LDH ) + ELSE +C +C Rank-deficient triangular factor R. Compute the +C minimum-norm least squares solution of R*X = H using +C the complete orthogonal factorization of R. +C + DO 100 I = 1, LNOBR + IWORK(I) = 0 + 100 CONTINUE +C +C Workspace: need 4*L*NOBR+1; +C prefer 3*L*NOBR+(L*NOBR+1)*NB. +C + JWORK = ITAU + LNOBR + CALL DLASET( 'Lower', LNOBR-1, LNOBR, ZERO, ZERO, R(2,1), LDR ) + CALL MB03OD( 'QR', LNOBR, LNOBR, R, LDR, IWORK, TOLL, SVLMAX, + $ DWORK(ITAU), RANK, SVAL, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need L*NOBR+M; prefer L*NOBR+M*NB. +C + CALL DORMQR( 'Left', 'Transpose', LNOBR, M, LNOBR, R, LDR, + $ DWORK(ITAU), H, LDH, DWORK(JWORK), LDWORK-JWORK+1, + $ IERR ) + IF ( RANK.LT.LNOBR ) THEN +C +C The least squares problem is rank-deficient. +C + IWARN = 4 + END IF +C +C Workspace: need L*NOBR+max(L*NOBR,M); prefer larger. +C + CALL MB02QY( LNOBR, LNOBR, M, RANK, R, LDR, IWORK, H, LDH, + $ DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + END IF +C +C Construct the matrix D, if needed. +C + IF ( WITHD ) + $ CALL DLACPY( 'Full', L, M, H(LDUN2+1,1), LDH, D, LDD ) +C +C Compute B by solving another linear system (possibly in +C a least squares sense). +C +C Make a block-permutation of the rows of the right-hand side, H, +C to construct the matrix +C +C [ H(L*(s-2)+1:L*(s-1),:); ... H(L+1:L*2,:); H(1:L),:) ] +C +C in H(1:L*s-L,1:n). +C + NOBRH = NOBR/2 + MOD( NOBR, 2 ) - 1 +C + DO 120 J = 1, M +C + DO 110 I = 1, NOBRH + CALL DSWAP( L, H(L*(I-1)+1,J), 1, H(L*(NOBR-I-1)+1,J), 1 ) + 110 CONTINUE +C + 120 CONTINUE +C +C Solve for B the matrix equation GaL*B = H(1:L*s-L,:), using +C the available QR factorization of GaL, if METH = 'M' and +C rank(GaL) = n, or the available pseudoinverse of GaL, otherwise. +C + IF ( MOESP .AND. RANKR1.EQ.N ) THEN +C +C The triangular factor r1 of GaL is considered to be of +C full rank. Compute Q1'*H in H and then solve for B, +C r1*B = H(1:n,:) in B, where Q1 is the orthogonal matrix +C in the QR factorization of GaL. +C Workspace: need M; prefer M*NB. +C + CALL DORMQR( 'Left', 'Transpose', LDUN2, M, N, R1, LDR1, + $ TAU1, H, LDH, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C +C Compute the solution in B. +C + CALL DLACPY( 'Full', N, M, H, LDH, B, LDB ) +C + CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, M, R1, LDR1, + $ B, LDB, IERR ) + IF ( IERR.GT.0 ) THEN + INFO = 3 + RETURN + END IF + ELSE +C +C Rank-deficient triangular factor r1. Use the available +C pseudoinverse of GaL for computing B from GaL*B = H. +C + CALL DGEMM ( 'NoTranspose', 'NoTranspose', N, M, LDUN2, ONE, + $ PGAL, LDPGAL, H, LDH, ZERO, B, LDB ) + END IF +C +C Return optimal workspace in DWORK(1) and reciprocal condition +C number in DWORK(2). +C + DWORK(1) = MAXWRK + DWORK(2) = RCOND +C + RETURN +C +C *** Last line of IB01PY *** + END diff --git a/mex/sources/libslicot/IB01QD.f b/mex/sources/libslicot/IB01QD.f new file mode 100644 index 000000000..93bf15663 --- /dev/null +++ b/mex/sources/libslicot/IB01QD.f @@ -0,0 +1,1081 @@ + SUBROUTINE IB01QD( JOBX0, JOB, N, M, L, NSMP, A, LDA, C, LDC, U, + $ LDU, Y, LDY, X0, B, LDB, D, LDD, TOL, IWORK, + $ DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the initial state and the system matrices B and D +C of a linear time-invariant (LTI) discrete-time system, given the +C matrix pair (A,C) and the input and output trajectories of the +C system. The model structure is : +C +C x(k+1) = Ax(k) + Bu(k), k >= 0, +C y(k) = Cx(k) + Du(k), +C +C where x(k) is the n-dimensional state vector (at time k), +C u(k) is the m-dimensional input vector, +C y(k) is the l-dimensional output vector, +C and A, B, C, and D are real matrices of appropriate dimensions. +C Matrix A is assumed to be in a real Schur form. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBX0 CHARACTER*1 +C Specifies whether or not the initial state should be +C computed, as follows: +C = 'X': compute the initial state x(0); +C = 'N': do not compute the initial state (x(0) is known +C to be zero). +C +C JOB CHARACTER*1 +C Specifies which matrices should be computed, as follows: +C = 'B': compute the matrix B only (D is known to be zero); +C = 'D': compute the matrices B and D. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C NSMP (input) INTEGER +C The number of rows of matrices U and Y (number of +C samples, t). +C NSMP >= N*M + a + e, where +C a = 0, if JOBX0 = 'N'; +C a = N, if JOBX0 = 'X'; +C e = 0, if JOBX0 = 'X' and JOB = 'B'; +C e = 1, if JOBX0 = 'N' and JOB = 'B'; +C e = M, if JOB = 'D'. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A in a real Schur form. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading L-by-N part of this array must contain the +C system output matrix C (corresponding to the real Schur +C form of A). +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= L. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,M) +C On entry, the leading NSMP-by-M part of this array must +C contain the t-by-m input-data sequence matrix U, +C U = [u_1 u_2 ... u_m]. Column j of U contains the +C NSMP values of the j-th input component for consecutive +C time increments. +C On exit, if JOB = 'D', the leading NSMP-by-M part of +C this array contains details of the QR factorization of +C the t-by-m matrix U, possibly computed sequentially +C (see METHOD). +C If JOB = 'B', this array is unchanged on exit. +C If M = 0, this array is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= MAX(1,NSMP), if M > 0; +C LDU >= 1, if M = 0. +C +C Y (input) DOUBLE PRECISION array, dimension (LDY,L) +C The leading NSMP-by-L part of this array must contain the +C t-by-l output-data sequence matrix Y, +C Y = [y_1 y_2 ... y_l]. Column j of Y contains the +C NSMP values of the j-th output component for consecutive +C time increments. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= MAX(1,NSMP). +C +C X0 (output) DOUBLE PRECISION array, dimension (N) +C If JOBX0 = 'X', the estimated initial state of the +C system, x(0). +C If JOBX0 = 'N', x(0) is set to zero without any +C calculations. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C If N > 0, M > 0, and INFO = 0, the leading N-by-M +C part of this array contains the system input matrix B +C in the coordinates corresponding to the real Schur form +C of A. +C If N = 0 or M = 0, this array is not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= N, if N > 0 and M > 0; +C LDB >= 1, if N = 0 or M = 0. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M) +C If M > 0, JOB = 'D', and INFO = 0, the leading +C L-by-M part of this array contains the system input-output +C matrix D. +C If M = 0 or JOB = 'B', this array is not referenced. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= L, if M > 0 and JOB = 'D'; +C LDD >= 1, if M = 0 or JOB = 'B'. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets TOL > 0, then the given value +C of TOL is used as a lower bound for the reciprocal +C condition number; a matrix whose estimated condition +C number is less than 1/TOL is considered to be of full +C rank. If the user sets TOL <= 0, then EPS is used +C instead, where EPS is the relative machine precision +C (see LAPACK Library routine DLAMCH). TOL <= 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), where +C LIWORK >= N*M + a, if JOB = 'B', +C LIWORK >= max( N*M + a, M ), if JOB = 'D', +C with a = 0, if JOBX0 = 'N'; +C a = N, if JOBX0 = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK; DWORK(2) contains the reciprocal condition +C number of the triangular factor of the QR factorization of +C the matrix W2 (see METHOD); if M > 0 and JOB = 'D', +C DWORK(3) contains the reciprocal condition number of the +C triangular factor of the QR factorization of U. +C On exit, if INFO = -23, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( LDW1, min( LDW2, LDW3 ) ), where +C LDW1 = 2, if M = 0 or JOB = 'B', +C LDW1 = 3, if M > 0 and JOB = 'D', +C LDWa = t*L*(r + 1) + max( N + max( d, f ), 6*r ), +C LDW2 = LDWa, if M = 0 or JOB = 'B', +C LDW2 = max( LDWa, t*L*(r + 1) + 2*M*M + 6*M ), +C if M > 0 and JOB = 'D', +C LDWb = (b + r)*(r + 1) + +C max( q*(r + 1) + N*N*M + c + max( d, f ), 6*r ), +C LDW3 = LDWb, if M = 0 or JOB = 'B', +C LDW3 = max( LDWb, (b + r)*(r + 1) + 2*M*M + 6*M ), +C if M > 0 and JOB = 'D', +C r = N*M + a, +C a = 0, if JOBX0 = 'N', +C a = N, if JOBX0 = 'X'; +C b = 0, if JOB = 'B', +C b = L*M, if JOB = 'D'; +C c = 0, if JOBX0 = 'N', +C c = L*N, if JOBX0 = 'X'; +C d = 0, if JOBX0 = 'N', +C d = 2*N*N + N, if JOBX0 = 'X'; +C f = 2*r, if JOB = 'B' or M = 0, +C f = M + max( 2*r, M ), if JOB = 'D' and M > 0; +C q = b + r*L. +C For good performance, LDWORK should be larger. +C If LDWORK >= LDW2 or +C LDWORK >= t*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c + +C max( d, f ), +C then standard QR factorizations of the matrices U and/or +C W2 (see METHOD) are used. +C Otherwise, the QR factorizations are computed sequentially +C by performing NCYCLE cycles, each cycle (except possibly +C the last one) processing s < t samples, where s is +C chosen from the equation +C LDWORK = s*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c + +C max( d, f ). +C (s is at least N*M+a+e, the minimum value of NSMP.) +C The computational effort may increase and the accuracy may +C decrease with the decrease of s. Recommended value is +C LDWORK = LDW2, assuming a large enough cache size, to +C also accommodate A, C, U, and Y. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 4: the least squares problem to be solved has a +C rank-deficient coefficient matrix. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 2: the singular value decomposition (SVD) algorithm did +C not converge. +C +C METHOD +C +C An extension and refinement of the method in [1,2] is used. +C Specifically, denoting +C +C X = [ vec(D')' vec(B)' x0' ]', +C +C where vec(M) is the vector obtained by stacking the columns of +C the matrix M, then X is the least squares solution of the +C system S*X = vec(Y), with the matrix S = [ diag(U) W ], +C defined by +C +C ( U | | ... | | | ... | | ) +C ( U | 11 | ... | n1 | 12 | ... | nm | ) +C S = ( : | y | ... | y | y | ... | y | P*Gamma ), +C ( : | | ... | | | ... | | ) +C ( U | | ... | | | ... | | ) +C ij +C diag(U) having L block rows and columns. In this formula, y +C are the outputs of the system for zero initial state computed +C using the following model, for j = 1:m, and for i = 1:n, +C ij ij ij +C x (k+1) = Ax (k) + e_i u_j(k), x (0) = 0, +C +C ij ij +C y (k) = Cx (k), +C +C where e_i is the i-th n-dimensional unit vector, Gamma is +C given by +C +C ( C ) +C ( C*A ) +C Gamma = ( C*A^2 ), +C ( : ) +C ( C*A^(t-1) ) +C +C and P is a permutation matrix that groups together the rows of +C Gamma depending on the same row of C, namely +C [ c_j; c_j*A; c_j*A^2; ... c_j*A^(t-1) ], for j = 1:L. +C The first block column, diag(U), is not explicitly constructed, +C but its structure is exploited. The last block column is evaluated +C using powers of A with exponents 2^k. No interchanges are applied. +C A special QR decomposition of the matrix S is computed. Let +C U = q*[ r' 0 ]' be the QR decomposition of U, if M > 0, where +C r is M-by-M. Then, diag(q') is applied to W and vec(Y). +C The block-rows of S and vec(Y) are implicitly permuted so that +C matrix S becomes +C +C ( diag(r) W1 ) +C ( 0 W2 ), +C +C where W1 has L*M rows. Then, the QR decomposition of W2 is +C computed (sequentially, if M > 0) and used to obtain B and x0. +C The intermediate results and the QR decomposition of U are +C needed to find D. If a triangular factor is too ill conditioned, +C then singular value decomposition (SVD) is employed. SVD is not +C generally needed if the input sequence is sufficiently +C persistently exciting and NSMP is large enough. +C If the matrix W cannot be stored in the workspace (i.e., +C LDWORK < LDW2), the QR decompositions of W2 and U are +C computed sequentially. +C +C REFERENCES +C +C [1] Verhaegen M., and Varga, A. +C Some Experience with the MOESP Class of Subspace Model +C Identification Methods in Identifying the BO105 Helicopter. +C Report TR R165-94, DLR Oberpfaffenhofen, 1994. +C +C [2] Sima, V., and Varga, A. +C RASP-IDENT : Subspace Model Identification Programs. +C Deutsche Forschungsanstalt fur Luft- und Raumfahrt e. V., +C Report TR R888-94, DLR Oberpfaffenhofen, Oct. 1994. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C +C FURTHER COMMENTS +C +C The algorithm for computing the system matrices B and D is +C less efficient than the MOESP or N4SID algorithms implemented in +C SLICOT Library routine IB01PD, because a large least squares +C problem has to be solved, but the accuracy is better, as the +C computed matrices B and D are fitted to the input and output +C trajectories. However, if matrix A is unstable, the computed +C matrices B and D could be inaccurate. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Identification methods; least squares solutions; multivariable +C systems; QR decomposition; singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU, + $ LDWORK, LDY, M, N, NSMP + CHARACTER JOB, JOBX0 +C .. Array Arguments .. + DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), + $ DWORK(*), U(LDU, *), X0(*), Y(LDY, *) + INTEGER IWORK(*) +C .. Local Scalars .. + DOUBLE PRECISION RCOND, RCONDU, TOLL + INTEGER I, I2, IA, IAS, IC, ICYCLE, IE, IERR, IEXPON, + $ IG, IGAM, IGS, INI, INIH, INIR, INIS, INY, + $ INYGAM, IQ, IREM, IRHS, ISIZE, ISV, ITAU, + $ ITAUU, IUPNT, IX, IXINIT, IXSAVE, IY, IYPNT, J, + $ JWORK, K, LDDW, LDR, LDW2, LDW3, LM, LN, LNOB, + $ MAXWRK, MINSMP, MINWLS, MINWRK, N2M, NCOL, + $ NCP1, NCYCLE, NM, NN, NOBS, NROW, NSMPL, RANK + LOGICAL FIRST, NCYC, POWER2, WITHB, WITHD, WITHX0 +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGELSS, DGEMV, DGEQRF, DLACPY, + $ DLASET, DORMQR, DTRCON, DTRMM, DTRMV, DTRSM, + $ MA02AD, MB01TD, MB02UD, MB04OD, MB04OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, LOG, MAX, MIN, MOD +C .. Executable Statements .. +C +C Check the input parameters. +C + WITHD = LSAME( JOB, 'D' ) + WITHB = LSAME( JOB, 'B' ) .OR. WITHD + WITHX0 = LSAME( JOBX0, 'X' ) +C + IWARN = 0 + INFO = 0 + LM = L*M + LN = L*N + NN = N*N + NM = N*M + N2M = N*NM + NCOL = NM + IF( WITHX0 ) + $ NCOL = NCOL + N + MINSMP = NCOL + IF( WITHD ) THEN + MINSMP = MINSMP + M + IQ = MINSMP + ELSE IF ( .NOT.WITHX0 ) THEN + IQ = MINSMP + MINSMP = MINSMP + 1 + ELSE + IQ = MINSMP + END IF +C + IF( .NOT.( WITHX0 .OR. LSAME( JOBX0, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.WITHB ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( L.LE.0 ) THEN + INFO = -5 + ELSE IF( NSMP.LT.MINSMP ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.L ) THEN + INFO = -10 + ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN + INFO = -12 + ELSE IF( LDY.LT.MAX( 1, NSMP ) ) THEN + INFO = -14 + ELSE IF( LDB.LT.1 .OR. ( LDB.LT.N .AND. M.GT.0 ) ) + $ THEN + INFO = -17 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) + $ THEN + INFO = -19 + ELSE IF( TOL.GT.ONE ) THEN + INFO = -20 + END IF +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + NSMPL = NSMP*L + IQ = IQ*L + NCP1 = NCOL + 1 + ISIZE = NSMPL*NCP1 + IF ( N.GT.0 .AND. WITHX0 ) THEN + IC = 2*NN + N + ELSE + IC = 0 + END IF + MINWLS = NCOL*NCP1 + IF ( WITHD ) + $ MINWLS = MINWLS + LM*NCP1 + IF ( M.GT.0 .AND. WITHD ) THEN + IA = M + MAX( 2*NCOL, M ) + ELSE + IA = 2*NCOL + END IF + ITAU = N2M + MAX( IC, IA ) + IF ( WITHX0 ) + $ ITAU = ITAU + LN + LDW2 = ISIZE + MAX( N + MAX( IC, IA ), 6*NCOL ) + LDW3 = MINWLS + MAX( IQ*NCP1 + ITAU, 6*NCOL ) + IF ( M.GT.0 .AND. WITHD ) THEN + LDW2 = MAX( LDW2, ISIZE + 2*M*M + 6*M ) + LDW3 = MAX( LDW3, MINWLS + 2*M*M + 6*M ) + END IF + MINWRK = MIN( LDW2, LDW3 ) + MINWRK = MAX( MINWRK, 2 ) + IF ( M.GT.0 .AND. WITHD ) + $ MINWRK = MAX( MINWRK, 3 ) + IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN + IF ( M.GT.0 .AND. WITHD ) THEN + MAXWRK = ISIZE + N + M + + $ MAX( M*ILAENV( 1, 'DGEQRF', ' ', NSMP, M, -1, -1 ), + $ NCOL + NCOL*ILAENV( 1, 'DGEQRF', ' ', NSMP-M, + $ NCOL, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, ISIZE + N + M + + $ MAX( NCP1*ILAENV( 1, 'DORMQR', 'LT', NSMP, + $ NCP1, M, -1 ), + $ NCOL + ILAENV( 1, 'DORMQR', 'LT', + $ NSMP-M, 1, NCOL, -1 ) ) ) + ELSE + MAXWRK = ISIZE + N + NCOL + + $ MAX( NCOL*ILAENV( 1, 'DGEQRF', ' ', NSMPL, NCOL, + $ -1, -1 ), + $ ILAENV( 1, 'DORMQR', 'LT',NSMPL, 1, NCOL, + $ -1 ) ) + END IF + MAXWRK = MAX( MAXWRK, MINWRK ) + END IF +C + IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN + INFO = -23 + DWORK(1) = MINWRK + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, M ).EQ.0 ) THEN + DWORK(2) = ONE + IF ( M.GT.0 .AND. WITHD ) THEN + DWORK(1) = THREE + DWORK(3) = ONE + ELSE + DWORK(1) = TWO + END IF + RETURN + END IF +C +C Set up the least squares problem, either directly, if enough +C workspace, or sequentially, otherwise. +C + IYPNT = 1 + IUPNT = 1 + LDDW = ( LDWORK - MINWLS - ITAU )/NCP1 + NOBS = MIN( NSMP, LDDW/L ) +C + IF ( LDWORK.GE.LDW2 .OR. NSMP.LE.NOBS ) THEN +C +C Enough workspace for solving the problem directly. +C + NCYCLE = 1 + NOBS = NSMP + LDDW = MAX( 1, NSMPL ) + IF ( WITHD ) THEN + INIR = M + 1 + ELSE + INIR = 1 + END IF + INY = 1 + INIS = 1 + ELSE +C +C NCYCLE > 1 cycles are needed for solving the problem +C sequentially, taking NOBS samples in each cycle (or the +C remaining samples in the last cycle). +C + LNOB = L*NOBS + LDDW = MAX( 1, LNOB ) + NCYCLE = NSMP/NOBS + IF ( MOD( NSMP, NOBS ).NE.0 ) + $ NCYCLE = NCYCLE + 1 + INIR = 1 + INIH = INIR + NCOL*NCOL + INIS = INIH + NCOL + IF ( WITHD ) THEN + INY = INIS + LM*NCP1 + ELSE + INY = INIS + END IF + END IF +C + NCYC = NCYCLE.GT.1 + INYGAM = INY + LDDW*NM + IRHS = INY + LDDW*NCOL + IXINIT = IRHS + LDDW + IF( NCYC ) THEN + IC = IXINIT + N2M + IF ( WITHX0 ) THEN + IA = IC + LN + ELSE + IA = IC + END IF + LDR = MAX( 1, NCOL ) + IE = INY + ELSE + IF ( WITHD ) THEN + INIH = IRHS + M + ELSE + INIH = IRHS + END IF + IA = IXINIT + N + LDR = LDDW + IE = IXINIT + END IF + IF ( N.GT.0 .AND. WITHX0 ) + $ IAS = IA + NN +C + ITAUU = IA + IF ( WITHD ) THEN + ITAU = ITAUU + M + ELSE + ITAU = ITAUU + END IF + DUM(1) = ZERO +C + DO 190 ICYCLE = 1, NCYCLE + FIRST = ICYCLE.EQ.1 + IF ( .NOT.FIRST ) THEN + IF ( ICYCLE.EQ.NCYCLE ) THEN + NOBS = NSMP - ( NCYCLE - 1 )*NOBS + LNOB = L*NOBS + END IF + END IF +C + IY = INY + IXSAVE = IXINIT +C +C Compute the M*N output trajectories for zero initial state +C or for the saved final state value of the previous cycle. +C This can be performed in parallel. +C Workspace: need s*L*(r + 1) + b + w, +C where r = M*N + a, s = NOBS, +C a = 0, if JOBX0 = 'N'; +C a = N, if JOBX0 = 'X'; +C b = N, if NCYCLE = 1; +C b = N*N*M, if NCYCLE > 1; +C w = 0, if NCYCLE = 1; +C w = r*(r+1), if NCYCLE > 1, JOB = 'B'; +C w = (M*L+r)*(r+1), if NCYCLE > 1, JOB = 'D'. +C + DO 40 J = 1, M + DO 30 I = 1, N +C ij +C Compute the y trajectory and put the vectorized form +C of it in an appropriate column of DWORK. To gain in +C efficiency, a specialization of SLICOT Library routine +C TF01ND is used. +C + IF ( FIRST ) + $ CALL DCOPY( N, DUM, 0, DWORK(IXSAVE), 1 ) + CALL DCOPY( N, DWORK(IXSAVE), 1, X0, 1 ) + INI = IY +C + DO 20 K = 1, NOBS + CALL DGEMV( 'No transpose', L, N, ONE, C, LDC, X0, 1, + $ ZERO, DWORK(IY), NOBS ) + IY = IY + 1 + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, + $ A, LDA, X0, 1 ) +C + DO 10 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXSAVE+IX-2) + 10 CONTINUE +C + X0(I) = X0(I) + U(IUPNT+K-1,J) + CALL DCOPY( N, X0, 1, DWORK(IXSAVE), 1 ) + 20 CONTINUE +C + IF ( NCYC ) + $ IXSAVE = IXSAVE + N + IY = INI + LDDW + 30 CONTINUE +C + 40 CONTINUE +C + IF ( N.GT.0 .AND. WITHX0 ) THEN +C +C Compute the permuted extended observability matrix Gamma +C ij +C in the following N columns of DWORK (after the y +C trajectories). Gamma is directly constructed in the +C required row structure. +C Workspace: need s*L*(r + 1) + 2*N*N + N + b + c + w, +C where c = 0, if NCYCLE = 1; +C c = L*N, if NCYCLE > 1. +C + JWORK = IAS + NN + IG = INYGAM + IEXPON = INT( LOG( DBLE( NOBS ) )/LOG( TWO ) ) + IREM = NOBS - 2**IEXPON + POWER2 = IREM.EQ.0 + IF ( .NOT.POWER2 ) + $ IEXPON = IEXPON + 1 +C + IF ( FIRST ) THEN +C + DO 50 I = 1, N + CALL DCOPY( L, C(1,I), 1, DWORK(IG), NOBS ) + IG = IG + LDDW + 50 CONTINUE +C + ELSE +C + DO 60 I = IC, IC + LN - 1, L + CALL DCOPY( L, DWORK(I), 1, DWORK(IG), NOBS ) + IG = IG + LDDW + 60 CONTINUE +C + END IF +C p +C Use powers of the matrix A: A , p = 2**(J-1). +C + CALL DLACPY( 'Upper', N, N, A, LDA, DWORK(IA), N ) + IF( N.GT.1 ) + $ CALL DCOPY( N-1, A(2,1), LDA+1, DWORK(IA+1), N+1 ) + I2 = 1 + NROW = 0 +C + DO 90 J = 1, IEXPON + IGAM = INYGAM + IF ( J.LT.IEXPON .OR. POWER2 ) THEN + NROW = I2 + ELSE + NROW = IREM + END IF +C + DO 80 I = 1, L + CALL DLACPY( 'Full', NROW, N, DWORK(IGAM), LDDW, + $ DWORK(IGAM+I2), LDDW ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', + $ 'Non Unit', NROW, N, ONE, DWORK(IA), N, + $ DWORK(IGAM+I2), LDDW ) + IG = IGAM +C p +C Compute the contribution of the subdiagonal of A +C to the product. +C + DO 70 IX = 1, N - 1 + CALL DAXPY( NROW, DWORK(IA+(IX-1)*N+IX), + $ DWORK(IG+LDDW), 1, DWORK(IG+I2), 1 ) + IG = IG + LDDW + 70 CONTINUE +C + IGAM = IGAM + NOBS + 80 CONTINUE +C + IF ( J.LT.IEXPON ) THEN + CALL DLACPY( 'Upper', N, N, DWORK(IA), N, DWORK(IAS), + $ N ) + IF( N.GT.1 ) + $ CALL DCOPY( N-1, DWORK(IA+1), N+1, DWORK(IAS+1), + $ N+1 ) + CALL MB01TD( N, DWORK(IAS), N, DWORK(IA), N, + $ DWORK(JWORK), IERR ) + I2 = I2*2 + END IF + 90 CONTINUE +C + IF ( NCYC .AND. ICYCLE.LT.NCYCLE ) THEN + IG = INYGAM + I2 + NROW - 1 + IGS = IG +C + DO 100 I = IC, IC + LN - 1, L + CALL DCOPY( L, DWORK(IG), NOBS, DWORK(I), 1 ) + IG = IG + LDDW + 100 CONTINUE +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', + $ L, N, ONE, A, LDA, DWORK(IC), L ) + IG = IGS +C +C Compute the contribution of the subdiagonal of A to the +C product. +C + DO 110 IX = 1, N - 1 + CALL DAXPY( L, A(IX+1,IX), DWORK(IG+LDDW), NOBS, + $ DWORK(IC+(IX-1)*L), 1 ) + IG = IG + LDDW + 110 CONTINUE +C + END IF + END IF +C +C Setup (part of) the right hand side of the least squares +C problem. +C + IY = IRHS +C + DO 120 K = 1, L + CALL DCOPY( NOBS, Y(IYPNT,K), 1, DWORK(IY), 1 ) + IY = IY + NOBS + 120 CONTINUE +C +C Compress the data using a special QR factorization. +C Workspace: need v + y, +C where v = s*L*(r + 1) + b + c + w + x, +C x = M, y = max( 2*r, M ), +C if JOB = 'D' and M > 0, +C x = 0, y = 2*r, if JOB = 'B' or M = 0. +C + IF ( M.GT.0 .AND. WITHD ) THEN +C +C Case 1: D is requested. +C + JWORK = ITAU + IF ( FIRST ) THEN + INI = INY + M +C +C Compress the first or single segment of U, U1 = Q1*R1. +C Workspace: need v + M; +C prefer v + M*NB. +C + CALL DGEQRF( NOBS, M, U, LDU, DWORK(ITAUU), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C ij +C Apply diag(Q1') to the matrix [ y Gamma Y ]. +C Workspace: need v + r + 1, +C prefer v + (r + 1)*NB. +C + DO 130 K = 1, L + CALL DORMQR( 'Left', 'Transpose', NOBS, NCP1, M, U, + $ LDU, DWORK(ITAUU), DWORK(INY+(K-1)*NOBS), + $ LDDW, DWORK(JWORK), LDWORK-JWORK+1, + $ IERR ) + 130 CONTINUE +C + IF ( NCOL.GT.0 ) THEN +C +C Compress the first part of the first data segment of +C ij +C [ y Gamma ]. +C Workspace: need v + 2*r, +C prefer v + r + r*NB. +C + JWORK = ITAU + NCOL + CALL DGEQRF( NOBS-M, NCOL, DWORK(INI), LDDW, + $ DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C +C Apply the transformation to the corresponding right +C hand side part. +C Workspace: need v + r + 1, +C prefer v + r + NB. +C + CALL DORMQR( 'Left', 'Transpose', NOBS-M, 1, NCOL, + $ DWORK(INI), LDDW, DWORK(ITAU), + $ DWORK(IRHS+M), LDDW, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C +C Compress the remaining parts of the first data segment +C ij +C of [ y Gamma ]. +C Workspace: need v + r - 1. +C + DO 140 K = 2, L + CALL MB04OD( 'Full', NCOL, 1, NOBS-M, DWORK(INI), + $ LDDW, DWORK(INI+(K-1)*NOBS), LDDW, + $ DWORK(IRHS+M), LDDW, + $ DWORK(IRHS+M+(K-1)*NOBS), LDDW, + $ DWORK(ITAU), DWORK(JWORK) ) + 140 CONTINUE +C + END IF +C + IF ( NCYC ) THEN +C ij +C Save the triangular factor of [ y Gamma ], the +C corresponding right hand side, and the first M rows +C in each NOBS group of rows. +C Workspace: need v. +C + CALL DLACPY( 'Upper', NCOL, NCP1, DWORK(INI), LDDW, + $ DWORK(INIR), LDR ) +C + DO 150 K = 1, L + CALL DLACPY( 'Full', M, NCP1, + $ DWORK(INY +(K-1)*NOBS), LDDW, + $ DWORK(INIS+(K-1)*M), LM ) + 150 CONTINUE +C + END IF + ELSE +C +C Compress the current data segment of U, Ui = Qi*Ri, +C i = ICYCLE. +C Workspace: need v + r + 1. +C + CALL MB04OD( 'Full', M, NCP1, NOBS, U, LDU, U(IUPNT,1), + $ LDU, DWORK(INIS), LM, DWORK(INY), LDDW, + $ DWORK(ITAUU), DWORK(JWORK) ) +C +C Apply diag(Qi') to the appropriate part of the matrix +C ij +C [ y Gamma Y ]. +C Workspace: need v + r + 1. +C + DO 170 K = 2, L +C + DO 160 IX = 1, M + CALL MB04OY( NOBS, NCP1, U(IUPNT,IX), + $ DWORK(ITAUU+IX-1), + $ DWORK(INIS+(K-1)*M+IX-1), LM, + $ DWORK(INY+(K-1)*NOBS), LDDW, + $ DWORK(JWORK) ) + 160 CONTINUE +C + 170 CONTINUE +C + IF ( NCOL.GT.0 ) THEN +C + JWORK = ITAU + NCOL +C +C Compress the current (but not the first) data segment +C ij +C of [ y Gamma ]. +C Workspace: need v + r - 1. +C + DO 180 K = 1, L + CALL MB04OD( 'Full', NCOL, 1, NOBS, DWORK(INIR), + $ LDR, DWORK(INY+(K-1)*NOBS), LDDW, + $ DWORK(INIH), LDR, + $ DWORK(IRHS+(K-1)*NOBS), LDDW, + $ DWORK(ITAU), DWORK(JWORK) ) + 180 CONTINUE +C + END IF + END IF +C + ELSE IF ( NCOL.GT.0 ) THEN +C +C Case 2: D is known to be zero. +C + JWORK = ITAU + NCOL + IF ( FIRST ) THEN +C +C Compress the first or single data segment of +C ij +C [ y Gamma ]. +C Workspace: need v + 2*r, +C prefer v + r + r*NB. +C + CALL DGEQRF( LDDW, NCOL, DWORK(INY), LDDW, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Apply the transformation to the right hand side. +C Workspace: need v + r + 1, +C prefer v + r + NB. +C + CALL DORMQR( 'Left', 'Transpose', LDDW, 1, NCOL, + $ DWORK(INY), LDDW, DWORK(ITAU), DWORK(IRHS), + $ LDDW, DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF ( NCYC ) THEN +C ij +C Save the triangular factor of [ y Gamma ] and the +C corresponding right hand side. +C Workspace: need v. +C + CALL DLACPY( 'Upper', NCOL, NCP1, DWORK(INY), LDDW, + $ DWORK(INIR), LDR ) + END IF + ELSE +C +C Compress the current (but not the first) data segment. +C Workspace: need v + r - 1. +C + CALL MB04OD( 'Full', NCOL, 1, LNOB, DWORK(INIR), LDR, + $ DWORK(INY), LDDW, DWORK(INIH), LDR, + $ DWORK(IRHS), LDDW, DWORK(ITAU), + $ DWORK(JWORK) ) + END IF + END IF +C + IUPNT = IUPNT + NOBS + IYPNT = IYPNT + NOBS + 190 CONTINUE +C +C Estimate the reciprocal condition number of the triangular factor +C of the QR decomposition. +C Workspace: need u + 3*r, where +C u = t*L*(r + 1), if NCYCLE = 1; +C u = w, if NCYCLE > 1. +C + CALL DTRCON( '1-norm', 'Upper', 'No Transpose', NCOL, DWORK(INIR), + $ LDR, RCOND, DWORK(IE), IWORK, IERR ) +C + TOLL = TOL + IF ( TOLL.LE.ZERO ) + $ TOLL = DLAMCH( 'Precision' ) + IF ( RCOND.LE.TOLL**( TWO/THREE ) ) THEN + IWARN = 4 +C +C The least squares problem is ill-conditioned. +C Use SVD to solve it. +C Workspace: need u + 6*r; +C prefer larger. +C + IF ( NCOL.GT.1 ) + $ CALL DLASET( 'Lower', NCOL-1, NCOL-1, ZERO, ZERO, + $ DWORK(INIR+1), LDR ) + ISV = IE + JWORK = ISV + NCOL + CALL DGELSS( NCOL, NCOL, 1, DWORK(INIR), LDR, DWORK(INIH), LDR, + $ DWORK(ISV), TOLL, RANK, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + IF ( IERR.GT.0 ) THEN +C +C Return if SVD algorithm did not converge. +C + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) + ELSE +C +C Find the least squares solution using QR decomposition only. +C + CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non Unit', NCOL, + $ 1, ONE, DWORK(INIR), LDR, DWORK(INIH), LDR ) + END IF +C +C Setup the estimated n-by-m input matrix B, and the estimated +C initial state of the system x0. +C + CALL DLACPY( 'Full', N, M, DWORK(INIH), N, B, LDB ) +C + IF ( N.GT.0 .AND. WITHX0 ) THEN + CALL DCOPY( N, DWORK(INIH+NM), 1, X0, 1 ) + ELSE + CALL DCOPY( N, DUM, 0, X0, 1 ) + END IF +C + IF ( M.GT.0 .AND. WITHD ) THEN +C +C Compute the estimated l-by-m input/output matrix D. +C + IF ( NCYC ) THEN + IRHS = INIS + LM*NCOL + CALL DGEMV( 'No Transpose', LM, NCOL, -ONE, DWORK(INIS), + $ LM, DWORK(INIH), 1, ONE, DWORK(IRHS), 1 ) + ELSE +C + DO 200 K = 1, L + CALL DGEMV( 'No Transpose', M, NCOL, -ONE, + $ DWORK(INIS+(K-1)*NOBS), LDDW, DWORK(INIH), 1, + $ ONE, DWORK(IRHS+(K-1)*NOBS), 1 ) + 200 CONTINUE +C + DO 210 K = 2, L + CALL DCOPY( M, DWORK(IRHS+(K-1)*NOBS), 1, + $ DWORK(IRHS+(K-1)*M), 1 ) + 210 CONTINUE +C + END IF +C +C Estimate the reciprocal condition number of the triangular +C factor of the QR decomposition of the matrix U. +C Workspace: need u + 3*M. +C + CALL DTRCON( '1-norm', 'Upper', 'No Transpose', M, U, LDU, + $ RCONDU, DWORK(IE), IWORK, IERR ) + IF ( RCONDU.LE.TOLL**( TWO/THREE ) ) THEN + IWARN = 4 +C +C The least squares problem is ill-conditioned. +C Use SVD to solve it. (QR decomposition of U is preserved.) +C Workspace: need u + 2*M*M + 6*M; +C prefer larger. +C + IQ = IE + M*M + ISV = IQ + M*M + JWORK = ISV + M + CALL DLACPY( 'Upper', M, M, U, LDU, DWORK(IE), M ) + CALL MB02UD( 'Not Factored', 'Left', 'No Transpose', + $ 'No Pinv', M, L, ONE, TOLL, RANK, DWORK(IE), + $ M, DWORK(IQ), M, DWORK(ISV), DWORK(IRHS), M, + $ DUM, 1, DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF ( IERR.GT.0 ) THEN +C +C Return if SVD algorithm did not converge. +C + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) + ELSE + CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non Unit', M, + $ L, ONE, U, LDU, DWORK(IRHS), M ) + END IF + CALL MA02AD( 'Full', M, L, DWORK(IRHS), M, D, LDD ) +C + END IF +C + DWORK(1) = MAXWRK + DWORK(2) = RCOND + IF ( M.GT.0 .AND. WITHD ) + $ DWORK(3) = RCONDU +C + RETURN +C +C *** End of IB01QD *** + END diff --git a/mex/sources/libslicot/IB01RD.f b/mex/sources/libslicot/IB01RD.f new file mode 100644 index 000000000..b5eaf6125 --- /dev/null +++ b/mex/sources/libslicot/IB01RD.f @@ -0,0 +1,762 @@ + SUBROUTINE IB01RD( JOB, N, M, L, NSMP, A, LDA, B, LDB, C, LDC, D, + $ LDD, U, LDU, Y, LDY, X0, TOL, IWORK, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the initial state of a linear time-invariant (LTI) +C discrete-time system, given the system matrices (A,B,C,D) and +C the input and output trajectories of the system. The model +C structure is : +C +C x(k+1) = Ax(k) + Bu(k), k >= 0, +C y(k) = Cx(k) + Du(k), +C +C where x(k) is the n-dimensional state vector (at time k), +C u(k) is the m-dimensional input vector, +C y(k) is the l-dimensional output vector, +C and A, B, C, and D are real matrices of appropriate dimensions. +C Matrix A is assumed to be in a real Schur form. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies whether or not the matrix D is zero, as follows: +C = 'Z': the matrix D is zero; +C = 'N': the matrix D is not zero. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C NSMP (input) INTEGER +C The number of rows of matrices U and Y (number of +C samples used, t). NSMP >= N. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A in a real Schur form. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B (corresponding to the real Schur +C form of A). +C If N = 0 or M = 0, this array is not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= N, if N > 0 and M > 0; +C LDB >= 1, if N = 0 or M = 0. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading L-by-N part of this array must contain the +C system output matrix C (corresponding to the real Schur +C form of A). +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= L. +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading L-by-M part of this array must contain the +C system input-output matrix. +C If M = 0 or JOB = 'Z', this array is not referenced. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= L, if M > 0 and JOB = 'N'; +C LDD >= 1, if M = 0 or JOB = 'Z'. +C +C U (input) DOUBLE PRECISION array, dimension (LDU,M) +C If M > 0, the leading NSMP-by-M part of this array must +C contain the t-by-m input-data sequence matrix U, +C U = [u_1 u_2 ... u_m]. Column j of U contains the +C NSMP values of the j-th input component for consecutive +C time increments. +C If M = 0, this array is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= MAX(1,NSMP), if M > 0; +C LDU >= 1, if M = 0. +C +C Y (input) DOUBLE PRECISION array, dimension (LDY,L) +C The leading NSMP-by-L part of this array must contain the +C t-by-l output-data sequence matrix Y, +C Y = [y_1 y_2 ... y_l]. Column j of Y contains the +C NSMP values of the j-th output component for consecutive +C time increments. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= MAX(1,NSMP). +C +C X0 (output) DOUBLE PRECISION array, dimension (N) +C The estimated initial state of the system, x(0). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets TOL > 0, then the given value +C of TOL is used as a lower bound for the reciprocal +C condition number; a matrix whose estimated condition +C number is less than 1/TOL is considered to be of full +C rank. If the user sets TOL <= 0, then EPS is used +C instead, where EPS is the relative machine precision +C (see LAPACK Library routine DLAMCH). TOL <= 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK and DWORK(2) contains the reciprocal condition +C number of the triangular factor of the QR factorization of +C the matrix Gamma (see METHOD). +C On exit, if INFO = -22, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( 2, min( LDW1, LDW2 ) ), where +C LDW1 = t*L*(N + 1) + 2*N + max( 2*N*N, 4*N ), +C LDW2 = N*(N + 1) + 2*N + +C max( q*(N + 1) + 2*N*N + L*N, 4*N ), +C q = N*L. +C For good performance, LDWORK should be larger. +C If LDWORK >= LDW1, then standard QR factorization of +C the matrix Gamma (see METHOD) is used. Otherwise, the +C QR factorization is computed sequentially by performing +C NCYCLE cycles, each cycle (except possibly the last one) +C processing s samples, where s is chosen by equating +C LDWORK to LDW2, for q replaced by s*L. +C The computational effort may increase and the accuracy may +C decrease with the decrease of s. Recommended value is +C LDRWRK = LDW1, assuming a large enough cache size, to +C also accommodate A, B, C, D, U, and Y. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 4: the least squares problem to be solved has a +C rank-deficient coefficient matrix. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 2: the singular value decomposition (SVD) algorithm did +C not converge. +C +C METHOD +C +C An extension and refinement of the method in [1] is used. +C Specifically, the output y0(k) of the system for zero initial +C state is computed for k = 0, 1, ..., t-1 using the given model. +C Then the following least squares problem is solved for x(0) +C +C ( C ) ( y(0) - y0(0) ) +C ( C*A ) ( y(1) - y0(1) ) +C Gamma * x(0) = ( : ) * x(0) = ( : ). +C ( : ) ( : ) +C ( C*A^(t-1) ) ( y(t-1) - y0(t-1) ) +C +C The coefficient matrix Gamma is evaluated using powers of A with +C exponents 2^k. The QR decomposition of this matrix is computed. +C If its triangular factor R is too ill conditioned, then singular +C value decomposition of R is used. +C +C If the coefficient matrix cannot be stored in the workspace (i.e., +C LDWORK < LDW1), the QR decomposition is computed sequentially. +C +C REFERENCES +C +C [1] Verhaegen M., and Varga, A. +C Some Experience with the MOESP Class of Subspace Model +C Identification Methods in Identifying the BO105 Helicopter. +C Report TR R165-94, DLR Oberpfaffenhofen, 1994. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. +C +C KEYWORDS +C +C Identification methods; least squares solutions; multivariable +C systems; QR decomposition; singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) +C IBLOCK is a threshold value for switching to a block algorithm +C for U (to avoid row by row passing through U). + INTEGER IBLOCK + PARAMETER ( IBLOCK = 16384 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU, + $ LDWORK, LDY, M, N, NSMP + CHARACTER JOB +C .. Array Arguments .. + DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), + $ DWORK(*), U(LDU, *), X0(*), Y(LDY, *) + INTEGER IWORK(*) +C .. Local Scalars .. + DOUBLE PRECISION RCOND, TOLL + INTEGER I2, IA, IAS, IC, ICYCLE, IE, IERR, IEXPON, + $ IG, INIGAM, INIH, INIR, INIT, IQ, IREM, IRHS, + $ ISIZE, ISV, ITAU, IU, IUPNT, IUT, IUTRAN, IX, + $ IXINIT, IY, IYPNT, J, JWORK, K, LDDW, LDR, + $ LDW1, LDW2, MAXWRK, MINSMP, MINWLS, MINWRK, NC, + $ NCP1, NCYCLE, NN, NOBS, NRBL, NROW, NSMPL, RANK + LOGICAL BLOCK, FIRST, NCYC, POWER2, SWITCH, WITHD +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGELSS, DGEMV, DGEQRF, DLACPY, + $ DLASET, DORMQR, DTRCON, DTRMM, DTRMV, DTRSV, + $ MA02AD, MB01TD, MB04OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, LOG, MAX, MIN, MOD +C .. Executable Statements .. +C +C Check the input parameters. +C + WITHD = LSAME( JOB, 'N' ) + IWARN = 0 + INFO = 0 + NN = N*N + MINSMP = N +C + IF( .NOT.( LSAME( JOB, 'Z' ) .OR. WITHD ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( L.LE.0 ) THEN + INFO = -4 + ELSE IF( NSMP.LT.MINSMP ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.1 .OR. ( LDB.LT.N .AND. M.GT.0 ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.L ) THEN + INFO = -11 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) + $ THEN + INFO = -13 + ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN + INFO = -15 + ELSE IF( LDY.LT.MAX( 1, NSMP ) ) THEN + INFO = -17 + ELSE IF( TOL.GT.ONE ) THEN + INFO = -19 + END IF +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + NSMPL = NSMP*L + IQ = MINSMP*L + NCP1 = N + 1 + ISIZE = NSMPL*NCP1 + IC = 2*NN + MINWLS = MINSMP*NCP1 + ITAU = IC + L*N + LDW1 = ISIZE + 2*N + MAX( IC, 4*N ) + LDW2 = MINWLS + 2*N + MAX( IQ*NCP1 + ITAU, 4*N ) + MINWRK = MAX( MIN( LDW1, LDW2 ), 2 ) + IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN + MAXWRK = ISIZE + 2*N + MAX( N*ILAENV( 1, 'DGEQRF', ' ', NSMPL, + $ N, -1, -1 ), + $ ILAENV( 1, 'DORMQR', 'LT', NSMPL, + $ 1, N, -1 ) ) + MAXWRK = MAX( MAXWRK, MINWRK ) + END IF +C + IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN + INFO = -22 + DWORK(1) = MINWRK + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK(1) = TWO + DWORK(2) = ONE + RETURN + END IF +C +C Set up the least squares problem, either directly, if enough +C workspace, or sequentially, otherwise. +C + IYPNT = 1 + IUPNT = 1 + INIR = 1 + IF ( LDWORK.GE.LDW1 ) THEN +C +C Enough workspace for solving the problem directly. +C + NCYCLE = 1 + NOBS = NSMP + LDDW = NSMPL + INIGAM = 1 + ELSE +C +C NCYCLE > 1 cycles are needed for solving the problem +C sequentially, taking NOBS samples in each cycle (or the +C remaining samples in the last cycle). +C + JWORK = LDWORK - MINWLS - 2*N - ITAU + LDDW = JWORK/NCP1 + NOBS = LDDW/L + LDDW = L*NOBS + NCYCLE = NSMP/NOBS + IF ( MOD( NSMP, NOBS ).NE.0 ) + $ NCYCLE = NCYCLE + 1 + INIH = INIR + NN + INIGAM = INIH + N + END IF +C + NCYC = NCYCLE.GT.1 + IRHS = INIGAM + LDDW*N + IXINIT = IRHS + LDDW + IC = IXINIT + N + IF( NCYC ) THEN + IA = IC + L*N + LDR = N + IE = INIGAM + ELSE + INIH = IRHS + IA = IC + LDR = LDDW + IE = IXINIT + END IF + IUTRAN = IA + IAS = IA + NN + ITAU = IA + DUM(1) = ZERO +C +C Set block parameters for passing through the array U. +C + BLOCK = M.GT.1 .AND. NSMP*M.GE.IBLOCK + IF ( BLOCK ) THEN + NRBL = ( LDWORK - IUTRAN + 1 )/M + NC = NOBS/NRBL + IF ( MOD( NOBS, NRBL ).NE.0 ) + $ NC = NC + 1 + INIT = ( NC - 1 )*NRBL + BLOCK = BLOCK .AND. NRBL.GT.1 + END IF +C +C Perform direct of sequential compression of the matrix Gamma. +C + DO 150 ICYCLE = 1, NCYCLE + FIRST = ICYCLE.EQ.1 + IF ( .NOT.FIRST ) THEN + IF ( ICYCLE.EQ.NCYCLE ) THEN + NOBS = NSMP - ( NCYCLE - 1 )*NOBS + LDDW = L*NOBS + IF ( BLOCK ) THEN + NC = NOBS/NRBL + IF ( MOD( NOBS, NRBL ).NE.0 ) + $ NC = NC + 1 + INIT = ( NC - 1 )*NRBL + END IF + END IF + END IF +C +C Compute the extended observability matrix Gamma. +C Workspace: need s*L*(N + 1) + 2*N*N + 2*N + a + w, +C where s = NOBS, +C a = 0, w = 0, if NCYCLE = 1, +C a = L*N, w = N*(N + 1), if NCYCLE > 1; +C prefer as above, with s = t, a = w = 0. +C + JWORK = IAS + NN + IEXPON = INT( LOG( DBLE( NOBS ) )/LOG( TWO ) ) + IREM = L*( NOBS - 2**IEXPON ) + POWER2 = IREM.EQ.0 + IF ( .NOT.POWER2 ) + $ IEXPON = IEXPON + 1 +C + IF ( FIRST ) THEN + CALL DLACPY( 'Full', L, N, C, LDC, DWORK(INIGAM), LDDW ) + ELSE + CALL DLACPY( 'Full', L, N, DWORK(IC), L, DWORK(INIGAM), + $ LDDW ) + END IF +C p +C Use powers of the matrix A: A , p = 2**(J-1). +C + CALL DLACPY( 'Upper', N, N, A, LDA, DWORK(IA), N ) + IF ( N.GT.1 ) + $ CALL DCOPY( N-1, A(2,1), LDA+1, DWORK(IA+1), N+1 ) + I2 = L + NROW = 0 +C + DO 20 J = 1, IEXPON + IG = INIGAM + IF ( J.LT.IEXPON .OR. POWER2 ) THEN + NROW = I2 + ELSE + NROW = IREM + END IF +C + CALL DLACPY( 'Full', NROW, N, DWORK(IG), LDDW, DWORK(IG+I2), + $ LDDW ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', + $ NROW, N, ONE, DWORK(IA), N, DWORK(IG+I2), + $ LDDW ) +C p +C Compute the contribution of the subdiagonal of A to the +C product. +C + DO 10 IX = 1, N - 1 + CALL DAXPY( NROW, DWORK(IA+(IX-1)*N+IX), DWORK(IG+LDDW), + $ 1, DWORK(IG+I2), 1 ) + IG = IG + LDDW + 10 CONTINUE +C + IF ( J.LT.IEXPON ) THEN + CALL DLACPY( 'Upper', N, N, DWORK(IA), N, DWORK(IAS), N ) + CALL DCOPY( N-1, DWORK(IA+1), N+1, DWORK(IAS+1), N+1 ) + CALL MB01TD( N, DWORK(IAS), N, DWORK(IA), N, + $ DWORK(JWORK), IERR ) + I2 = I2*2 + END IF + 20 CONTINUE +C + IF ( NCYC ) THEN + IG = INIGAM + I2 + NROW - L + CALL DLACPY( 'Full', L, N, DWORK(IG), LDDW, DWORK(IC), L ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', L, + $ N, ONE, A, LDA, DWORK(IC), L ) +C +C Compute the contribution of the subdiagonal of A to the +C product. +C + DO 30 IX = 1, N - 1 + CALL DAXPY( L, A(IX+1,IX), DWORK(IG+LDDW), 1, + $ DWORK(IC+(IX-1)*L), 1 ) + IG = IG + LDDW + 30 CONTINUE +C + END IF +C +C Setup (part of) the right hand side of the least squares +C problem starting from DWORK(IRHS); use the estimated output +C trajectory for zero initial state, or for the saved final state +C value of the previous cycle. +C A specialization of SLICOT Library routine TF01ND is used. +C For large input sets (NSMP*M >= IBLOCK), chunks of U are +C transposed, to reduce the number of row-wise passes. +C Workspace: need s*L*(N + 1) + N + w; +C prefer as above, with s = t, w = 0. +C + IF ( FIRST ) + $ CALL DCOPY( N, DUM, 0, DWORK(IXINIT), 1 ) + CALL DCOPY( N, DWORK(IXINIT), 1, X0, 1 ) + IY = IRHS +C + DO 40 J = 1, L + CALL DCOPY( NOBS, Y(IYPNT,J), 1, DWORK(IY), L ) + IY = IY + 1 + 40 CONTINUE +C + IY = IRHS + IU = IUPNT + IF ( M.GT.0 ) THEN + IF ( WITHD ) THEN +C + IF ( BLOCK ) THEN + SWITCH = .TRUE. + NROW = NRBL +C + DO 60 K = 1, NOBS + IF ( MOD( K-1, NROW ).EQ.0 .AND. SWITCH ) THEN + IUT = IUTRAN + IF ( K.GT.INIT ) THEN + NROW = NOBS - INIT + SWITCH = .FALSE. + END IF + CALL MA02AD( 'Full', NROW, M, U(IU,1), LDU, + $ DWORK(IUT), M ) + IU = IU + NROW + END IF + CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, + $ 1, ONE, DWORK(IY), 1 ) + CALL DGEMV( 'No transpose', L, M, -ONE, D, LDD, + $ DWORK(IUT), 1, ONE, DWORK(IY), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, + $ A, LDA, X0, 1 ) +C + DO 50 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) + 50 CONTINUE +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ DWORK(IUT), 1, ONE, X0, 1 ) + CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) + IY = IY + L + IUT = IUT + M + 60 CONTINUE +C + ELSE +C + DO 80 K = 1, NOBS + CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, + $ 1, ONE, DWORK(IY), 1 ) + CALL DGEMV( 'No transpose', L, M, -ONE, D, LDD, + $ U(IU,1), LDU, ONE, DWORK(IY), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, + $ A, LDA, X0, 1 ) +C + DO 70 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) + 70 CONTINUE +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ U(IU,1), LDU, ONE, X0, 1 ) + CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) + IY = IY + L + IU = IU + 1 + 80 CONTINUE +C + END IF +C + ELSE +C + IF ( BLOCK ) THEN + SWITCH = .TRUE. + NROW = NRBL +C + DO 100 K = 1, NOBS + IF ( MOD( K-1, NROW ).EQ.0 .AND. SWITCH ) THEN + IUT = IUTRAN + IF ( K.GT.INIT ) THEN + NROW = NOBS - INIT + SWITCH = .FALSE. + END IF + CALL MA02AD( 'Full', NROW, M, U(IU,1), LDU, + $ DWORK(IUT), M ) + IU = IU + NROW + END IF + CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, + $ 1, ONE, DWORK(IY), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, + $ A, LDA, X0, 1 ) +C + DO 90 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) + 90 CONTINUE +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ DWORK(IUT), 1, ONE, X0, 1 ) + CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) + IY = IY + L + IUT = IUT + M + 100 CONTINUE +C + ELSE +C + DO 120 K = 1, NOBS + CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, + $ 1, ONE, DWORK(IY), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, + $ A, LDA, X0, 1 ) +C + DO 110 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) + 110 CONTINUE +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ U(IU,1), LDU, ONE, X0, 1 ) + CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) + IY = IY + L + IU = IU + 1 + 120 CONTINUE +C + END IF +C + END IF +C + ELSE +C + DO 140 K = 1, NOBS + CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, 1, + $ ONE, DWORK(IY), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, A, + $ LDA, X0, 1 ) +C + DO 130 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) + 130 CONTINUE +C + CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) + IY = IY + L + 140 CONTINUE +C + END IF +C +C Compress the data using (sequential) QR factorization. +C Workspace: need v + 2*N; +C where v = s*L*(N + 1) + N + a + w. +C + JWORK = ITAU + N + IF ( FIRST ) THEN +C +C Compress the first data segment of Gamma. +C Workspace: need v + 2*N, +C prefer v + N + N*NB. +C + CALL DGEQRF( LDDW, N, DWORK(INIGAM), LDDW, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Apply the transformation to the right hand side part. +C Workspace: need v + N + 1, +C prefer v + N + NB. +C + CALL DORMQR( 'Left', 'Transpose', LDDW, 1, N, DWORK(INIGAM), + $ LDDW, DWORK(ITAU), DWORK(IRHS), LDDW, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C + IF ( NCYC ) THEN +C +C Save the triangular factor of Gamma and the +C corresponding right hand side. +C + CALL DLACPY( 'Upper', N, NCP1, DWORK(INIGAM), LDDW, + $ DWORK(INIR), LDR ) + END IF + ELSE +C +C Compress the current (but not the first) data segment of +C Gamma. +C Workspace: need v + N - 1. +C + CALL MB04OD( 'Full', N, 1, LDDW, DWORK(INIR), LDR, + $ DWORK(INIGAM), LDDW, DWORK(INIH), LDR, + $ DWORK(IRHS), LDDW, DWORK(ITAU), DWORK(JWORK) ) + END IF +C + IUPNT = IUPNT + NOBS + IYPNT = IYPNT + NOBS + 150 CONTINUE +C +C Estimate the reciprocal condition number of the triangular factor +C of the QR decomposition. +C Workspace: need u + 3*N, where +C u = t*L*(N + 1), if NCYCLE = 1; +C u = w, if NCYCLE > 1. +C + CALL DTRCON( '1-norm', 'Upper', 'No Transpose', N, DWORK(INIR), + $ LDR, RCOND, DWORK(IE), IWORK, IERR ) +C + TOLL = TOL + IF ( TOLL.LE.ZERO ) + $ TOLL = DLAMCH( 'Precision' ) + IF ( RCOND.LE.TOLL**( TWO/THREE ) ) THEN + IWARN = 4 +C +C The least squares problem is ill-conditioned. +C Use SVD to solve it. +C Workspace: need u + 6*N; +C prefer larger. +C + CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, DWORK(INIR+1), + $ LDR ) + ISV = IE + JWORK = ISV + N + CALL DGELSS( N, N, 1, DWORK(INIR), LDR, DWORK(INIH), LDR, + $ DWORK(ISV), TOLL, RANK, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + IF ( IERR.GT.0 ) THEN +C +C Return if SVD algorithm did not converge. +C + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) + ELSE +C +C Find the least squares solution using QR decomposition only. +C + CALL DTRSV( 'Upper', 'No Transpose', 'Non Unit', N, + $ DWORK(INIR), LDR, DWORK(INIH), 1 ) + END IF +C +C Return the estimated initial state of the system x0. +C + CALL DCOPY( N, DWORK(INIH), 1, X0, 1 ) +C + DWORK(1) = MAXWRK + DWORK(2) = RCOND +C + RETURN +C +C *** End of IB01RD *** + END diff --git a/mex/sources/libslicot/IB03AD.f b/mex/sources/libslicot/IB03AD.f new file mode 100644 index 000000000..9ba63187c --- /dev/null +++ b/mex/sources/libslicot/IB03AD.f @@ -0,0 +1,1076 @@ + SUBROUTINE IB03AD( INIT, ALG, STOR, NOBR, M, L, NSMP, N, NN, + $ ITMAX1, ITMAX2, NPRINT, U, LDU, Y, LDY, X, LX, + $ TOL1, TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a set of parameters for approximating a Wiener system +C in a least-squares sense, using a neural network approach and a +C Levenberg-Marquardt algorithm. Conjugate gradients (CG) or +C Cholesky algorithms are used to solve linear systems of equations. +C The Wiener system is represented as +C +C x(t+1) = A*x(t) + B*u(t) +C z(t) = C*x(t) + D*u(t), +C +C y(t) = f(z(t),wb(1:L)), +C +C where t = 1, 2, ..., NSMP, and f is a nonlinear function, +C evaluated by the SLICOT Library routine NF01AY. The parameter +C vector X is partitioned as X = ( wb(1), ..., wb(L), theta ), +C where wb(i), i = 1 : L, correspond to the nonlinear part, and +C theta corresponds to the linear part. See SLICOT Library routine +C NF01AD for further details. +C +C The sum of squares of the error functions, defined by +C +C e(t) = y(t) - Y(t), t = 1, 2, ..., NSMP, +C +C is minimized, where Y(t) is the measured output vector. The +C functions and their Jacobian matrices are evaluated by SLICOT +C Library routine NF01BB (the FCN routine in the call of MD03AD). +C +C ARGUMENTS +C +C Mode Parameters +C +C INIT CHARACTER*1 +C Specifies which parts have to be initialized, as follows: +C = 'L' : initialize the linear part only, X already +C contains an initial approximation of the +C nonlinearity; +C = 'S' : initialize the static nonlinearity only, X +C already contains an initial approximation of the +C linear part; +C = 'B' : initialize both linear and nonlinear parts; +C = 'N' : do not initialize anything, X already contains +C an initial approximation. +C If INIT = 'S' or 'B', the error functions for the +C nonlinear part, and their Jacobian matrices, are evaluated +C by SLICOT Library routine NF01BA (used as a second FCN +C routine in the MD03AD call for the initialization step, +C see METHOD). +C +C ALG CHARACTER*1 +C Specifies the algorithm used for solving the linear +C systems involving a Jacobian matrix J, as follows: +C = 'D' : a direct algorithm, which computes the Cholesky +C factor of the matrix J'*J + par*I is used, where +C par is the Levenberg factor; +C = 'I' : an iterative Conjugate Gradients algorithm, which +C only needs the matrix J, is used. +C In both cases, matrix J is stored in a compressed form. +C +C STOR CHARACTER*1 +C If ALG = 'D', specifies the storage scheme for the +C symmetric matrix J'*J, as follows: +C = 'F' : full storage is used; +C = 'P' : packed storage is used. +C The option STOR = 'F' usually ensures a faster execution. +C This parameter is not relevant if ALG = 'I'. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C If INIT = 'L' or 'B', NOBR is the number of block rows, s, +C in the input and output block Hankel matrices to be +C processed for estimating the linear part. NOBR > 0. +C (In the MOESP theory, NOBR should be larger than n, +C the estimated dimension of state vector.) +C This parameter is ignored if INIT is 'S' or 'N'. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L >= 0, and L > 0, if +C INIT = 'L' or 'B'. +C +C NSMP (input) INTEGER +C The number of input and output samples, t. NSMP >= 0, and +C NSMP >= 2*(M+L+1)*NOBR - 1, if INIT = 'L' or 'B'. +C +C N (input/output) INTEGER +C The order of the linear part. +C If INIT = 'L' or 'B', and N < 0 on entry, the order is +C assumed unknown and it will be found by the routine. +C Otherwise, the input value will be used. If INIT = 'S' +C or 'N', N must be non-negative. The values N >= NOBR, +C or N = 0, are not acceptable if INIT = 'L' or 'B'. +C +C NN (input) INTEGER +C The number of neurons which shall be used to approximate +C the nonlinear part. NN >= 0. +C +C ITMAX1 (input) INTEGER +C The maximum number of iterations for the initialization of +C the static nonlinearity. +C This parameter is ignored if INIT is 'N' or 'L'. +C Otherwise, ITMAX1 >= 0. +C +C ITMAX2 (input) INTEGER +C The maximum number of iterations. ITMAX2 >= 0. +C +C NPRINT (input) INTEGER +C This parameter enables controlled printing of iterates if +C it is positive. In this case, FCN is called with IFLAG = 0 +C at the beginning of the first iteration and every NPRINT +C iterations thereafter and immediately prior to return, +C and the current error norm is printed. Other intermediate +C results could be printed by modifying the corresponding +C FCN routine (NF01BA and/or NF01BB). If NPRINT <= 0, no +C special calls of FCN with IFLAG = 0 are made. +C +C U (input) DOUBLE PRECISION array, dimension (LDU, M) +C The leading NSMP-by-M part of this array must contain the +C set of input samples, +C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,NSMP). +C +C Y (input) DOUBLE PRECISION array, dimension (LDY, L) +C The leading NSMP-by-L part of this array must contain the +C set of output samples, +C Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ). +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= MAX(1,NSMP). +C +C X (input/output) DOUBLE PRECISION array dimension (LX) +C On entry, if INIT = 'L', the leading (NN*(L+2) + 1)*L part +C of this array must contain the initial parameters for +C the nonlinear part of the system. +C On entry, if INIT = 'S', the elements lin1 : lin2 of this +C array must contain the initial parameters for the linear +C part of the system, corresponding to the output normal +C form, computed by SLICOT Library routine TB01VD, where +C lin1 = (NN*(L+2) + 1)*L + 1; +C lin2 = (NN*(L+2) + 1)*L + N*(L+M+1) + L*M. +C On entry, if INIT = 'N', the elements 1 : lin2 of this +C array must contain the initial parameters for the +C nonlinear part followed by the initial parameters for the +C linear part of the system, as specified above. +C This array need not be set on entry if INIT = 'B'. +C On exit, the elements 1 : lin2 of this array contain the +C optimal parameters for the nonlinear part followed by the +C optimal parameters for the linear part of the system, as +C specified above. +C +C LX (input/output) INTEGER +C On entry, this parameter must contain the intended length +C of X. If N >= 0, then LX >= NX := lin2 (see parameter X). +C If N is unknown (N < 0 on entry), a large enough estimate +C of N should be used in the formula of lin2. +C On exit, if N < 0 on entry, but LX is not large enough, +C then this parameter contains the actual length of X, +C corresponding to the computed N. Otherwise, its value +C is unchanged. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If INIT = 'S' or 'B' and TOL1 >= 0, TOL1 is the tolerance +C which measures the relative error desired in the sum of +C squares, for the initialization step of nonlinear part. +C Termination occurs when the actual relative reduction in +C the sum of squares is at most TOL1. In addition, if +C ALG = 'I', TOL1 also measures the relative residual of +C the solutions computed by the CG algorithm (for the +C initialization step). Termination of a CG process occurs +C when the relative residual is at most TOL1. +C If the user sets TOL1 < 0, then SQRT(EPS) is used +C instead TOL1, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH). +C This parameter is ignored if INIT is 'N' or 'L'. +C +C TOL2 DOUBLE PRECISION +C If TOL2 >= 0, TOL2 is the tolerance which measures the +C relative error desired in the sum of squares, for the +C whole optimization process. Termination occurs when the +C actual relative reduction in the sum of squares is at +C most TOL2. +C If ALG = 'I', TOL2 also measures the relative residual of +C the solutions computed by the CG algorithm (for the whole +C optimization). Termination of a CG process occurs when the +C relative residual is at most TOL2. +C If the user sets TOL2 < 0, then SQRT(EPS) is used +C instead TOL2. This default value could require many +C iterations, especially if TOL1 is larger. If INIT = 'S' +C or 'B', it is advisable that TOL2 be larger than TOL1, +C and spend more time with cheaper iterations. +C +C Workspace +C +C IWORK INTEGER array, dimension (MAX( 3, LIW1, LIW2 )), where +C LIW1 = LIW2 = 0, if INIT = 'S' or 'N'; otherwise, +C LIW1 = M+L; +C LIW2 = MAX(M*NOBR+N,M*(N+L)). +C On output, if INFO = 0, IWORK(1) and IWORK(2) return the +C (total) number of function and Jacobian evaluations, +C respectively (including the initialization step, if it was +C performed), and if INIT = 'L' or INIT = 'B', IWORK(3) +C specifies how many locations of DWORK contain reciprocal +C condition number estimates (see below); otherwise, +C IWORK(3) = 0. +C +C DWORK DOUBLE PRECISION array dimesion (LDWORK) +C On entry, if desired, and if INIT = 'S' or 'B', the +C entries DWORK(1:4) are set to initialize the random +C numbers generator for the nonlinear part parameters (see +C the description of the argument XINIT of SLICOT Library +C routine MD03AD); this enables to obtain reproducible +C results. The same seed is used for all outputs. +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, DWORK(2) returns the residual error norm (the +C sum of squares), DWORK(3) returns the number of iterations +C performed, DWORK(4) returns the number of conjugate +C gradients iterations performed, and DWORK(5) returns the +C final Levenberg factor, for optimizing the parameters of +C both the linear part and the static nonlinearity part. +C If INIT = 'S' or INIT = 'B' and INFO = 0, then the +C elements DWORK(6) to DWORK(10) contain the corresponding +C five values for the initialization step (see METHOD). +C (If L > 1, DWORK(10) contains the maximum of the Levenberg +C factors for all outputs.) If INIT = 'L' or INIT = 'B', and +C INFO = 0, DWORK(11) to DWORK(10+IWORK(3)) contain +C reciprocal condition number estimates set by SLICOT +C Library routines IB01AD, IB01BD, and IB01CD. +C On exit, if INFO = -23, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C In the formulas below, N should be taken not larger than +C NOBR - 1, if N < 0 on entry. +C LDWORK = MAX( LW1, LW2, LW3, LW4 ), where +C LW1 = 0, if INIT = 'S' or 'N'; otherwise, +C LW1 = MAX( 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR, +C 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + +C MAX( LDW1, LDW2 ), +C (N+L)*(N+M) + N + N*N + 2 + N*(N+M+L) + +C MAX( 5*N, 2, MIN( LDW3, LDW4 ), LDW5, LDW6 ), +C where, +C LDW1 >= MAX( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, +C L*NOBR*N + +C MAX( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, +C 2*(L*NOBR-L)*N+N*N+8*N, +C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) +C LDW2 >= 0, if M = 0; +C LDW2 >= L*NOBR*N + M*NOBR*(N+L)*(M*(N+L)+1) + +C MAX( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; +C LDW3 = NSMP*L*(N+1) + 2*N + MAX( 2*N*N, 4*N ), +C LDW4 = N*(N+1) + 2*N + +C MAX( N*L*(N+1) + 2*N*N + L*N, 4*N ); +C LDW5 = NSMP*L + (N+L)*(N+M) + 3*N+M+L; +C LDW6 = NSMP*L + (N+L)*(N+M) + N + +C MAX(1, N*N*L + N*L + N, N*N + +C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), +C N*M)); +C LW2 = LW3 = 0, if INIT = 'L' or 'N'; otherwise, +C LW2 = NSMP*L + +C MAX( 5, NSMP + 2*BSN + NSMP*BSN + +C MAX( 2*NN + BSN, LDW7 ) ); +C LDW7 = BSN*BSN, if ALG = 'D' and STOR = 'F'; +C LDW7 = BSN*(BSN+1)/2, if ALG = 'D' and STOR = 'P'; +C LDW7 = 3*BSN + NSMP, if ALG = 'I'; +C LW3 = MAX( LDW8, NSMP*L + (N+L)*(2*N+M) + 2*N ); +C LDW8 = NSMP*L + (N+L)*(N+M) + 3*N+M+L, if M > 0; +C LDW8 = NSMP*L + (N+L)*N + 2*N+L, if M = 0; +C LW4 = MAX( 5, NSMP*L + 2*NX + NSMP*L*( BSN + LTHS ) + +C MAX( L1 + NX, NSMP*L + L1, L2 ) ), +C L0 = MAX( N*(N+L), N+M+L ), if M > 0; +C L0 = MAX( N*(N+L), L ), if M = 0; +C L1 = NSMP*L + MAX( 2*NN, (N+L)*(N+M) + 2*N + L0); +C L2 = NX*NX, if ALG = 'D' and STOR = 'F'; +C L2 = NX*(NX+1)/2, if ALG = 'D' and STOR = 'P'; +C L2 = 3*NX + NSMP*L, if ALG = 'I', +C with BSN = NN*( L + 2 ) + 1, +C LTHS = N*( L + M + 1 ) + L*M. +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C < 0: the user set IFLAG = IWARN in (one of) the +C subroutine(s) FCN, i.e., NF01BA, if INIT = 'S' +C or 'B', and/or NF01BB; this value cannot be returned +C without changing the FCN routine(s); +C otherwise, IWARN has the value k*100 + j*10 + i, +C where k is defined below, i refers to the whole +C optimization process, and j refers to the +C initialization step (j = 0, if INIT = 'L' or 'N'), +C and the possible values for i and j have the +C following meaning (where TOL* denotes TOL1 or TOL2, +C and similarly for ITMAX*): +C = 1: the number of iterations has reached ITMAX* without +C satisfying the convergence condition; +C = 2: if alg = 'I' and in an iteration of the Levenberg- +C Marquardt algorithm, the CG algorithm finished +C after 3*NX iterations (or 3*(lin1-1) iterations, for +C the initialization phase), without achieving the +C precision required in the call; +C = 3: the cosine of the angle between the vector of error +C function values and any column of the Jacobian is at +C most FACTOR*EPS in absolute value (FACTOR = 100); +C = 4: TOL* is too small: no further reduction in the sum +C of squares is possible. +C The digit k is normally 0, but if INIT = 'L' or 'B', it +C can have a value in the range 1 to 6 (see IB01AD, IB01BD +C and IB01CD). In all these cases, the entries DWORK(1:5), +C DWORK(6:10) (if INIT = 'S' or 'B'), and +C DWORK(11:10+IWORK(3)) (if INIT = 'L' or 'B'), are set as +C described above. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C otherwise, INFO has the value k*100 + j*10 + i, +C where k is defined below, i refers to the whole +C optimization process, and j refers to the +C initialization step (j = 0, if INIT = 'L' or 'N'), +C and the possible values for i and j have the +C following meaning: +C = 1: the routine FCN returned with INFO <> 0 for +C IFLAG = 1; +C = 2: the routine FCN returned with INFO <> 0 for +C IFLAG = 2; +C = 3: ALG = 'D' and SLICOT Library routines MB02XD or +C NF01BU (or NF01BV, if INIT = 'S' or 'B') or +C ALG = 'I' and SLICOT Library routines MB02WD or +C NF01BW (or NF01BX, if INIT = 'S' or 'B') returned +C with INFO <> 0. +C In addition, if INIT = 'L' or 'B', i could also be +C = 4: if a Lyapunov equation could not be solved; +C = 5: if the identified linear system is unstable; +C = 6: if the QR algorithm failed on the state matrix +C of the identified linear system. +C The digit k is normally 0, but if INIT = 'L' or 'B', it +C can have a value in the range 1 to 10 (see IB01AD/IB01BD). +C +C METHOD +C +C If INIT = 'L' or 'B', the linear part of the system is +C approximated using the combined MOESP and N4SID algorithm. If +C necessary, this algorithm can also choose the order, but it is +C advantageous if the order is already known. +C +C If INIT = 'S' or 'B', the output of the approximated linear part +C is computed and used to calculate an approximation of the static +C nonlinearity using the Levenberg-Marquardt algorithm [1]. +C This step is referred to as the (nonlinear) initialization step. +C +C As last step, the Levenberg-Marquardt algorithm is used again to +C optimize the parameters of the linear part and the static +C nonlinearity as a whole. Therefore, it is necessary to parametrise +C the matrices of the linear part. The output normal form [2] +C parameterisation is used. +C +C The Jacobian is computed analytically, for the nonlinear part, and +C numerically, for the linear part. +C +C REFERENCES +C +C [1] Kelley, C.T. +C Iterative Methods for Optimization. +C Society for Industrial and Applied Mathematics (SIAM), +C Philadelphia (Pa.), 1999. +C +C [2] Peeters, R.L.M., Hanzon, B., and Olivi, M. +C Balanced realizations of discrete-time stable all-pass +C systems and the tangential Schur algorithm. +C Proceedings of the European Control Conference, +C 31 August - 3 September 1999, Karlsruhe, Germany. +C Session CP-6, Discrete-time Systems, 1999. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Oct. 2000, during a stay at University of Twente, NL. +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, +C Mar. 2002, Apr. 2002, Feb. 2004, March 2005, Nov. 2005. +C +C KEYWORDS +C +C Conjugate gradients, least-squares approximation, +C Levenberg-Marquardt algorithm, matrix operations, optimization. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C The upper triangular part is used in MD03AD; + CHARACTER UPLO + PARAMETER ( UPLO = 'U' ) +C For INIT = 'L' or 'B', additional parameters are set: +C The following six parameters are used in the call of IB01AD; + CHARACTER IALG, BATCH, CONCT, CTRL, JOBD, METH + PARAMETER ( IALG = 'Fast QR', BATCH = 'One batch', + $ CONCT = 'Not connect', CTRL = 'Not confirm', + $ JOBD = 'Not MOESP', METH = 'MOESP' ) +C The following three parameters are used in the call of IB01BD; + CHARACTER JOB, JOBCK, METHB + PARAMETER ( JOB = 'All matrices', + $ JOBCK = 'No Kalman gain', + $ METHB = 'Combined MOESP+N4SID' ) +C The following two parameters are used in the call of IB01CD; + CHARACTER COMUSE, JOBXD + PARAMETER ( COMUSE = 'Use B, D', + $ JOBXD = 'D also' ) +C TOLN controls the estimated order in IB01AD (default value); + DOUBLE PRECISION TOLN + PARAMETER ( TOLN = -1.0D0 ) +C RCOND controls the rank decisions in IB01AD, IB01BD, and IB01CD +C (default); + DOUBLE PRECISION RCOND + PARAMETER ( RCOND = -1.0D0 ) +C .. Scalar Arguments .. + CHARACTER ALG, INIT, STOR + INTEGER INFO, ITMAX1, ITMAX2, IWARN, L, LDU, LDWORK, + $ LDY, LX, M, N, NN, NOBR, NPRINT, NSMP + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), U(LDU, *), X(*), Y(LDY, *) + INTEGER IWORK(*) +C .. Local Scalars .. + INTEGER AC, BD, BSN, I, IA, IB, IK, INFOL, IQ, IR, + $ IRCND, IRCNDB, IRY, IS, ISAD, ISV, IV, IW1, IW2, + $ IWARNL, IX, IX0, J, JWORK, LDAC, LDR, LIPAR, + $ LNOL, LTHS, ML, MNO, N2, NFEV, NJEV, NS, NSML, + $ NTHS, NX, WRKOPT, Z + LOGICAL CHOL, FULL, INIT1, INIT2 +C .. Local Arrays .. + LOGICAL BWORK(1) + INTEGER IPAR(7) + DOUBLE PRECISION RCND(16), SEED(4), WORK(5) +C .. External Functions .. + EXTERNAL LSAME + LOGICAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, IB01AD, IB01BD, IB01CD, MD03AD, NF01BA, + $ NF01BB, NF01BU, NF01BV, NF01BW, NF01BX, TB01VD, + $ TB01VY, TF01MX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. +C .. Executable Statements .. +C + CHOL = LSAME( ALG, 'D' ) + FULL = LSAME( STOR, 'F' ) + INIT1 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'L' ) + INIT2 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'S' ) +C + ML = M + L + INFO = 0 + IWARN = 0 + IF ( .NOT.( INIT1 .OR. INIT2 .OR. LSAME( INIT, 'N' ) ) ) THEN + INFO = -1 + ELSEIF ( .NOT.( CHOL .OR. LSAME( ALG, 'I' ) ) ) THEN + INFO = -2 + ELSEIF ( CHOL .AND. .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN + INFO = -3 + ELSEIF ( INIT1 .AND. NOBR.LE.0 ) THEN + INFO = -4 + ELSEIF ( M.LT.0 ) THEN + INFO = -5 + ELSEIF ( L.LT.0 .OR. ( INIT1 .AND. L.EQ.0 ) ) THEN + INFO = -6 + ELSEIF ( NSMP.LT.0 .OR. + $ ( INIT1 .AND. NSMP.LT.2*( ML + 1 )*NOBR - 1 ) ) THEN + INFO = -7 + ELSEIF ( ( N.LT.0 .AND. .NOT.INIT1 ) .OR. + $ ( ( N.EQ.0 .OR. N.GE.NOBR ) .AND. INIT1 ) ) THEN + INFO = -8 + ELSEIF ( NN.LT.0 ) THEN + INFO = -9 + ELSEIF ( INIT2 .AND. ( ITMAX1.LT.0 ) ) THEN + INFO = -10 + ELSEIF ( ITMAX2.LT.0 ) THEN + INFO = -11 + ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN + INFO = -14 + ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN + INFO = -16 + ELSE + LNOL = L*NOBR - L + MNO = M*NOBR + BSN = NN*( L + 2 ) + 1 + NTHS = BSN*L + NSML = NSMP*L + IF ( N.GT.0 ) THEN + LDAC = N + L + ISAD = LDAC*( N + M ) + N2 = N*N + END IF +C +C Check the workspace size. +C + JWORK = 0 + IF ( INIT1 ) THEN +C Workspace for IB01AD. + JWORK = 2*ML*NOBR*( 2*ML*( NOBR + 1 ) + 3 ) + L*NOBR + IF ( N.GT.0 ) THEN +C Workspace for IB01BD. + IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + + $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, + $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + + $ 1, MNO + 3*N + L ) ) + IF ( M.GT.0 ) THEN + IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + + $ MAX( LDAC**2, 4*M*LDAC + 1 ) + ELSE + IW2 = 0 + END IF + JWORK = MAX( JWORK, + $ ( 2*ML*NOBR )**2 + ISAD + MAX( IW1, IW2 ) ) +C Workspace for IB01CD. + IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) + IW2 = N*( N + 1 ) + 2*N + + $ MAX( N*L*( N + 1 ) + 2*N2 + L*N, 4*N ) + JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + + $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) +C Workspace for TF01MX. + JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) +C Workspace for TB01VD. + JWORK = MAX( JWORK, NSML + ISAD + N + + $ MAX( 1, N2*L + N*L + N, + $ N2 + MAX( N2 + N*MAX( N, L ) + + $ 6*N + MIN( N, L ), N*M ) ) ) + END IF + END IF +C + IF ( INIT2 ) THEN +C Workspace for MD03AD (initialization of the nonlinear part). + IF ( CHOL ) THEN + IF ( FULL ) THEN + IW1 = BSN**2 + ELSE + IW1 = ( BSN*( BSN + 1 ) )/2 + END IF + ELSE + IW1 = 3*BSN + NSMP + END IF + JWORK = MAX( JWORK, NSML + + $ MAX( 5, NSMP + 2*BSN + NSMP*BSN + + $ MAX( 2*NN + BSN, IW1 ) ) ) + IF ( N.GT.0 .AND. .NOT.INIT1 ) THEN +C Workspace for TB01VY. + JWORK = MAX( JWORK, NSML + LDAC*( 2*N + M ) + 2*N ) +C Workspace for TF01MX. + IF ( M.GT.0 ) THEN + IW1 = N + M + ELSE + IW1 = 0 + END IF + JWORK = MAX( JWORK, NSML + ISAD + IW1 + LDAC + N ) + END IF + END IF +C + IF ( N.GE.0 ) THEN +C +C Find the number of parameters. +C + LTHS = N*( ML + 1 ) + L*M + NX = NTHS + LTHS +C + IF ( LX.LT.NX ) THEN + INFO = -18 + CALL XERBLA( 'IB03AD', -INFO ) + RETURN + END IF +C +C Workspace for MD03AD (whole optimization). +C + IF ( M.GT.0 ) THEN + IW1 = LDAC + M + ELSE + IW1 = L + END IF + IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) + IF ( CHOL ) THEN + IF ( FULL ) THEN + IW2 = NX**2 + ELSE + IW2 = ( NX*( NX + 1 ) )/2 + END IF + ELSE + IW2 = 3*NX + NSML + END IF + JWORK = MAX( JWORK, + $ 5, NSML + 2*NX + NSML*( BSN + LTHS ) + + $ MAX( IW1 + NX, NSML + IW1, IW2 ) ) + END IF +C + IF ( LDWORK.LT.JWORK ) THEN + INFO = -23 + DWORK(1) = JWORK + END IF + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB03AD', -INFO ) + RETURN + ENDIF +C +C Initialize the pointers to system matrices and save the possible +C seed for random numbers generation. +C + Z = 1 + AC = Z + NSML + CALL DCOPY( 4, DWORK, 1, SEED, 1 ) +C + WRKOPT = 1 +C + IF ( INIT1 ) THEN +C +C Initialize the linear part. +C If N < 0, the order of the system is determined by IB01AD; +C otherwise, the given order will be used. +C The workspace needed is defined for the options set above +C in the PARAMETER statements. +C Workspace: need: 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR; +C prefer: larger. +C Integer workspace: M+L. (If METH = 'N', (M+L)*NOBR.) +C + NS = N + IR = 1 + ISV = 2*ML*NOBR + LDR = ISV + IF ( LSAME( JOBD, 'M' ) ) + $ LDR = MAX( LDR, 3*MNO ) + ISV = IR + LDR*ISV + JWORK = ISV + L*NOBR +C + CALL IB01AD( METH, IALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, L, + $ NSMP, U, LDU, Y, LDY, N, DWORK(IR), LDR, + $ DWORK(ISV), RCOND, TOLN, IWORK, DWORK(JWORK), + $ LDWORK-JWORK+1, IWARNL, INFOL ) +C + IF( INFOL.NE.0 ) THEN + INFO = 100*INFOL + RETURN + END IF + IF( IWARNL.NE.0 ) + $ IWARN = 100*IWARNL + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IRCND = 0 + IF ( LSAME( METH, 'N' ) ) THEN + IRCND = 2 + CALL DCOPY( IRCND, DWORK(JWORK+1), 1, RCND, 1 ) + END IF +C + IF ( NS.GE.0 ) THEN + N = NS + ELSE +C +C Find the number of parameters. +C + LDAC = N + L + ISAD = LDAC*( N + M ) + N2 = N*N + LTHS = N*( ML + 1 ) + L*M + NX = NTHS + LTHS +C + IF ( LX.LT.NX ) THEN + LX = NX + INFO = -18 + CALL XERBLA( 'IB03AD', -INFO ) + RETURN + END IF +C Workspace for IB01BD. + IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + + $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, + $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + 1, + $ MNO + 3*N + L ) ) + IF ( M.GT.0 ) THEN + IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + + $ MAX( LDAC**2, 4*M*LDAC + 1 ) + ELSE + IW2 = 0 + END IF + JWORK = ISV + ISAD + MAX( IW1, IW2 ) +C Workspace for IB01CD. + IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) + IW2 = N*( N + 1 ) + 2*N + MAX( N*L*( N + 1 ) + 2*N2 + L*N, + $ 4*N ) + JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + + $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) +C Workspace for TF01MX. + JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) +C Workspace for TB01VD. + JWORK = MAX( JWORK, NSML + ISAD + N + + $ MAX( 1, N2*L + N*L + N, + $ N2 + MAX( N2 + N*MAX( N, L ) + + $ 6*N + MIN( N, L ), N*M ) ) ) +C Workspace for MD03AD (whole optimization). + IF ( M.GT.0 ) THEN + IW1 = LDAC + M + ELSE + IW1 = L + END IF + IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) + IF ( CHOL ) THEN + IF ( FULL ) THEN + IW2 = NX**2 + ELSE + IW2 = ( NX*( NX + 1 ) )/2 + END IF + ELSE + IW2 = 3*NX + NSML + END IF + JWORK = MAX( JWORK, + $ 5, NSML + 2*NX + NSML*( BSN + LTHS ) + + $ MAX( IW1 + NX, NSML + IW1, IW2 ) ) + IF ( LDWORK.LT.JWORK ) THEN + INFO = -23 + DWORK(1) = JWORK + CALL XERBLA( 'IB03AD', -INFO ) + RETURN + END IF + END IF +C + BD = AC + LDAC*N + IX = BD + LDAC*M + IA = ISV + IB = IA + LDAC*N + IQ = IB + LDAC*M + IF ( LSAME( JOBCK, 'N' ) ) THEN + IRY = IQ + IS = IQ + IK = IQ + JWORK = IQ + ELSE + IRY = IQ + N2 + IS = IRY + L*L + IK = IS + N*L + JWORK = IK + N*L + END IF +C +C The workspace needed is defined for the options set above +C in the PARAMETER statements. +C Workspace: +C need: 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + +C max( LDW1,LDW2 ), where, +C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, +C L*NOBR*N + +C max( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, +C 2*(L*NOBR-L)*N+N*N+8*N, +C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) +C LDW2 >= 0, if M = 0; +C LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+ +C max( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; +C prefer: larger. +C Integer workspace: MAX(M*NOBR+N,M*(N+L)). +C + CALL IB01BD( METHB, JOB, JOBCK, NOBR, N, M, L, NSMP, DWORK(IR), + $ LDR, DWORK(IA), LDAC, DWORK(IA+N), LDAC, + $ DWORK(IB), LDAC, DWORK(IB+N), LDAC, DWORK(IQ), N, + $ DWORK(IRY), L, DWORK(IS), N, DWORK(IK), N, RCOND, + $ IWORK, DWORK(JWORK), LDWORK-JWORK+1, BWORK, + $ IWARNL, INFOL ) +C + IF( INFOL.EQ.-30 ) THEN + INFO = -23 + DWORK(1) = DWORK(JWORK) + CALL XERBLA( 'IB03AD', -INFO ) + RETURN + END IF + IF( INFOL.NE.0 ) THEN + INFO = 100*INFOL + RETURN + END IF + IF( IWARNL.NE.0 ) + $ IWARN = 100*IWARNL + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IRCNDB = 4 + IF ( LSAME( JOBCK, 'K' ) ) + $ IRCNDB = IRCNDB + 8 + CALL DCOPY( IRCNDB, DWORK(JWORK+1), 1, RCND(IRCND+1), 1 ) + IRCND = IRCND + IRCNDB +C +C Copy the system matrices to the beginning of DWORK, to save +C space, and redefine the pointers. +C + CALL DCOPY( ISAD, DWORK(IA), 1, DWORK, 1 ) + IA = 1 + IB = IA + LDAC*N + IX0 = IB + LDAC*M + IV = IX0 + N +C +C Compute the initial condition of the system. On normal exit, +C DWORK(i), i = JWORK+2:JWORK+1+N*N, +C DWORK(j), j = JWORK+2+N*N:JWORK+1+N*N+L*N, and +C DWORK(k), k = JWORK+2+N*N+L*N:JWORK+1+N*N+L*N+N*M, +C contain the transformed system matrices At, Ct, and Bt, +C respectively, corresponding to the real Schur form of the +C estimated system state matrix A. The transformation matrix is +C stored in DWORK(IV:IV+N*N-1). +C The workspace needed is defined for the options set above +C in the PARAMETER statements. +C Workspace: +C need: (N+L)*(N+M) + N + N*N + 2 + N*( N + M + L ) + +C max( 5*N, 2, min( LDW1, LDW2 ) ), where, +C LDW1 = NSMP*L*(N + 1) + 2*N + max( 2*N*N, 4*N), +C LDW2 = N*(N + 1) + 2*N + +C max( N*L*(N + 1) + 2*N*N + L*N, 4*N); +C prefer: larger. +C Integer workspace: N. +C + JWORK = IV + N2 + CALL IB01CD( 'X needed', COMUSE, JOBXD, N, M, L, NSMP, + $ DWORK(IA), LDAC, DWORK(IB), LDAC, DWORK(IA+N), + $ LDAC, DWORK(IB+N), LDAC, U, LDU, Y, LDY, + $ DWORK(IX0), DWORK(IV), N, RCOND, IWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFOL ) +C + IF( INFOL.EQ.-26 ) THEN + INFO = -23 + DWORK(1) = DWORK(JWORK) + CALL XERBLA( 'IB03AD', -INFO ) + RETURN + END IF + IF( INFOL.EQ.1 ) + $ INFOL = 10 + IF( INFOL.NE.0 ) THEN + INFO = 100*INFOL + RETURN + END IF + IF( IWARNL.NE.0 ) + $ IWARN = 100*IWARNL + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IRCND = IRCND + 1 + RCND(IRCND) = DWORK(JWORK+1) +C +C Now, save the system matrices and x0 in the final location. +C + IF ( IV.LT.AC ) THEN + CALL DCOPY( ISAD+N, DWORK(IA), 1, DWORK(AC), 1 ) + ELSE + DO 5 J = AC + ISAD + N - 1, AC, -1 + DWORK(J) = DWORK(IA+J-AC) + 5 CONTINUE + END IF +C +C Compute the output of the linear part. +C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, +C if M > 0; +C NSMP*L + (N + L)*N + 2*N + L, if M = 0; +C prefer larger. +C + JWORK = IX + N + CALL DCOPY( N, DWORK(IX), 1, X(NTHS+1), 1 ) + CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, X(NTHS+1), + $ DWORK(Z), NSMP, DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) +C +C Convert the state-space representation to output normal form. +C Workspace: +C need: NSMP*L + (N + L)*(N + M) + N + +C MAX(1, N*N*L + N*L + N, N*N + +C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), N*M)); +C prefer: larger. +C + CALL TB01VD( 'Apply', N, M, L, DWORK(AC), LDAC, DWORK(BD), + $ LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), LDAC, + $ DWORK(IX), X(NTHS+1), LTHS, DWORK(JWORK), + $ LDWORK-JWORK+1, INFOL ) +C + IF( INFOL.GT.0 ) THEN + INFO = INFOL + 3 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + END IF +C + LIPAR = 7 + IW1 = 0 + IW2 = 0 +C + IF ( INIT2 ) THEN +C +C Initialize the nonlinear part. +C + IF ( .NOT.INIT1 ) THEN + BD = AC + LDAC*N + IX = BD + LDAC*M +C +C Convert the output normal form to state-space model. +C Workspace: need NSMP*L + (N + L)*(2*N + M) + 2*N. +C (NSMP*L locations are reserved for the output of the linear +C part.) +C + JWORK = IX + N + CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), + $ LDAC, DWORK(BD), LDAC, DWORK(AC+N), LDAC, + $ DWORK(BD+N), LDAC, DWORK(IX), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) +C +C Compute the output of the linear part. +C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, +C if M > 0; +C NSMP*L + (N + L)*N + 2*N + L, if M = 0; +C prefer larger. +C + CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, + $ DWORK(IX), DWORK(Z), NSMP, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + END IF +C +C Optimize the parameters of the nonlinear part. +C Workspace: +C need NSMP*L + +C MAX( 5, NSMP + 2*BSN + NSMP*BSN + +C MAX( 2*NN + BSN, DW( sol ) ) ), +C where, if ALG = 'D', +C DW( sol ) = BSN*BSN, if STOR = 'F'; +C DW( sol ) = BSN*(BSN+1)/2, if STOR = 'P'; +C and DW( sol ) = 3*BSN + NSMP, if ALG = 'I'; +C prefer larger. +C + JWORK = AC + WORK(1) = ZERO + CALL DCOPY( 4, WORK(1), 0, WORK(2), 1 ) +C +C Set the integer parameters needed, including the number of +C neurons. +C + IPAR(1) = NSMP + IPAR(2) = L + IPAR(3) = NN +C + DO 10 I = 0, L - 1 + CALL DCOPY( 4, SEED, 1, DWORK(JWORK), 1 ) + IF ( CHOL ) THEN + CALL MD03AD( 'Random initialization', ALG, STOR, UPLO, + $ NF01BA, NF01BV, NSMP, BSN, ITMAX1, NPRINT, + $ IPAR, LIPAR, DWORK(Z), NSMP, Y(1,I+1), LDY, + $ X(I*BSN+1), NFEV, NJEV, TOL1, TOL1, + $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, + $ INFOL ) + ELSE + CALL MD03AD( 'Random initialization', ALG, STOR, UPLO, + $ NF01BA, NF01BX, NSMP, BSN, ITMAX1, NPRINT, + $ IPAR, LIPAR, DWORK(Z), NSMP, Y(1,I+1), LDY, + $ X(I*BSN+1), NFEV, NJEV, TOL1, TOL1, + $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, + $ INFOL ) + END IF +C + IF( INFOL.NE.0 ) THEN + INFO = 10*INFOL + RETURN + END IF + IF ( IWARNL.LT.0 ) THEN + INFO = INFOL + IWARN = IWARNL + GO TO 20 + ELSEIF ( IWARNL.GT.0 ) THEN + IF ( IWARN.GT.100 ) THEN + IWARN = MAX( IWARN, ( IWARN/100 )*100 + 10*IWARNL ) + ELSE + IWARN = MAX( IWARN, 10*IWARNL ) + END IF + END IF + WORK(1) = MAX( WORK(1), DWORK(JWORK) ) + WORK(2) = MAX( WORK(2), DWORK(JWORK+1) ) + WORK(5) = MAX( WORK(5), DWORK(JWORK+4) ) + WORK(3) = WORK(3) + DWORK(JWORK+2) + WORK(4) = WORK(4) + DWORK(JWORK+3) + IW1 = NFEV + IW1 + IW2 = NJEV + IW2 + 10 CONTINUE +C + ENDIF +C +C Main iteration. +C Workspace: need MAX( 5, NFUN + 2*NX + NFUN*( BSN + LTHS ) + +C MAX( LDW1 + NX, NFUN + LDW1, DW( sol ) ) ), +C where NFUN = NSMP*L, and +C LDW1 = NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + +C MAX( N*(N + L), N + M + L )), +C if M > 0, +C LDW1 = NFUN + MAX( 2*NN, (N + L)*N + 2*N + +C MAX( N*(N + L), L ) ), +C if M = 0; +C if ALG = 'D', +C DW( sol ) = NX*NX, if STOR = 'F'; +C DW( sol ) = NX*(NX+1)/2, if STOR = 'P'; +C and DW( sol ) = 3*NX + NFUN, if ALG = 'I', +C and DW( f ) is the workspace needed by the +C subroutine f; +C prefer larger. +C +C Set the integer parameters describing the Jacobian structure +C and the number of neurons. +C + IPAR(1) = LTHS + IPAR(2) = L + IPAR(3) = NSMP + IPAR(4) = BSN + IPAR(5) = M + IPAR(6) = N + IPAR(7) = NN +C + IF ( CHOL ) THEN + CALL MD03AD( 'Given initialization', ALG, STOR, UPLO, NF01BB, + $ NF01BU, NSML, NX, ITMAX2, NPRINT, IPAR, LIPAR, + $ U, LDU, Y, LDY, X, NFEV, NJEV, TOL2, TOL2, + $ DWORK, LDWORK, IWARNL, INFO ) + ELSE + CALL MD03AD( 'Given initialization', ALG, STOR, UPLO, NF01BB, + $ NF01BW, NSML, NX, ITMAX2, NPRINT, IPAR, LIPAR, + $ U, LDU, Y, LDY, X, NFEV, NJEV, TOL2, TOL2, + $ DWORK, LDWORK, IWARNL, INFO ) + END IF +C + IF( INFO.NE.0 ) + $ RETURN +C + 20 CONTINUE + IWORK(1) = IW1 + NFEV + IWORK(2) = IW2 + NJEV + IF ( IWARNL.LT.0 ) THEN + IWARN = IWARNL + ELSE + IWARN = IWARN + IWARNL + END IF + IF ( INIT2 ) + $ CALL DCOPY( 5, WORK, 1, DWORK(6), 1 ) + IF ( INIT1 ) THEN + IWORK(3) = IRCND + CALL DCOPY( IRCND, RCND, 1, DWORK(11), 1 ) + ELSE + IWORK(3) = 0 + END IF + RETURN +C +C *** Last line of IB03AD *** + END diff --git a/mex/sources/libslicot/IB03BD.f b/mex/sources/libslicot/IB03BD.f new file mode 100644 index 000000000..a1e0e86de --- /dev/null +++ b/mex/sources/libslicot/IB03BD.f @@ -0,0 +1,1087 @@ + SUBROUTINE IB03BD( INIT, NOBR, M, L, NSMP, N, NN, ITMAX1, ITMAX2, + $ NPRINT, U, LDU, Y, LDY, X, LX, TOL1, TOL2, + $ IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a set of parameters for approximating a Wiener system +C in a least-squares sense, using a neural network approach and a +C MINPACK-like Levenberg-Marquardt algorithm. The Wiener system +C consists of a linear part and a static nonlinearity, and it is +C represented as +C +C x(t+1) = A*x(t) + B*u(t) +C z(t) = C*x(t) + D*u(t), +C +C y(t) = f(z(t),wb(1:L)), +C +C where t = 1, 2, ..., NSMP, and f is a nonlinear function, +C evaluated by the SLICOT Library routine NF01AY. The parameter +C vector X is partitioned as X = ( wb(1), ..., wb(L), theta ), +C where theta corresponds to the linear part, and wb(i), i = 1 : L, +C correspond to the nonlinear part. See SLICOT Library routine +C NF01AD for further details. +C +C The sum of squares of the error functions, defined by +C +C e(t) = y(t) - Y(t), t = 1, 2, ..., NSMP, +C +C is minimized, where Y(t) is the measured output vector. The +C functions and their Jacobian matrices are evaluated by SLICOT +C Library routine NF01BF (the FCN routine in the call of MD03BD). +C +C ARGUMENTS +C +C Mode Parameters +C +C INIT CHARACTER*1 +C Specifies which parts have to be initialized, as follows: +C = 'L' : initialize the linear part only, X already +C contains an initial approximation of the +C nonlinearity; +C = 'S' : initialize the static nonlinearity only, X +C already contains an initial approximation of the +C linear part; +C = 'B' : initialize both linear and nonlinear parts; +C = 'N' : do not initialize anything, X already contains +C an initial approximation. +C If INIT = 'S' or 'B', the error functions for the +C nonlinear part, and their Jacobian matrices, are evaluated +C by SLICOT Library routine NF01BE (used as a second FCN +C routine in the MD03BD call for the initialization step, +C see METHOD). +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C If INIT = 'L' or 'B', NOBR is the number of block rows, s, +C in the input and output block Hankel matrices to be +C processed for estimating the linear part. NOBR > 0. +C (In the MOESP theory, NOBR should be larger than n, +C the estimated dimension of state vector.) +C This parameter is ignored if INIT is 'S' or 'N'. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L >= 0, and L > 0, if +C INIT = 'L' or 'B'. +C +C NSMP (input) INTEGER +C The number of input and output samples, t. NSMP >= 0, and +C NSMP >= 2*(M+L+1)*NOBR - 1, if INIT = 'L' or 'B'. +C +C N (input/output) INTEGER +C The order of the linear part. +C If INIT = 'L' or 'B', and N < 0 on entry, the order is +C assumed unknown and it will be found by the routine. +C Otherwise, the input value will be used. If INIT = 'S' +C or 'N', N must be non-negative. The values N >= NOBR, +C or N = 0, are not acceptable if INIT = 'L' or 'B'. +C +C NN (input) INTEGER +C The number of neurons which shall be used to approximate +C the nonlinear part. NN >= 0. +C +C ITMAX1 (input) INTEGER +C The maximum number of iterations for the initialization of +C the static nonlinearity. +C This parameter is ignored if INIT is 'N' or 'L'. +C Otherwise, ITMAX1 >= 0. +C +C ITMAX2 (input) INTEGER +C The maximum number of iterations. ITMAX2 >= 0. +C +C NPRINT (input) INTEGER +C This parameter enables controlled printing of iterates if +C it is positive. In this case, FCN is called with IFLAG = 0 +C at the beginning of the first iteration and every NPRINT +C iterations thereafter and immediately prior to return, +C and the current error norm is printed. Other intermediate +C results could be printed by modifying the corresponding +C FCN routine (NF01BE and/or NF01BF). If NPRINT <= 0, no +C special calls of FCN with IFLAG = 0 are made. +C +C U (input) DOUBLE PRECISION array, dimension (LDU, M) +C The leading NSMP-by-M part of this array must contain the +C set of input samples, +C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,NSMP). +C +C Y (input) DOUBLE PRECISION array, dimension (LDY, L) +C The leading NSMP-by-L part of this array must contain the +C set of output samples, +C Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ). +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= MAX(1,NSMP). +C +C X (input/output) DOUBLE PRECISION array dimension (LX) +C On entry, if INIT = 'L', the leading (NN*(L+2) + 1)*L part +C of this array must contain the initial parameters for +C the nonlinear part of the system. +C On entry, if INIT = 'S', the elements lin1 : lin2 of this +C array must contain the initial parameters for the linear +C part of the system, corresponding to the output normal +C form, computed by SLICOT Library routine TB01VD, where +C lin1 = (NN*(L+2) + 1)*L + 1; +C lin2 = (NN*(L+2) + 1)*L + N*(L+M+1) + L*M. +C On entry, if INIT = 'N', the elements 1 : lin2 of this +C array must contain the initial parameters for the +C nonlinear part followed by the initial parameters for the +C linear part of the system, as specified above. +C This array need not be set on entry if INIT = 'B'. +C On exit, the elements 1 : lin2 of this array contain the +C optimal parameters for the nonlinear part followed by the +C optimal parameters for the linear part of the system, as +C specified above. +C +C LX (input/output) INTEGER +C On entry, this parameter must contain the intended length +C of X. If N >= 0, then LX >= NX := lin2 (see parameter X). +C If N is unknown (N < 0 on entry), a large enough estimate +C of N should be used in the formula of lin2. +C On exit, if N < 0 on entry, but LX is not large enough, +C then this parameter contains the actual length of X, +C corresponding to the computed N. Otherwise, its value +C is unchanged. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If INIT = 'S' or 'B' and TOL1 >= 0, TOL1 is the tolerance +C which measures the relative error desired in the sum of +C squares, as well as the relative error desired in the +C approximate solution, for the initialization step of +C nonlinear part. Termination occurs when either both the +C actual and predicted relative reductions in the sum of +C squares, or the relative error between two consecutive +C iterates are at most TOL1. If the user sets TOL1 < 0, +C then SQRT(EPS) is used instead TOL1, where EPS is the +C machine precision (see LAPACK Library routine DLAMCH). +C This parameter is ignored if INIT is 'N' or 'L'. +C +C TOL2 DOUBLE PRECISION +C If TOL2 >= 0, TOL2 is the tolerance which measures the +C relative error desired in the sum of squares, as well as +C the relative error desired in the approximate solution, +C for the whole optimization process. Termination occurs +C when either both the actual and predicted relative +C reductions in the sum of squares, or the relative error +C between two consecutive iterates are at most TOL2. If the +C user sets TOL2 < 0, then SQRT(EPS) is used instead TOL2. +C This default value could require many iterations, +C especially if TOL1 is larger. If INIT = 'S' or 'B', it is +C advisable that TOL2 be larger than TOL1, and spend more +C time with cheaper iterations. +C +C Workspace +C +C IWORK INTEGER array, dimension (MAX( LIW1, LIW2, LIW3 )), where +C LIW1 = LIW2 = 0, if INIT = 'S' or 'N'; otherwise, +C LIW1 = M+L; +C LIW2 = MAX(M*NOBR+N,M*(N+L)); +C LIW3 = 3+MAX(NN*(L+2)+2,NX+L), if INIT = 'S' or 'B'; +C LIW3 = 3+NX+L, if INIT = 'L' or 'N'. +C On output, if INFO = 0, IWORK(1) and IWORK(2) return the +C (total) number of function and Jacobian evaluations, +C respectively (including the initialization step, if it was +C performed), and if INIT = 'L' or INIT = 'B', IWORK(3) +C specifies how many locations of DWORK contain reciprocal +C condition number estimates (see below); otherwise, +C IWORK(3) = 0. If INFO = 0, the entries 4 to 3+NX of IWORK +C define a permutation matrix P such that J*P = Q*R, where +C J is the final calculated Jacobian, Q is an orthogonal +C matrix (not stored), and R is upper triangular with +C diagonal elements of nonincreasing magnitude (possibly +C for each block column of J). Column j of P is column +C IWORK(3+j) of the identity matrix. Moreover, the entries +C 4+NX:3+NX+L of this array contain the ranks of the final +C submatrices S_k (see description of LMPARM in MD03BD). +C +C DWORK DOUBLE PRECISION array dimesion (LDWORK) +C On entry, if desired, and if INIT = 'S' or 'B', the +C entries DWORK(1:4) are set to initialize the random +C numbers generator for the nonlinear part parameters (see +C the description of the argument XINIT of SLICOT Library +C routine MD03BD); this enables to obtain reproducible +C results. The same seed is used for all outputs. +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, DWORK(2) returns the residual error norm (the +C sum of squares), DWORK(3) returns the number of iterations +C performed, and DWORK(4) returns the final Levenberg +C factor, for optimizing the parameters of both the linear +C part and the static nonlinearity part. If INIT = 'S' or +C INIT = 'B' and INFO = 0, then the elements DWORK(5) to +C DWORK(8) contain the corresponding four values for the +C initialization step (see METHOD). (If L > 1, DWORK(8) +C contains the maximum of the Levenberg factors for all +C outputs.) If INIT = 'L' or INIT = 'B', and INFO = 0, +C DWORK(9) to DWORK(8+IWORK(3)) contain reciprocal condition +C number estimates set by SLICOT Library routines IB01AD, +C IB01BD, and IB01CD. +C On exit, if INFO = -21, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C In the formulas below, N should be taken not larger than +C NOBR - 1, if N < 0 on entry. +C LDWORK = MAX( LW1, LW2, LW3, LW4 ), where +C LW1 = 0, if INIT = 'S' or 'N'; otherwise, +C LW1 = MAX( 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR, +C 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + +C MAX( LDW1, LDW2 ), +C (N+L)*(N+M) + N + N*N + 2 + N*(N+M+L) + +C MAX( 5*N, 2, MIN( LDW3, LDW4 ), LDW5, LDW6 ), +C where, +C LDW1 >= MAX( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, +C L*NOBR*N + +C MAX( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, +C 2*(L*NOBR-L)*N+N*N+8*N, +C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) +C LDW2 >= 0, if M = 0; +C LDW2 >= L*NOBR*N + M*NOBR*(N+L)*(M*(N+L)+1) + +C MAX( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; +C LDW3 = NSMP*L*(N+1) + 2*N + MAX( 2*N*N, 4*N ), +C LDW4 = N*(N+1) + 2*N + +C MAX( N*L*(N+1) + 2*N*N + L*N, 4*N ); +C LDW5 = NSMP*L + (N+L)*(N+M) + 3*N+M+L; +C LDW6 = NSMP*L + (N+L)*(N+M) + N + +C MAX(1, N*N*L + N*L + N, N*N + +C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), +C N*M)); +C LW2 = LW3 = 0, if INIT = 'L' or 'N'; otherwise, +C LW2 = NSMP*L + BSN + +C MAX( 4, NSMP + +C MAX( NSMP*BSN + MAX( 2*NN, 5*BSN + 1 ), +C BSN**2 + BSN + +C MAX( NSMP + 2*NN, 5*BSN ) ) ); +C LW3 = MAX( LDW7, NSMP*L + (N+L)*(2*N+M) + 2*N ); +C LDW7 = NSMP*L + (N+L)*(N+M) + 3*N+M+L, if M > 0; +C LDW7 = NSMP*L + (N+L)*N + 2*N+L, if M = 0; +C LW4 = NSMP*L + NX + +C MAX( 4, NSMP*L + +C MAX( NSMP*L*( BSN + LTHS ) + +C MAX( NSMP*L + L1, L2 + NX ), +C NX*( BSN + LTHS ) + NX + +C MAX( NSMP*L + L1, NX + L3 ) ) ), +C L0 = MAX( N*(N+L), N+M+L ), if M > 0; +C L0 = MAX( N*(N+L), L ), if M = 0; +C L1 = NSMP*L + MAX( 2*NN, (N+L)*(N+M) + 2*N + L0); +C L2 = 4*NX + 1, if L <= 1 or BSN = 0; otherwise, +C L2 = BSN + MAX(3*BSN+1,LTHS); +C L2 = MAX(L2,4*LTHS+1), if NSMP > BSN; +C L2 = MAX(L2,(NSMP-BSN)*(L-1)), if BSN < NSMP < 2*BSN; +C L3 = 4*NX, if L <= 1 or BSN = 0; +C L3 = LTHS*BSN + 2*NX + 2*MAX(BSN,LTHS), +C if L > 1 and BSN > 0, +C with BSN = NN*( L + 2 ) + 1, +C LTHS = N*( L + M + 1 ) + L*M. +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C < 0: the user set IFLAG = IWARN in (one of) the +C subroutine(s) FCN, i.e., NF01BE, if INIT = 'S' +C or 'B', and/or NF01BF; this value cannot be returned +C without changing the FCN routine(s); +C otherwise, IWARN has the value k*100 + j*10 + i, +C where k is defined below, i refers to the whole +C optimization process, and j refers to the +C initialization step (j = 0, if INIT = 'L' or 'N'), +C and the possible values for i and j have the +C following meaning (where TOL* denotes TOL1 or TOL2, +C and similarly for ITMAX*): +C = 1: both actual and predicted relative reductions in +C the sum of squares are at most TOL*; +C = 2: relative error between two consecutive iterates is +C at most TOL*; +C = 3: conditions for i or j = 1 and i or j = 2 both hold; +C = 4: the cosine of the angle between the vector of error +C function values and any column of the Jacobian is at +C most EPS in absolute value; +C = 5: the number of iterations has reached ITMAX* without +C satisfying any convergence condition; +C = 6: TOL* is too small: no further reduction in the sum +C of squares is possible; +C = 7: TOL* is too small: no further improvement in the +C approximate solution X is possible; +C = 8: the vector of function values e is orthogonal to the +C columns of the Jacobian to machine precision. +C The digit k is normally 0, but if INIT = 'L' or 'B', it +C can have a value in the range 1 to 6 (see IB01AD, IB01BD +C and IB01CD). In all these cases, the entries DWORK(1:4), +C DWORK(5:8) (if INIT = 'S' or 'B'), and DWORK(9:8+IWORK(3)) +C (if INIT = 'L' or 'B'), are set as described above. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C otherwise, INFO has the value k*100 + j*10 + i, +C where k is defined below, i refers to the whole +C optimization process, and j refers to the +C initialization step (j = 0, if INIT = 'L' or 'N'), +C and the possible values for i and j have the +C following meaning: +C = 1: the routine FCN returned with INFO <> 0 for +C IFLAG = 1; +C = 2: the routine FCN returned with INFO <> 0 for +C IFLAG = 2; +C = 3: the routine QRFACT returned with INFO <> 0; +C = 4: the routine LMPARM returned with INFO <> 0. +C In addition, if INIT = 'L' or 'B', i could also be +C = 5: if a Lyapunov equation could not be solved; +C = 6: if the identified linear system is unstable; +C = 7: if the QR algorithm failed on the state matrix +C of the identified linear system. +C QRFACT and LMPARM are generic names for SLICOT Library +C routines NF01BS and NF01BP, respectively, for the whole +C optimization process, and MD03BA and MD03BB, respectively, +C for the initialization step (if INIT = 'S' or 'B'). +C The digit k is normally 0, but if INIT = 'L' or 'B', it +C can have a value in the range 1 to 10 (see IB01AD/IB01BD). +C +C METHOD +C +C If INIT = 'L' or 'B', the linear part of the system is +C approximated using the combined MOESP and N4SID algorithm. If +C necessary, this algorithm can also choose the order, but it is +C advantageous if the order is already known. +C +C If INIT = 'S' or 'B', the output of the approximated linear part +C is computed and used to calculate an approximation of the static +C nonlinearity using the Levenberg-Marquardt algorithm [1,3]. +C This step is referred to as the (nonlinear) initialization step. +C +C As last step, the Levenberg-Marquardt algorithm is used again to +C optimize the parameters of the linear part and the static +C nonlinearity as a whole. Therefore, it is necessary to parametrise +C the matrices of the linear part. The output normal form [2] +C parameterisation is used. +C +C The Jacobian is computed analytically, for the nonlinear part, and +C numerically, for the linear part. +C +C REFERENCES +C +C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. +C User's Guide for MINPACK-1. +C Applied Math. Division, Argonne National Laboratory, Argonne, +C Illinois, Report ANL-80-74, 1980. +C +C [2] Peeters, R.L.M., Hanzon, B., and Olivi, M. +C Balanced realizations of discrete-time stable all-pass +C systems and the tangential Schur algorithm. +C Proceedings of the European Control Conference, +C 31 August - 3 September 1999, Karlsruhe, Germany. +C Session CP-6, Discrete-time Systems, 1999. +C +C [3] More, J.J. +C The Levenberg-Marquardt algorithm: implementation and theory. +C In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in +C Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg +C and New York, pp. 105-116, 1978. +C +C NUMERICAL ASPECTS +C +C The Levenberg-Marquardt algorithm described in [3] is scaling +C invariant and globally convergent to (maybe local) minima. +C The convergence rate near a local minimum is quadratic, if the +C Jacobian is computed analytically, and linear, if the Jacobian +C is computed numerically. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C V. Sima, March, 2002, Apr. 2002, Feb. 2004, March 2005. +C +C KEYWORDS +C +C Least-squares approximation, Levenberg-Marquardt algorithm, +C matrix operations, optimization. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C FACTOR is a scaling factor for variables (see MD03BD). + DOUBLE PRECISION FACTOR + PARAMETER ( FACTOR = 100.0D0 ) +C Condition estimation and internal scaling of variables are used +C (see MD03BD). + CHARACTER COND, SCALE + PARAMETER ( COND = 'E', SCALE = 'I' ) +C Default tolerances are used in MD03BD for measuring the +C orthogonality between the vector of function values and columns +C of the Jacobian (GTOL), and for the rank estimations (TOL). + DOUBLE PRECISION GTOL, TOL + PARAMETER ( GTOL = 0.0D0, TOL = 0.0D0 ) +C For INIT = 'L' or 'B', additional parameters are set: +C The following six parameters are used in the call of IB01AD; + CHARACTER ALG, BATCH, CONCT, CTRL, JOBD, METH + PARAMETER ( ALG = 'Fast QR', BATCH = 'One batch', + $ CONCT = 'Not connect', CTRL = 'Not confirm', + $ JOBD = 'Not MOESP', METH = 'MOESP' ) +C The following three parameters are used in the call of IB01BD; + CHARACTER JOB, JOBCK, METHB + PARAMETER ( JOB = 'All matrices', + $ JOBCK = 'No Kalman gain', + $ METHB = 'Combined MOESP+N4SID' ) +C The following two parameters are used in the call of IB01CD; + CHARACTER COMUSE, JOBXD + PARAMETER ( COMUSE = 'Use B, D', + $ JOBXD = 'D also' ) +C TOLN controls the estimated order in IB01AD (default value); + DOUBLE PRECISION TOLN + PARAMETER ( TOLN = -1.0D0 ) +C RCOND controls the rank decisions in IB01AD, IB01BD, and IB01CD +C (default); + DOUBLE PRECISION RCOND + PARAMETER ( RCOND = -1.0D0 ) +C .. Scalar Arguments .. + CHARACTER INIT + INTEGER INFO, ITMAX1, ITMAX2, IWARN, L, LDU, LDWORK, + $ LDY, LX, M, N, NN, NOBR, NPRINT, NSMP + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), U(LDU, *), X(*), Y(LDY, *) + INTEGER IWORK(*) +C .. Local Scalars .. + INTEGER AC, BD, BSN, I, IA, IB, IDIAG, IK, INFOL, IQ, + $ IR, IRCND, IRCNDB, IRY, IS, ISAD, ISV, IV, IW1, + $ IW2, IW3, IWARNL, IX, IX0, J, JWORK, LDAC, LDR, + $ LIPAR, LNOL, LTHS, ML, MNO, N2, NFEV, NJEV, NS, + $ NSML, NTHS, NX, WRKOPT, Z + LOGICAL INIT1, INIT2 +C .. Local Arrays .. + LOGICAL BWORK(1) + INTEGER IPAR(7) + DOUBLE PRECISION RCND(16), SEED(4), WORK(4) +C .. External Functions .. + EXTERNAL LSAME + LOGICAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, IB01AD, IB01BD, IB01CD, MD03BA, MD03BB, + $ MD03BD, NF01BE, NF01BF, NF01BP, NF01BS, TB01VD, + $ TB01VY, TF01MX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INIT1 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'L' ) + INIT2 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'S' ) +C + ML = M + L + INFO = 0 + IWARN = 0 + IF ( .NOT.( INIT1 .OR. INIT2 .OR. LSAME( INIT, 'N' ) ) ) THEN + INFO = -1 + ELSEIF ( INIT1 .AND. NOBR.LE.0 ) THEN + INFO = -2 + ELSEIF ( M.LT.0 ) THEN + INFO = -3 + ELSEIF ( L.LT.0 .OR. ( INIT1 .AND. L.EQ.0 ) ) THEN + INFO = -4 + ELSEIF ( NSMP.LT.0 .OR. + $ ( INIT1 .AND. NSMP.LT.2*( ML + 1 )*NOBR - 1 ) ) THEN + INFO = -5 + ELSEIF ( ( N.LT.0 .AND. .NOT.INIT1 ) .OR. + $ ( ( N.EQ.0 .OR. N.GE.NOBR ) .AND. INIT1 ) ) THEN + INFO = -6 + ELSEIF ( NN.LT.0 ) THEN + INFO = -7 + ELSEIF ( INIT2 .AND. ( ITMAX1.LT.0 ) ) THEN + INFO = -8 + ELSEIF ( ITMAX2.LT.0 ) THEN + INFO = -9 + ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN + INFO = -12 + ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN + INFO = -14 + ELSE + LNOL = L*NOBR - L + MNO = M*NOBR + BSN = NN*( L + 2 ) + 1 + NTHS = BSN*L + NSML = NSMP*L + IF ( N.GT.0 ) THEN + LDAC = N + L + ISAD = LDAC*( N + M ) + N2 = N*N + END IF +C +C Check the workspace size. +C + JWORK = 0 + IF ( INIT1 ) THEN +C Workspace for IB01AD. + JWORK = 2*ML*NOBR*( 2*ML*( NOBR + 1 ) + 3 ) + L*NOBR + IF ( N.GT.0 ) THEN +C Workspace for IB01BD. + IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + + $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, + $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + + $ 1, MNO + 3*N + L ) ) + IF ( M.GT.0 ) THEN + IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + + $ MAX( LDAC**2, 4*M*LDAC + 1 ) + ELSE + IW2 = 0 + END IF + JWORK = MAX( JWORK, + $ ( 2*ML*NOBR )**2 + ISAD + MAX( IW1, IW2 ) ) +C Workspace for IB01CD. + IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) + IW2 = N*( N + 1 ) + 2*N + + $ MAX( N*L*( N + 1 ) + 2*N2 + L*N, 4*N ) + JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + + $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) +C Workspace for TF01MX. + JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) +C Workspace for TB01VD. + JWORK = MAX( JWORK, NSML + ISAD + N + + $ MAX( 1, N2*L + N*L + N, + $ N2 + MAX( N2 + N*MAX( N, L ) + + $ 6*N + MIN( N, L ), N*M ) ) ) + END IF + END IF +C + IF ( INIT2 ) THEN +C Workspace for MD03BD (initialization of the nonlinear part). + JWORK = MAX( JWORK, NSML + BSN + + $ MAX( 4, NSMP + + $ MAX( NSMP*BSN + MAX( 2*NN, 5*BSN + 1 ), + $ BSN**2 + BSN + + $ MAX( NSMP + 2*NN, 5*BSN ) ) ) ) + IF ( N.GT.0 .AND. .NOT.INIT1 ) THEN +C Workspace for TB01VY. + JWORK = MAX( JWORK, NSML + LDAC*( 2*N + M ) + 2*N ) +C Workspace for TF01MX. + IF ( M.GT.0 ) THEN + IW1 = N + M + ELSE + IW1 = 0 + END IF + JWORK = MAX( JWORK, NSML + ISAD + IW1 + LDAC + N ) + END IF + END IF +C + IF ( N.GE.0 ) THEN +C +C Find the number of parameters. +C + LTHS = N*( ML + 1 ) + L*M + NX = NTHS + LTHS +C + IF ( LX.LT.NX ) THEN + INFO = -16 + CALL XERBLA( 'IB03BD', -INFO ) + RETURN + END IF +C +C Workspace for MD03BD (whole optimization). +C + IF ( M.GT.0 ) THEN + IW1 = LDAC + M + ELSE + IW1 = L + END IF + IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) + IF ( L.LE.1 .OR. BSN.EQ.0 ) THEN + IW3 = 4*NX + IW2 = IW3 + 1 + ELSE + IW2 = BSN + MAX( 3*BSN + 1, LTHS ) + IF ( NSMP.GT.BSN ) THEN + IW2 = MAX( IW2, 4*LTHS + 1 ) + IF ( NSMP.LT.2*BSN ) + $ IW2 = MAX( IW2, ( NSMP - BSN )*( L - 1 ) ) + END IF + IW3 = LTHS*BSN + 2*NX + 2*MAX( BSN, LTHS ) + END IF + JWORK = MAX( JWORK, NSML + NX + + $ MAX( 4, NSML + + $ MAX( NSML*( BSN + LTHS ) + + $ MAX( NSML + IW1, IW2 + NX ), + $ NX*( BSN + LTHS ) + NX + + $ MAX( NSML + IW1, NX + IW3 ) ) + $ ) ) + END IF +C + IF ( LDWORK.LT.JWORK ) THEN + INFO = -21 + DWORK(1) = JWORK + END IF + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB03BD', -INFO ) + RETURN + END IF +C +C Initialize the pointers to system matrices and save the possible +C seed for random numbers generation. +C + Z = 1 + AC = Z + NSML + CALL DCOPY( 4, DWORK, 1, SEED, 1 ) +C + WRKOPT = 1 +C + IF ( INIT1 ) THEN +C +C Initialize the linear part. +C If N < 0, the order of the system is determined by IB01AD; +C otherwise, the given order will be used. +C The workspace needed is defined for the options set above +C in the PARAMETER statements. +C Workspace: need: 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR; +C prefer: larger. +C Integer workspace: M+L. (If METH = 'N', (M+L)*NOBR.) +C + NS = N + IR = 1 + ISV = 2*ML*NOBR + LDR = ISV + IF ( LSAME( JOBD, 'M' ) ) + $ LDR = MAX( LDR, 3*MNO ) + ISV = IR + LDR*ISV + JWORK = ISV + L*NOBR +C + CALL IB01AD( METH, ALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, L, + $ NSMP, U, LDU, Y, LDY, N, DWORK(IR), LDR, + $ DWORK(ISV), RCOND, TOLN, IWORK, DWORK(JWORK), + $ LDWORK-JWORK+1, IWARNL, INFOL ) +C + IF( INFOL.NE.0 ) THEN + INFO = 100*INFOL + RETURN + END IF + IF( IWARNL.NE.0 ) + $ IWARN = 100*IWARNL + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IRCND = 0 + IF ( LSAME( METH, 'N' ) ) THEN + IRCND = 2 + CALL DCOPY( IRCND, DWORK(JWORK+1), 1, RCND, 1 ) + END IF +C + IF ( NS.GE.0 ) THEN + N = NS + ELSE +C +C Find the number of parameters. +C + LDAC = N + L + ISAD = LDAC*( N + M ) + N2 = N*N + LTHS = N*( ML + 1 ) + L*M + NX = NTHS + LTHS +C + IF ( LX.LT.NX ) THEN + LX = NX + INFO = -16 + CALL XERBLA( 'IB03BD', -INFO ) + RETURN + END IF +C Workspace for IB01BD. + IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + + $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, + $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + 1, + $ MNO + 3*N + L ) ) + IF ( M.GT.0 ) THEN + IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + + $ MAX( LDAC**2, 4*M*LDAC + 1 ) + ELSE + IW2 = 0 + END IF + JWORK = ISV + ISAD + MAX( IW1, IW2 ) +C Workspace for IB01CD. + IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) + IW2 = N*( N + 1 ) + 2*N + MAX( N*L*( N + 1 ) + 2*N2 + L*N, + $ 4*N ) + JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + + $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) +C Workspace for TF01MX. + JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) +C Workspace for TB01VD. + JWORK = MAX( JWORK, NSML + ISAD + N + + $ MAX( 1, N2*L + N*L + N, + $ N2 + MAX( N2 + N*MAX( N, L ) + + $ 6*N + MIN( N, L ), N*M ) ) ) +C Workspace for MD03BD (whole optimization). + IF ( M.GT.0 ) THEN + IW1 = LDAC + M + ELSE + IW1 = L + END IF + IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) + IF ( L.LE.1 .OR. BSN.EQ.0 ) THEN + IW3 = 4*NX + IW2 = IW3 + 1 + ELSE + IW2 = BSN + MAX( 3*BSN + 1, LTHS ) + IF ( NSMP.GT.BSN ) THEN + IW2 = MAX( IW2, 4*LTHS + 1 ) + IF ( NSMP.LT.2*BSN ) + $ IW2 = MAX( IW2, ( NSMP - BSN )*( L - 1 ) ) + END IF + IW3 = LTHS*BSN + 2*NX + 2*MAX( BSN, LTHS ) + END IF + JWORK = MAX( JWORK, NSML + NX + + $ MAX( 4, NSML + + $ MAX( NSML*( BSN + LTHS ) + + $ MAX( NSML + IW1, IW2 + NX ), + $ NX*( BSN + LTHS ) + NX + + $ MAX( NSML + IW1, NX + IW3 ) ) + $ ) ) + IF ( LDWORK.LT.JWORK ) THEN + INFO = -21 + DWORK(1) = JWORK + CALL XERBLA( 'IB03BD', -INFO ) + RETURN + END IF + END IF +C + BD = AC + LDAC*N + IX = BD + LDAC*M + IA = ISV + IB = IA + LDAC*N + IQ = IB + LDAC*M + IF ( LSAME( JOBCK, 'N' ) ) THEN + IRY = IQ + IS = IQ + IK = IQ + JWORK = IQ + ELSE + IRY = IQ + N2 + IS = IRY + L*L + IK = IS + N*L + JWORK = IK + N*L + END IF +C +C The workspace needed is defined for the options set above +C in the PARAMETER statements. +C Workspace: +C need: 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + +C max( LDW1,LDW2 ), where, +C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, +C L*NOBR*N + +C max( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, +C 2*(L*NOBR-L)*N+N*N+8*N, +C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) +C LDW2 >= 0, if M = 0; +C LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+ +C max( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; +C prefer: larger. +C Integer workspace: MAX(M*NOBR+N,M*(N+L)). +C + CALL IB01BD( METHB, JOB, JOBCK, NOBR, N, M, L, NSMP, DWORK(IR), + $ LDR, DWORK(IA), LDAC, DWORK(IA+N), LDAC, + $ DWORK(IB), LDAC, DWORK(IB+N), LDAC, DWORK(IQ), N, + $ DWORK(IRY), L, DWORK(IS), N, DWORK(IK), N, RCOND, + $ IWORK, DWORK(JWORK), LDWORK-JWORK+1, BWORK, + $ IWARNL, INFOL ) +C + IF( INFOL.EQ.-30 ) THEN + INFO = -21 + DWORK(1) = DWORK(JWORK) + CALL XERBLA( 'IB03BD', -INFO ) + RETURN + END IF + IF( INFOL.NE.0 ) THEN + INFO = 100*INFOL + RETURN + END IF + IF( IWARNL.NE.0 ) + $ IWARN = 100*IWARNL + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IRCNDB = 4 + IF ( LSAME( JOBCK, 'K' ) ) + $ IRCNDB = IRCNDB + 8 + CALL DCOPY( IRCNDB, DWORK(JWORK+1), 1, RCND(IRCND+1), 1 ) + IRCND = IRCND + IRCNDB +C +C Copy the system matrices to the beginning of DWORK, to save +C space, and redefine the pointers. +C + CALL DCOPY( ISAD, DWORK(IA), 1, DWORK, 1 ) + IA = 1 + IB = IA + LDAC*N + IX0 = IB + LDAC*M + IV = IX0 + N +C +C Compute the initial condition of the system. On normal exit, +C DWORK(i), i = JWORK+2:JWORK+1+N*N, +C DWORK(j), j = JWORK+2+N*N:JWORK+1+N*N+L*N, and +C DWORK(k), k = JWORK+2+N*N+L*N:JWORK+1+N*N+L*N+N*M, +C contain the transformed system matrices At, Ct, and Bt, +C respectively, corresponding to the real Schur form of the +C estimated system state matrix A. The transformation matrix is +C stored in DWORK(IV:IV+N*N-1). +C The workspace needed is defined for the options set above +C in the PARAMETER statements. +C Workspace: +C need: (N+L)*(N+M) + N + N*N + 2 + N*( N + M + L ) + +C max( 5*N, 2, min( LDW1, LDW2 ) ), where, +C LDW1 = NSMP*L*(N + 1) + 2*N + max( 2*N*N, 4*N), +C LDW2 = N*(N + 1) + 2*N + +C max( N*L*(N + 1) + 2*N*N + L*N, 4*N); +C prefer: larger. +C Integer workspace: N. +C + JWORK = IV + N2 + CALL IB01CD( 'X needed', COMUSE, JOBXD, N, M, L, NSMP, + $ DWORK(IA), LDAC, DWORK(IB), LDAC, DWORK(IA+N), + $ LDAC, DWORK(IB+N), LDAC, U, LDU, Y, LDY, + $ DWORK(IX0), DWORK(IV), N, RCOND, IWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFOL ) +C + IF( INFOL.EQ.-26 ) THEN + INFO = -21 + DWORK(1) = DWORK(JWORK) + CALL XERBLA( 'IB03BD', -INFO ) + RETURN + END IF + IF( INFOL.EQ.1 ) + $ INFOL = 10 + IF( INFOL.NE.0 ) THEN + INFO = 100*INFOL + RETURN + END IF + IF( IWARNL.NE.0 ) + $ IWARN = 100*IWARNL + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IRCND = IRCND + 1 + RCND(IRCND) = DWORK(JWORK+1) +C +C Now, save the system matrices and x0 in the final location. +C + IF ( IV.LT.AC ) THEN + CALL DCOPY( ISAD+N, DWORK(IA), 1, DWORK(AC), 1 ) + ELSE + DO 10 J = AC + ISAD + N - 1, AC, -1 + DWORK(J) = DWORK(IA+J-AC) + 10 CONTINUE + END IF +C +C Compute the output of the linear part. +C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, +C if M > 0; +C NSMP*L + (N + L)*N + 2*N + L, if M = 0; +C prefer larger. +C + JWORK = IX + N + CALL DCOPY( N, DWORK(IX), 1, X(NTHS+1), 1 ) + CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, X(NTHS+1), + $ DWORK(Z), NSMP, DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) +C +C Convert the state-space representation to output normal form. +C Workspace: +C need: NSMP*L + (N + L)*(N + M) + N + +C MAX(1, N*N*L + N*L + N, N*N + +C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), N*M)); +C prefer: larger. +C + CALL TB01VD( 'Apply', N, M, L, DWORK(AC), LDAC, DWORK(BD), + $ LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), LDAC, + $ DWORK(IX), X(NTHS+1), LTHS, DWORK(JWORK), + $ LDWORK-JWORK+1, INFOL ) +C + IF( INFOL.GT.0 ) THEN + INFO = INFOL + 4 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + END IF +C + LIPAR = 7 + IW1 = 0 + IW2 = 0 + IDIAG = AC +C + IF ( INIT2 ) THEN +C +C Initialize the nonlinear part. +C + IF ( .NOT.INIT1 ) THEN + BD = AC + LDAC*N + IX = BD + LDAC*M +C +C Convert the output normal form to state-space model. +C Workspace: need NSMP*L + (N + L)*(2*N + M) + 2*N. +C (NSMP*L locations are reserved for the output of the linear +C part.) +C + JWORK = IX + N + CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), + $ LDAC, DWORK(BD), LDAC, DWORK(AC+N), LDAC, + $ DWORK(BD+N), LDAC, DWORK(IX), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) +C +C Compute the output of the linear part. +C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, +C if M > 0; +C NSMP*L + (N + L)*N + 2*N + L, if M = 0; +C prefer larger. +C + CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, + $ DWORK(IX), DWORK(Z), NSMP, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + END IF +C +C Optimize the parameters of the nonlinear part. +C Workspace: +C need NSMP*L + BSN + +C MAX( 4, NSMP + +C MAX( NSMP*BSN + MAX( 2*NN, 5*BSN + 1 ), +C BSN**2 + BSN + MAX( NSMP + 2*NN, 5*BSN ) )); +C prefer larger. +C Integer workspace: NN*(L + 2) + 2. +C + WORK(1) = ZERO + CALL DCOPY( 3, WORK(1), 0, WORK(2), 1 ) +C +C Set the integer parameters needed, including the number of +C neurons. +C + IPAR(1) = NSMP + IPAR(2) = L + IPAR(3) = NN + JWORK = IDIAG + BSN +C + DO 30 I = 0, L - 1 + CALL DCOPY( 4, SEED, 1, DWORK(JWORK), 1 ) + CALL MD03BD( 'Random initialization', SCALE, COND, NF01BE, + $ MD03BA, MD03BB, NSMP, BSN, ITMAX1, FACTOR, + $ NPRINT, IPAR, LIPAR, DWORK(Z), NSMP, Y(1,I+1), + $ LDY, X(I*BSN+1), DWORK(IDIAG), NFEV, NJEV, + $ TOL1, TOL1, GTOL, TOL, IWORK, DWORK(JWORK), + $ LDWORK-JWORK+1, IWARNL, INFOL ) + IF( INFOL.NE.0 ) THEN + INFO = 10*INFOL + RETURN + END IF + IF ( IWARNL.LT.0 ) THEN + INFO = INFOL + IWARN = IWARNL + GO TO 50 + ELSEIF ( IWARNL.GT.0 ) THEN + IF ( IWARN.GT.100 ) THEN + IWARN = MAX( IWARN, ( IWARN/100 )*100 + 10*IWARNL ) + ELSE + IWARN = MAX( IWARN, 10*IWARNL ) + END IF + END IF + WORK(1) = MAX( WORK(1), DWORK(JWORK) ) + WORK(2) = MAX( WORK(2), DWORK(JWORK+1) ) + WORK(4) = MAX( WORK(4), DWORK(JWORK+3) ) + WORK(3) = WORK(3) + DWORK(JWORK+2) + IW1 = NFEV + IW1 + IW2 = NJEV + IW2 + 30 CONTINUE +C + END IF +C +C Main iteration. +C Workspace: +C need NSMP*L + NX + +C MAX( 4, NSMP*L + +C MAX( NSMP*L*( BSN + LTHS ) + +C MAX( NSMP*L + LDW1, LDW2 + NX ), +C NX*( BSN + LTHS ) + NX + +C MAX( NSMP*L + LDW1, NX + LDW3 ) ) ), +C LDW0 = MAX( N*(N+L), N+M+L ), if M > 0; +C LDW0 = MAX( N*(N+L), L ), if M = 0; +C LDW1 = NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + LDW0); +C LDW2 = 4*NX + 1, if L <= 1 or BSN = 0; otherwise, +C LDW2 = BSN + MAX(3*BSN+1,LTHS); +C LDW2 = MAX(LDW2, 4*LTHS+1), if NSMP > BSN; +C LDW2 = MAX(LDW2, (NSMP-BSN)*(L-1)), if BSN < NSMP < 2*BSN; +C LDW3 = 4*NX, if L <= 1 or BSN = 0; +C LDW3 = LTHS*BSN + 2*NX + 2*MAX(BSN,LTHS), +C if L > 1 and BSN > 0; +C prefer larger. +C Integer workspace: NX+L. +C +C Set the integer parameters describing the Jacobian structure +C and the number of neurons. +C + IPAR(1) = LTHS + IPAR(2) = L + IPAR(3) = NSMP + IPAR(4) = BSN + IPAR(5) = M + IPAR(6) = N + IPAR(7) = NN + JWORK = IDIAG + NX +C + CALL MD03BD( 'Given initialization', SCALE, COND, NF01BF, + $ NF01BS, NF01BP, NSML, NX, ITMAX2, FACTOR, NPRINT, + $ IPAR, LIPAR, U, LDU, Y, LDY, X, DWORK(IDIAG), NFEV, + $ NJEV, TOL2, TOL2, GTOL, TOL, IWORK, DWORK(JWORK), + $ LDWORK-JWORK+1, IWARNL, INFO ) + IF( INFO.NE.0 ) + $ RETURN +C + DO 40 I = 1, NX + L + IWORK(I+3) = IWORK(I) + 40 CONTINUE +C + 50 CONTINUE + IWORK(1) = IW1 + NFEV + IWORK(2) = IW2 + NJEV + IF ( IWARNL.LT.0 ) THEN + IWARN = IWARNL + ELSE + IWARN = IWARN + IWARNL + END IF + CALL DCOPY( 4, DWORK(JWORK), 1, DWORK, 1 ) + IF ( INIT2 ) + $ CALL DCOPY( 4, WORK, 1, DWORK(5), 1 ) + IF ( INIT1 ) THEN + IWORK(3) = IRCND + CALL DCOPY( IRCND, RCND, 1, DWORK(9), 1 ) + ELSE + IWORK(3) = 0 + END IF +C + RETURN +C +C *** Last line of IB03BD *** + END diff --git a/mex/sources/libslicot/MA01AD.f b/mex/sources/libslicot/MA01AD.f new file mode 100644 index 000000000..eab214d03 --- /dev/null +++ b/mex/sources/libslicot/MA01AD.f @@ -0,0 +1,95 @@ + SUBROUTINE MA01AD( XR, XI, YR, YI ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the complex square root YR + i*YI of a complex number +C XR + i*XI in real arithmetic. The returned result is so that +C YR >= 0.0 and SIGN(YI) = SIGN(XI). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C XR (input) DOUBLE PRECISION +C XI (input) DOUBLE PRECISION +C These scalars define the real and imaginary part of the +C complex number of which the square root is sought. +C +C YR (output) DOUBLE PRECISION +C YI (output) DOUBLE PRECISION +C These scalars define the real and imaginary part of the +C complex square root. +C +C METHOD +C +C The complex square root YR + i*YI of the complex number XR + i*XI +C is computed in real arithmetic, taking care to avoid overflow. +C +C REFERENCES +C +C Adapted from EISPACK subroutine CSROOT. +C +C CONTRIBUTOR +C +C P. Benner, Universitaet Bremen, Germany, and +C R. Byers, University of Kansas, Lawrence, USA, +C Aug. 1998, routine DCROOT. +C V. Sima, Research Institute for Informatics, Bucharest, Romania, +C Oct. 1998, SLICOT Library version. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF + PARAMETER ( ZERO = 0.0D0, HALF = 1.0D0/2.0D0 ) +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION XR, XI, YR, YI +C .. +C .. Local Scalars .. + DOUBLE PRECISION S +C .. +C .. External Functions .. + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2 +C +C .. Intrinsic functions .. + INTRINSIC ABS, SQRT +C .. +C .. Executable Statements .. +C + S = SQRT( HALF*( DLAPY2( XR, XI ) + ABS( XR ) ) ) + IF ( XR.GE.ZERO ) YR = S + IF ( XI.LT.ZERO ) S = -S + IF ( XR.LE.ZERO ) THEN + YI = S + IF ( XR.LT.ZERO ) YR = HALF*( XI/S ) + ELSE + YI = HALF*( XI/YR ) + END IF +C + RETURN +C *** Last line of MA01AD *** + END diff --git a/mex/sources/libslicot/MA02AD.f b/mex/sources/libslicot/MA02AD.f new file mode 100644 index 000000000..a3cec4e40 --- /dev/null +++ b/mex/sources/libslicot/MA02AD.f @@ -0,0 +1,108 @@ + SUBROUTINE MA02AD( JOB, M, N, A, LDA, B, LDB ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To transpose all or part of a two-dimensional matrix A into +C another matrix B. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the part of the matrix A to be transposed into B +C as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part; +C Otherwise: All of the matrix A. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The m-by-n matrix A. If JOB = 'U', only the upper +C triangle or trapezoid is accessed; if JOB = 'L', only the +C lower triangle or trapezoid is accessed. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C B = A' in the locations specified by JOB. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine DMTRA. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER LDA, LDB, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*) +C .. Local Scalars .. + INTEGER I, J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. Intrinsic Functions .. + INTRINSIC MIN +C +C .. Executable Statements .. +C + IF( LSAME( JOB, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, MIN( J, M ) + B(J,I) = A(I,J) + 10 CONTINUE + 20 CONTINUE + ELSE IF( LSAME( JOB, 'L' ) ) THEN + DO 40 J = 1, N + DO 30 I = J, M + B(J,I) = A(I,J) + 30 CONTINUE + 40 CONTINUE + ELSE + DO 60 J = 1, N + DO 50 I = 1, M + B(J,I) = A(I,J) + 50 CONTINUE + 60 CONTINUE + END IF +C + RETURN +C *** Last line of MA02AD *** + END diff --git a/mex/sources/libslicot/MA02BD.f b/mex/sources/libslicot/MA02BD.f new file mode 100644 index 000000000..38e713734 --- /dev/null +++ b/mex/sources/libslicot/MA02BD.f @@ -0,0 +1,113 @@ + SUBROUTINE MA02BD( SIDE, M, N, A, LDA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reverse the order of rows and/or columns of a given matrix A +C by pre-multiplying and/or post-multiplying it, respectively, with +C a permutation matrix P, where P is a square matrix of appropriate +C order, with ones down the secondary diagonal. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies the operation to be performed, as follows: +C = 'L': the order of rows of A is to be reversed by +C pre-multiplying A with P; +C = 'R': the order of columns of A is to be reversed by +C post-multiplying A with P; +C = 'B': both the order of rows and the order of columns +C of A is to be reversed by pre-multiplying and +C post-multiplying A with P. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading M-by-N part of this array must +C contain the given matrix whose rows and/or columns are to +C be permuted. +C On exit, the leading M-by-N part of this array contains +C the matrix P*A if SIDE = 'L', or A*P if SIDE = 'R', or +C P*A*P if SIDE = 'B'. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine PAP. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER SIDE + INTEGER LDA, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*) +C .. Local Scalars .. + LOGICAL BSIDES + INTEGER I, J, K, M2, N2 +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DSWAP +C .. Executable Statements .. +C + BSIDES = LSAME( SIDE, 'B' ) +C + IF( ( LSAME( SIDE, 'L' ) .OR. BSIDES ) .AND. M.GT.1 ) THEN +C +C Compute P*A. +C + M2 = M/2 + K = M - M2 + 1 + DO 10 J = 1, N + CALL DSWAP( M2, A(1,J), -1, A(K,J), 1 ) + 10 CONTINUE + END IF + IF( ( LSAME( SIDE, 'R' ) .OR. BSIDES ) .AND. N.GT.1 ) THEN +C +C Compute A*P. +C + N2 = N/2 + K = N - N2 + 1 + DO 20 I = 1, M + CALL DSWAP( N2, A(I,1), -LDA, A(I,K), LDA ) + 20 CONTINUE + END IF +C + RETURN +C *** Last line of MA02BD *** + END diff --git a/mex/sources/libslicot/MA02BZ.f b/mex/sources/libslicot/MA02BZ.f new file mode 100644 index 000000000..b2a699bf1 --- /dev/null +++ b/mex/sources/libslicot/MA02BZ.f @@ -0,0 +1,114 @@ + SUBROUTINE MA02BZ( SIDE, M, N, A, LDA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reverse the order of rows and/or columns of a given matrix A +C by pre-multiplying and/or post-multiplying it, respectively, with +C a permutation matrix P, where P is a square matrix of appropriate +C order, with ones down the secondary diagonal. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies the operation to be performed, as follows: +C = 'L': the order of rows of A is to be reversed by +C pre-multiplying A with P; +C = 'R': the order of columns of A is to be reversed by +C post-multiplying A with P; +C = 'B': both the order of rows and the order of columns +C of A is to be reversed by pre-multiplying and +C post-multiplying A with P. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) COMPLEX*16 array, dimension (LDA,N) +C On entry, the leading M-by-N part of this array must +C contain the given matrix whose rows and/or columns are to +C be permuted. +C On exit, the leading M-by-N part of this array contains +C the matrix P*A if SIDE = 'L', or A*P if SIDE = 'R', or +C P*A*P if SIDE = 'B'. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER SIDE + INTEGER LDA, M, N +C .. Array Arguments .. + COMPLEX*16 A(LDA,*) +C .. Local Scalars .. + LOGICAL BSIDES + INTEGER I, J, K, M2, N2 +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL ZSWAP +C .. Executable Statements .. +C + BSIDES = LSAME( SIDE, 'B' ) +C + IF( ( LSAME( SIDE, 'L' ) .OR. BSIDES ) .AND. M.GT.1 ) THEN +C +C Compute P*A. +C + M2 = M/2 + K = M - M2 + 1 + DO 10 J = 1, N + CALL ZSWAP( M2, A(1,J), -1, A(K,J), 1 ) + 10 CONTINUE + END IF + IF( ( LSAME( SIDE, 'R' ) .OR. BSIDES ) .AND. N.GT.1 ) THEN +C +C Compute A*P. +C + N2 = N/2 + K = N - N2 + 1 + DO 20 I = 1, M + CALL ZSWAP( N2, A(I,1), -LDA, A(I,K), LDA ) + 20 CONTINUE + END IF +C + RETURN +C *** Last line of MA02BZ *** + END diff --git a/mex/sources/libslicot/MA02CD.f b/mex/sources/libslicot/MA02CD.f new file mode 100644 index 000000000..e4948b891 --- /dev/null +++ b/mex/sources/libslicot/MA02CD.f @@ -0,0 +1,113 @@ + SUBROUTINE MA02CD( N, KL, KU, A, LDA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the pertranspose of a central band of a square matrix. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the square matrix A. N >= 0. +C +C KL (input) INTEGER +C The number of subdiagonals of A to be pertransposed. +C 0 <= KL <= N-1. +C +C KU (input) INTEGER +C The number of superdiagonals of A to be pertransposed. +C 0 <= KU <= N-1. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain a square matrix whose central band formed from +C the KL subdiagonals, the main diagonal and the KU +C superdiagonals will be pertransposed. +C On exit, the leading N-by-N part of this array contains +C the matrix A with its central band (the KL subdiagonals, +C the main diagonal and the KU superdiagonals) pertransposed +C (that is the elements of each antidiagonal appear in +C reversed order). This is equivalent to forming P*B'*P, +C where B is the matrix formed from the central band of A +C and P is a permutation matrix with ones down the secondary +C diagonal. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine DMPTR. +C +C REVISIONS +C +C A. Varga, December 2001. +C V. Sima, March 2004. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER KL, KU, LDA, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*) +C .. Local Scalars .. + INTEGER I, I1, LDA1 +C .. External Subroutines .. + EXTERNAL DSWAP +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C +C Quick return if possible. +C + IF( N.LE.1 ) + $ RETURN +C + LDA1 = LDA + 1 +C +C Pertranspose the KL subdiagonals. +C + DO 10 I = 1, MIN( KL, N-2 ) + I1 = (N-I) / 2 + IF( I1.GT.0 ) + $ CALL DSWAP( I1, A(I+1,1), LDA1, A(N-I1+1,N-I1+1-I), -LDA1 ) + 10 CONTINUE +C +C Pertranspose the KU superdiagonals. +C + DO 20 I = 1, MIN( KU, N-2 ) + I1 = (N-I) / 2 + IF( I1.GT.0 ) + $ CALL DSWAP( I1, A(1,I+1), LDA1, A(N-I1+1-I,N-I1+1), -LDA1 ) + 20 CONTINUE +C +C Pertranspose the diagonal. +C + I1 = N / 2 + IF( I1.GT.0 ) + $ CALL DSWAP( I1, A(1,1), LDA1, A(N-I1+1,N-I1+1), -LDA1 ) +C + RETURN +C *** Last line of MA02CD *** + END diff --git a/mex/sources/libslicot/MA02CZ.f b/mex/sources/libslicot/MA02CZ.f new file mode 100644 index 000000000..5bb85b5ed --- /dev/null +++ b/mex/sources/libslicot/MA02CZ.f @@ -0,0 +1,113 @@ + SUBROUTINE MA02CZ( N, KL, KU, A, LDA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the pertranspose of a central band of a square matrix. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the square matrix A. N >= 0. +C +C KL (input) INTEGER +C The number of subdiagonals of A to be pertransposed. +C 0 <= KL <= N-1. +C +C KU (input) INTEGER +C The number of superdiagonals of A to be pertransposed. +C 0 <= KU <= N-1. +C +C A (input/output) COMPLEX*16 array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain a square matrix whose central band formed from +C the KL subdiagonals, the main diagonal and the KU +C superdiagonals will be pertransposed. +C On exit, the leading N-by-N part of this array contains +C the matrix A with its central band (the KL subdiagonals, +C the main diagonal and the KU superdiagonals) pertransposed +C (that is the elements of each antidiagonal appear in +C reversed order). This is equivalent to forming P*B'*P, +C where B is the matrix formed from the central band of A +C and P is a permutation matrix with ones down the secondary +C diagonal. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER KL, KU, LDA, N +C .. Array Arguments .. + COMPLEX*16 A(LDA,*) +C .. Local Scalars .. + INTEGER I, I1, LDA1 +C .. External Subroutines .. + EXTERNAL ZSWAP +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C +C Quick return if possible. +C + IF( N.LE.1 ) + $ RETURN +C + LDA1 = LDA + 1 +C +C Pertranspose the KL subdiagonals. +C + DO 10 I = 1, MIN( KL, N-2 ) + I1 = (N-I) / 2 + IF( I1.GT.0 ) + $ CALL ZSWAP( I1, A(I+1,1), LDA1, A(N-I1+1,N-I1+1-I), -LDA1 ) + 10 CONTINUE +C +C Pertranspose the KU superdiagonals. +C + DO 20 I = 1, MIN( KU, N-2 ) + I1 = (N-I) / 2 + IF( I1.GT.0 ) + $ CALL ZSWAP( I1, A(1,I+1), LDA1, A(N-I1+1-I,N-I1+1), -LDA1 ) + 20 CONTINUE +C +C Pertranspose the diagonal. +C + I1 = N / 2 + IF( I1.GT.0 ) + $ CALL ZSWAP( I1, A(1,1), LDA1, A(N-I1+1,N-I1+1), -LDA1 ) +C + RETURN +C *** Last line of MA02CZ *** + END diff --git a/mex/sources/libslicot/MA02DD.f b/mex/sources/libslicot/MA02DD.f new file mode 100644 index 000000000..ef7967e73 --- /dev/null +++ b/mex/sources/libslicot/MA02DD.f @@ -0,0 +1,157 @@ + SUBROUTINE MA02DD( JOB, UPLO, N, A, LDA, AP ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To pack/unpack the upper or lower triangle of a symmetric matrix. +C The packed matrix is stored column-wise in the one-dimensional +C array AP. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies whether the matrix should be packed or unpacked, +C as follows: +C = 'P': The matrix should be packed; +C = 'U': The matrix should be unpacked. +C +C UPLO CHARACTER*1 +C Specifies the part of the matrix to be packed/unpacked, +C as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input or output) DOUBLE PRECISION array, dimension +C (LDA,N) +C This array is an input parameter if JOB = 'P', and an +C output parameter if JOB = 'U'. +C On entry, if JOB = 'P', the leading N-by-N upper +C triangular part (if UPLO = 'U'), or lower triangular part +C (if UPLO = 'L'), of this array must contain the +C corresponding upper or lower triangle of the symmetric +C matrix A, and the other strictly triangular part is not +C referenced. +C On exit, if JOB = 'U', the leading N-by-N upper triangular +C part (if UPLO = 'U'), or lower triangular part (if +C UPLO = 'L'), of this array contains the corresponding +C upper or lower triangle of the symmetric matrix A; the +C other strictly triangular part is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C AP (output or input) DOUBLE PRECISION array, dimension +C (N*(N+1)/2) +C This array is an output parameter if JOB = 'P', and an +C input parameter if JOB = 'U'. +C On entry, if JOB = 'U', the leading N*(N+1)/2 elements of +C this array must contain the upper (if UPLO = 'U') or lower +C (if UPLO = 'L') triangle of the symmetric matrix A, packed +C column-wise. That is, the elements are stored in the order +C 11, 12, 22, ..., 1n, 2n, 3n, ..., nn, if UPLO = 'U'; +C 11, 21, 31, ..., n1, 22, 32, ..., n2, ..., if UPLO = 'L'. +C On exit, if JOB = 'P', the leading N*(N+1)/2 elements of +C this array contain the upper (if UPLO = 'U') or lower +C (if UPLO = 'L') triangle of the symmetric matrix A, packed +C column-wise, as described above. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Romania, +C Oct. 1998. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER JOB, UPLO + INTEGER LDA, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), AP(*) +C .. Local Scalars .. + LOGICAL LUPLO + INTEGER IJ, J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY +C +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked for errors. +C + LUPLO = LSAME( UPLO, 'L' ) + IJ = 1 + IF( LSAME( JOB, 'P' ) ) THEN + IF( LUPLO ) THEN +C +C Pack the lower triangle of A. +C + DO 20 J = 1, N + CALL DCOPY( N-J+1, A(J,J), 1, AP(IJ), 1 ) + IJ = IJ + N - J + 1 + 20 CONTINUE +C + ELSE +C +C Pack the upper triangle of A. +C + DO 40 J = 1, N + CALL DCOPY( J, A(1,J), 1, AP(IJ), 1 ) + IJ = IJ + J + 40 CONTINUE +C + END IF + ELSE + IF( LUPLO ) THEN +C +C Unpack the lower triangle of A. +C + DO 60 J = 1, N + CALL DCOPY( N-J+1, AP(IJ), 1, A(J,J), 1 ) + IJ = IJ + N - J + 1 + 60 CONTINUE +C + ELSE +C +C Unpack the upper triangle of A. +C + DO 80 J = 1, N + CALL DCOPY( J, AP(IJ), 1, A(1,J), 1 ) + IJ = IJ + J + 80 CONTINUE +C + END IF + END IF +C + RETURN +C *** Last line of MA02DD *** + END diff --git a/mex/sources/libslicot/MA02ED.f b/mex/sources/libslicot/MA02ED.f new file mode 100644 index 000000000..79ce82f7c --- /dev/null +++ b/mex/sources/libslicot/MA02ED.f @@ -0,0 +1,99 @@ + SUBROUTINE MA02ED( UPLO, N, A, LDA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To store by symmetry the upper or lower triangle of a symmetric +C matrix, given the other triangle. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies which part of the matrix is given as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part. +C For all other values, the array A is not referenced. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N upper triangular part +C (if UPLO = 'U'), or lower triangular part (if UPLO = 'L'), +C of this array must contain the corresponding upper or +C lower triangle of the symmetric matrix A. +C On exit, the leading N-by-N part of this array contains +C the symmetric matrix A with all elements stored. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Romania, +C Oct. 1998. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*) +C .. Local Scalars .. + INTEGER J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY +C +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked for errors. +C + IF( LSAME( UPLO, 'L' ) ) THEN +C +C Construct the upper triangle of A. +C + DO 20 J = 2, N + CALL DCOPY( J-1, A(J,1), LDA, A(1,J), 1 ) + 20 CONTINUE +C + ELSE IF( LSAME( UPLO, 'U' ) ) THEN +C +C Construct the lower triangle of A. +C + DO 40 J = 2, N + CALL DCOPY( J-1, A(1,J), 1, A(J,1), LDA ) + 40 CONTINUE +C + END IF + RETURN +C *** Last line of MA02ED *** + END diff --git a/mex/sources/libslicot/MA02FD.f b/mex/sources/libslicot/MA02FD.f new file mode 100644 index 000000000..f2ec4350b --- /dev/null +++ b/mex/sources/libslicot/MA02FD.f @@ -0,0 +1,104 @@ + SUBROUTINE MA02FD( X1, X2, C, S, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients c and s (c^2 + s^2 = 1) for a modified +C hyperbolic plane rotation, such that, +C +C y1 := 1/c * x1 - s/c * x2 = sqrt(x1^2 - x2^2), +C y2 := -s * y1 + c * x2 = 0, +C +C given two real numbers x1 and x2, satisfying either x1 = x2 = 0, +C or abs(x2) < abs(x1). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C X1 (input/output) DOUBLE PRECISION +C On entry, the real number x1. +C On exit, the real number y1. +C +C X2 (input) DOUBLE PRECISION +C The real number x2. +C The values x1 and x2 should satisfy either x1 = x2 = 0, or +C abs(x2) < abs(x1). +C +C C (output) DOUBLE PRECISION +C The cosines c of the modified hyperbolic plane rotation. +C +C S (output) DOUBLE PRECISION +C The sines s of the modified hyperbolic plane rotation. +C +C Error Indicator +C +C INFO INTEGER +C = 0: succesful exit; +C = 1: if abs(x2) >= abs(x1) and either x1 <> 0 or x2 <> 0. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000. +C +C KEYWORDS +C +C Orthogonal transformation, plane rotation. +C +C ***************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION X1, X2, C, S + INTEGER INFO +C .. Intrinsic Functions .. + INTRINSIC ABS, SIGN, SQRT +C .. Executable Statements .. +C + IF ( ( X1.NE.ZERO .OR. X2.NE.ZERO ) .AND. + $ ABS( X2 ).GE.ABS( X1 ) ) THEN + INFO = 1 + ELSE + INFO = 0 + IF ( X1.EQ.ZERO ) THEN + S = ZERO + C = ONE + ELSE + S = X2 / X1 +C +C No overflows could appear in the next statement; underflows +C are possible if X2 is tiny and X1 is huge, but then +C abs(C) = ONE - delta, +C where delta is much less than machine precision. +C + C = SIGN( SQRT( ONE - S ) * SQRT( ONE + S ), X1 ) + X1 = C * X1 + END IF + END IF +C + RETURN +C *** Last line of MA02FD *** + END diff --git a/mex/sources/libslicot/MA02GD.f b/mex/sources/libslicot/MA02GD.f new file mode 100644 index 000000000..90cda2ed4 --- /dev/null +++ b/mex/sources/libslicot/MA02GD.f @@ -0,0 +1,158 @@ + SUBROUTINE MA02GD( N, A, LDA, K1, K2, IPIV, INCX ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform a series of column interchanges on the matrix A. +C One column interchange is initiated for each of columns K1 through +C K2 of A. This is useful for solving linear systems X*A = B, when +C the matrix A has already been factored by LAPACK Library routine +C DGETRF. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of rows of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,*) +C On entry, the leading N-by-M part of this array must +C contain the matrix A to which the column interchanges will +C be applied, where M is the largest element of IPIV(K), for +C K = K1, ..., K2. +C On exit, the leading N-by-M part of this array contains +C the permuted matrix. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C K1 (input) INTEGER +C The first element of IPIV for which a column interchange +C will be done. +C +C K2 (input) INTEGER +C The last element of IPIV for which a column interchange +C will be done. +C +C IPIV (input) INTEGER array, dimension (K1+(K2-K1)*abs(INCX)) +C The vector of interchanging (pivot) indices. Only the +C elements in positions K1 through K2 of IPIV are accessed. +C IPIV(K) = L implies columns K and L are to be +C interchanged. +C +C INCX (input) INTEGER +C The increment between successive values of IPIV. +C If INCX is negative, the interchanges are applied in +C reverse order. +C +C METHOD +C +C The columns IPIV(K) and K are swapped for K = K1, ..., K2, for +C INCX = 1 (and similarly, for INCX <> 1). +C +C FURTHER COMMENTS +C +C This routine is the column-oriented counterpart of the LAPACK +C Library routine DLASWP. The LAPACK Library routine DLAPMT cannot +C be used in this context. To solve the system X*A = B, where A and +C B are N-by-N and M-by-N, respectively, the following statements +C can be used: +C +C CALL DGETRF( N, N, A, LDA, IPIV, INFO ) +C CALL DTRSM( 'R', 'U', 'N', 'N', M, N, ONE, A, LDA, B, LDB ) +C CALL DTRSM( 'R', 'L', 'N', 'U', M, N, ONE, A, LDA, B, LDB ) +C CALL MA02GD( M, B, LDB, 1, N, IPIV, -1 ) +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2008. +C +C KEYWORDS +C +C Elementary matrix operations, linear algebra. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INCX, K1, K2, LDA, N +C .. +C .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +C .. +C .. Local Scalars .. + INTEGER J, JP, JX +C .. +C .. External Subroutines .. + EXTERNAL DSWAP +C .. +C .. Executable Statements .. +C +C Quick return if possible. +C + IF( INCX.EQ.0 .OR. N.EQ.0 ) + $ RETURN +C +C Interchange column J with column IPIV(J) for each of columns K1 +C through K2. +C + IF( INCX.GT.0 ) THEN + JX = K1 + ELSE + JX = 1 + ( 1-K2 )*INCX + END IF +C + IF( INCX.EQ.1 ) THEN +C + DO 10 J = K1, K2 + JP = IPIV( J ) + IF( JP.NE.J ) + $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) + 10 CONTINUE +C + ELSE IF( INCX.GT.1 ) THEN +C + DO 20 J = K1, K2 + JP = IPIV( JX ) + IF( JP.NE.J ) + $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) + JX = JX + INCX + 20 CONTINUE +C + ELSE IF( INCX.LT.0 ) THEN +C + DO 30 J = K2, K1, -1 + JP = IPIV( JX ) + IF( JP.NE.J ) + $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) + JX = JX + INCX + 30 CONTINUE +C + END IF +C + RETURN +C +C *** Last line of MA02GD *** + END diff --git a/mex/sources/libslicot/MA02HD.f b/mex/sources/libslicot/MA02HD.f new file mode 100644 index 000000000..2017da866 --- /dev/null +++ b/mex/sources/libslicot/MA02HD.f @@ -0,0 +1,180 @@ + LOGICAL FUNCTION MA02HD( JOB, M, N, DIAG, A, LDA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To check if A = DIAG*I, where I is an M-by-N matrix with ones on +C the diagonal and zeros elsewhere. +C +C FUNCTION VALUE +C +C MA02HD LOGICAL +C The function value is set to .TRUE. if A = DIAG*I, and to +C .FALSE., otherwise. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the part of the matrix A to be checked out, +C as follows: +C = 'U': Upper triangular/trapezoidal part; +C = 'L': Lower triangular/trapezoidal part. +C Otherwise: All of the matrix A. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C DIAG (input) DOUBLE PRECISION +C The scalar DIAG. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading M-by-N part of this array must contain the +C matrix A. If JOB = 'U', only the upper triangle or +C trapezoid is accessed; if JOB = 'L', only the lower +C triangle or trapezoid is accessed. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C METHOD +C +C The routine returns immediately after detecting a diagonal element +C which differs from DIAG, or a nonzero off-diagonal element in the +C searched part of A. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2001. +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2003. +C +C KEYWORDS +C +C Elementary operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER LDA, M, N + DOUBLE PRECISION DIAG +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*) +C .. Local Scalars .. + INTEGER I, J +C .. External Functions + LOGICAL LSAME + EXTERNAL LSAME +C .. Intrinsic Functions .. + INTRINSIC MIN +C +C .. Executable Statements .. +C +C Do not check parameters, for efficiency. +C + IF( LSAME( JOB, 'U' ) ) THEN +C + DO 20 J = 1, N +C + DO 10 I = 1, MIN( J-1, M ) + IF( A(I,J).NE.ZERO ) THEN + MA02HD = .FALSE. + RETURN + END IF + 10 CONTINUE +C + IF( J.LE.M ) THEN + IF( A(J,J).NE.DIAG ) THEN + MA02HD = .FALSE. + RETURN + END IF + END IF + 20 CONTINUE +C + ELSE IF( LSAME( JOB, 'L' ) ) THEN +C + DO 40 J = 1, MIN( M, N ) + IF( A(J,J).NE.DIAG ) THEN + MA02HD = .FALSE. + RETURN + END IF +C + IF ( J.NE.M ) THEN +C + DO 30 I = MIN( J+1, M ), M + IF( A(I,J).NE.ZERO ) THEN + MA02HD = .FALSE. + RETURN + END IF + 30 CONTINUE +C + END IF + 40 CONTINUE +C + ELSE +C + DO 70 J = 1, N +C + DO 50 I = 1, MIN( J-1, M ) + IF( A(I,J).NE.ZERO ) THEN + MA02HD = .FALSE. + RETURN + END IF + 50 CONTINUE +C + IF( J.LE.M ) THEN + IF( A(J,J).NE.DIAG ) THEN + MA02HD = .FALSE. + RETURN + END IF + END IF +C + IF ( J.LT.M ) THEN +C + DO 60 I = MIN( J+1, M ), M + IF( A(I,J).NE.ZERO ) THEN + MA02HD = .FALSE. + RETURN + END IF + 60 CONTINUE +C + END IF + 70 CONTINUE +C + END IF +C + MA02HD = .TRUE. +C + RETURN +C *** Last line of MA02HD *** + END diff --git a/mex/sources/libslicot/MA02ID.f b/mex/sources/libslicot/MA02ID.f new file mode 100644 index 000000000..8b822bb55 --- /dev/null +++ b/mex/sources/libslicot/MA02ID.f @@ -0,0 +1,293 @@ + DOUBLE PRECISION FUNCTION MA02ID( TYP, NORM, N, A, LDA, QG, + $ LDQG, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the value of the one norm, or the Frobenius norm, or +C the infinity norm, or the element of largest absolute value +C of a real skew-Hamiltonian matrix +C +C [ A G ] T T +C X = [ T ], G = -G, Q = -Q, +C [ Q A ] +C +C or of a real Hamiltonian matrix +C +C [ A G ] T T +C X = [ T ], G = G, Q = Q, +C [ Q -A ] +C +C where A, G and Q are real n-by-n matrices. +C +C Note that for this kind of matrices the infinity norm is equal +C to the one norm. +C +C FUNCTION VALUE +C +C MA02ID DOUBLE PRECISION +C The computed norm. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYP CHARACTER*1 +C Specifies the type of the input matrix X: +C = 'S': X is skew-Hamiltonian; +C = 'H': X is Hamiltonian. +C +C NORM CHARACTER*1 +C Specifies the value to be returned in MA02ID: +C = '1' or 'O': one norm of X; +C = 'F' or 'E': Frobenius norm of X; +C = 'I': infinity norm of X; +C = 'M': max(abs(X(i,j)). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C QG (input) DOUBLE PRECISION array, dimension (LDQG,N+1) +C On entry, the leading N-by-N+1 part of this array must +C contain in columns 1:N the lower triangular part of the +C matrix Q and in columns 2:N+1 the upper triangular part +C of the matrix G. If TYP = 'S', the parts containing the +C diagonal and the first supdiagonal of this array are not +C referenced. +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= MAX(1,N). +C +C Workspace +C +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C where LDWORK >= 2*N when NORM = '1', NORM = 'I' or +C NORM = 'O'; otherwise, DWORK is not referenced. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLANHA). +C +C KEYWORDS +C +C Elementary matrix operations, Hamiltonian matrix, skew-Hamiltonian +C matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TWO, ZERO + PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER NORM, TYP + INTEGER LDA, LDQG, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*) +C .. Local Scalars .. + LOGICAL LSH + INTEGER I, J + DOUBLE PRECISION DSCL, DSUM, SCALE, SUM, TEMP, VALUE +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLANGE, DLAPY2 + EXTERNAL DLANGE, DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL DLASSQ +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +C +C .. Executable Statements .. +C + LSH = LSAME( TYP, 'S' ) +C + IF ( N.EQ.0 ) THEN + VALUE = ZERO +C + ELSE IF ( LSAME( NORM, 'M' ) .AND. LSH ) THEN +C +C Find max(abs(A(i,j))). +C + VALUE = DLANGE( 'MaxElement', N, N, A, LDA, DWORK ) + IF ( N.GT.1 ) THEN + DO 30 J = 1, N+1 + DO 10 I = 1, J-2 + VALUE = MAX( VALUE, ABS( QG(I,J) ) ) + 10 CONTINUE + DO 20 I = J+1, N + VALUE = MAX( VALUE, ABS( QG(I,J) ) ) + 20 CONTINUE + 30 CONTINUE + END IF +C + ELSE IF ( LSAME( NORM, 'M' ) ) THEN +C +C Find max( abs( A(i,j) ), abs( QG(i,j) ) ). +C + VALUE = MAX( DLANGE( 'MaxElement', N, N, A, LDA, DWORK ), + $ DLANGE( 'MaxElement', N, N+1, QG, LDQG, + $ DWORK ) ) +C + ELSE IF ( ( LSAME( NORM, 'O' ) .OR. ( NORM.EQ.'1' ) .OR. + $ LSAME( NORM, 'I' ) ) .AND. LSH ) THEN +C +C Find the column and row sums of A (in one pass). +C + VALUE = ZERO + DO 40 I = 1, N + DWORK(I) = ZERO + 40 CONTINUE +C + DO 60 J = 1, N + SUM = ZERO + DO 50 I = 1, N + TEMP = ABS( A(I,J) ) + SUM = SUM + TEMP + DWORK(I) = DWORK(I) + TEMP + 50 CONTINUE + DWORK(N+J) = SUM + 60 CONTINUE +C +C Compute the maximal absolute column sum. +C + DO 90 J = 1, N+1 + DO 70 I = 1, J-2 + TEMP = ABS( QG(I,J) ) + DWORK(I) = DWORK(I) + TEMP + DWORK(J-1) = DWORK(J-1) + TEMP + 70 CONTINUE + IF ( J.LT.N+1 ) THEN + SUM = DWORK(N+J) + DO 80 I = J+1, N + TEMP = ABS( QG(I,J) ) + SUM = SUM + TEMP + DWORK(N+I) = DWORK(N+I) + TEMP + 80 CONTINUE + VALUE = MAX( VALUE, SUM ) + END IF + 90 CONTINUE + DO 100 I = 1, N + VALUE = MAX( VALUE, DWORK(I) ) + 100 CONTINUE +C + ELSE IF ( LSAME( NORM, 'O' ) .OR. ( NORM.EQ.'1' ) .OR. + $ LSAME( NORM, 'I' ) ) THEN +C +C Find the column and row sums of A (in one pass). +C + VALUE = ZERO + DO 110 I = 1, N + DWORK(I) = ZERO + 110 CONTINUE +C + DO 130 J = 1, N + SUM = ZERO + DO 120 I = 1, N + TEMP = ABS( A(I,J) ) + SUM = SUM + TEMP + DWORK(I) = DWORK(I) + TEMP + 120 CONTINUE + DWORK(N+J) = SUM + 130 CONTINUE +C +C Compute the maximal absolute column sum. +C + DO 160 J = 1, N+1 + DO 140 I = 1, J-2 + TEMP = ABS( QG(I,J) ) + DWORK(I) = DWORK(I) + TEMP + DWORK(J-1) = DWORK(J-1) + TEMP + 140 CONTINUE + IF ( J.GT.1 ) + $ DWORK(J-1) = DWORK(J-1) + ABS( QG(J-1,J) ) + IF ( J.LT.N+1 ) THEN + SUM = DWORK(N+J) + ABS( QG(J,J) ) + DO 150 I = J+1, N + TEMP = ABS( QG(I,J) ) + SUM = SUM + TEMP + DWORK(N+I) = DWORK(N+I) + TEMP + 150 CONTINUE + VALUE = MAX( VALUE, SUM ) + END IF + 160 CONTINUE + DO 170 I = 1, N + VALUE = MAX( VALUE, DWORK(I) ) + 170 CONTINUE +C + ELSE IF ( ( LSAME( NORM, 'F' ) .OR. + $ LSAME( NORM, 'E' ) ) .AND. LSH ) THEN +C +C Find normF(A). +C + SCALE = ZERO + SUM = ONE + DO 180 J = 1, N + CALL DLASSQ( N, A(1,J), 1, SCALE, SUM ) + 180 CONTINUE +C +C Add normF(G) and normF(Q). +C + DO 190 J = 1, N+1 + IF ( J.GT.2 ) + $ CALL DLASSQ( J-2, QG(1,J), 1, SCALE, SUM ) + IF ( J.LT.N ) + $ CALL DLASSQ( N-J, QG(J+1,J), 1, SCALE, SUM ) + 190 CONTINUE + VALUE = SQRT( TWO )*SCALE*SQRT( SUM ) + ELSE IF ( LSAME( NORM, 'F' ) .OR. LSAME( NORM, 'E' ) ) THEN + SCALE = ZERO + SUM = ONE + DO 200 J = 1, N + CALL DLASSQ( N, A(1,J), 1, SCALE, SUM ) + 200 CONTINUE + DSCL = ZERO + DSUM = ONE + DO 210 J = 1, N+1 + IF ( J.GT.1 ) THEN + CALL DLASSQ( J-2, QG(1,J), 1, SCALE, SUM ) + CALL DLASSQ( 1, QG(J-1,J), 1, DSCL, DSUM ) + END IF + IF ( J.LT.N+1 ) THEN + CALL DLASSQ( 1, QG(J,J), 1, DSCL, DSUM ) + CALL DLASSQ( N-J, QG(J+1,J), 1, SCALE, SUM ) + END IF + 210 CONTINUE + VALUE = DLAPY2( SQRT( TWO )*SCALE*SQRT( SUM ), + $ DSCL*SQRT( DSUM ) ) + END IF +C + MA02ID = VALUE + RETURN +C *** Last line of MA02ID *** + END diff --git a/mex/sources/libslicot/MA02JD.f b/mex/sources/libslicot/MA02JD.f new file mode 100644 index 000000000..ebf75d0a2 --- /dev/null +++ b/mex/sources/libslicot/MA02JD.f @@ -0,0 +1,164 @@ + DOUBLE PRECISION FUNCTION MA02JD( LTRAN1, LTRAN2, N, Q1, LDQ1, Q2, + $ LDQ2, RES, LDRES ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute || Q^T Q - I ||_F for a matrix of the form +C +C [ op( Q1 ) op( Q2 ) ] +C Q = [ ], +C [ -op( Q2 ) op( Q1 ) ] +C +C where Q1 and Q2 are N-by-N matrices. This residual can be used to +C test wether Q is numerically an orthogonal symplectic matrix. +C +C FUNCTION VALUE +C +C MA02JD DOUBLE PRECISION +C The computed residual. +C +C ARGUMENTS +C +C Mode Parameters +C +C LTRAN1 LOGICAL +C Specifies the form of op( Q1 ) as follows: +C = .FALSE.: op( Q1 ) = Q1; +C = .TRUE. : op( Q1 ) = Q1'. +C +C LTRAN2 LOGICAL +C Specifies the form of op( Q2 ) as follows: +C = .FALSE.: op( Q2 ) = Q2; +C = .TRUE. : op( Q2 ) = Q2'. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices Q1 and Q2. N >= 0. +C +C Q1 (input) DOUBLE PRECISION array, dimension (LDQ1,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix op( Q1 ). +C +C LDQ1 INTEGER +C The leading dimension of the array Q1. LDQ1 >= MAX(1,N). +C +C Q2 (input) DOUBLE PRECISION array, dimension (LDQ2,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix op( Q2 ). +C +C LDQ2 INTEGER +C The leading dimension of the array Q2. LDQ2 >= MAX(1,N). +C +C Workspace +C +C RES DOUBLE PRECISION array, dimension (LDRES,N) +C +C LDRES INTEGER +C The leading dimension of the array RES. LDRES >= MAX(1,N). +C +C METHOD +C +C The routine computes the residual by simple elementary operations. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAORS). +C +C KEYWORDS +C +C Elementary operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + LOGICAL LTRAN1, LTRAN2 + INTEGER LDQ1, LDQ2, LDRES, N +C .. Array Arguments .. + DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), RES(LDRES,*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION TEMP +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1) +C .. External Subroutines .. + EXTERNAL DGEMM +C .. External Functions .. + DOUBLE PRECISION DLANGE, DLAPY2 + EXTERNAL DLANGE, DLAPY2 +C .. Intrinsic Functions .. + INTRINSIC SQRT +C +C .. Executable Statements .. +C + IF ( LTRAN1 ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q1, + $ LDQ1, Q1, LDQ1, ZERO, RES, LDRES ) + ELSE + CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q1, + $ LDQ1, Q1, LDQ1, ZERO, RES, LDRES ) + END IF + IF ( LTRAN2 ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q2, + $ LDQ2, Q2, LDQ2, ONE, RES, LDRES ) + ELSE + CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q2, + $ LDQ2, Q2, LDQ2, ONE, RES, LDRES ) + END IF + DO 10 I = 1, N + RES(I,I) = RES(I,I) - ONE + 10 CONTINUE + TEMP = DLANGE( 'Frobenius', N, N, RES, LDRES, DUMMY ) + IF ( LTRAN1 .AND. LTRAN2 ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q2, + $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) + CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q1, + $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) + ELSE IF ( LTRAN1 ) THEN + CALL DGEMM( 'Transpose', 'Transpose', N, N, N, ONE, Q2, + $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, Q1, + $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) + ELSE IF ( LTRAN2 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, Q2, + $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) + CALL DGEMM( 'Transpose', 'Transpose', N, N, N, ONE, Q1, + $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) + ELSE + CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q2, + $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) + CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q1, + $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) + END IF + TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, RES, LDRES, + $ DUMMY ) ) + MA02JD = SQRT( TWO )*TEMP + RETURN +C *** Last line of MA02JD *** + END diff --git a/mex/sources/libslicot/MB01MD.f b/mex/sources/libslicot/MB01MD.f new file mode 100644 index 000000000..94f99f57a --- /dev/null +++ b/mex/sources/libslicot/MB01MD.f @@ -0,0 +1,279 @@ + SUBROUTINE MB01MD( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, + $ INCY ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the matrix-vector operation +C +C y := alpha*A*x + beta*y, +C +C where alpha and beta are scalars, x and y are vectors of length +C n and A is an n-by-n skew-symmetric matrix. +C +C This is a modified version of the vanilla implemented BLAS +C routine DSYMV written by Jack Dongarra, Jeremy Du Croz, +C Sven Hammarling, and Richard Hanson. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies whether the upper or lower triangular part of +C the array A is to be referenced as follows: +C = 'U': only the strictly upper triangular part of A is to +C be referenced; +C = 'L': only the strictly lower triangular part of A is to +C be referenced. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. If alpha is zero the array A is not +C referenced. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C On entry with UPLO = 'U', the leading N-by-N part of this +C array must contain the strictly upper triangular part of +C the matrix A. The lower triangular part of this array is +C not referenced. +C On entry with UPLO = 'L', the leading N-by-N part of this +C array must contain the strictly lower triangular part of +C the matrix A. The upper triangular part of this array is +C not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N) +C +C X (input) DOUBLE PRECISION array, dimension +C ( 1 + ( N - 1 )*abs( INCX ) ). +C On entry, elements 1, INCX+1, .., ( N - 1 )*INCX + 1 of +C this array must contain the elements of the vector X. +C +C INCX (input) INTEGER +C The increment for the elements of X. IF INCX < 0 then the +C elements of X are accessed in reversed order. INCX <> 0. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. If beta is zero then Y need not be set on +C input. +C +C Y (input/output) DOUBLE PRECISION array, dimension +C ( 1 + ( N - 1 )*abs( INCY ) ). +C On entry, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of +C this array must contain the elements of the vector Y. +C On exit, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of +C this array contain the updated elements of the vector Y. +C +C INCY (input) INTEGER +C The increment for the elements of Y. IF INCY < 0 then the +C elements of Y are accessed in reversed order. INCY <> 0. +C +C NUMERICAL ASPECTS +C +C Though being almost identical with the vanilla implementation +C of the BLAS routine DSYMV the performance of this routine could +C be significantly lower in the case of vendor supplied, highly +C optimized BLAS. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, May 2008 (SLICOT version of the HAPACK routine DSKMV). +C +C KEYWORDS +C +C Elementary matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDA, N + CHARACTER UPLO +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), X(*), Y(*) +C .. Local Scalars .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable Statements .. +C +C Test the input parameters. +C + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = 1 + ELSE IF ( N.LT.0 )THEN + INFO = 2 + ELSE IF ( LDA.LT.MAX( 1, N ) )THEN + INFO = 5 + ELSE IF ( INCX.EQ.0 )THEN + INFO = 7 + ELSE IF ( INCY.EQ.0 )THEN + INFO = 10 + END IF + IF ( INFO.NE.0 )THEN + CALL XERBLA( 'MB01MD', INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +C +C Set up the start points in X and Y. +C + IF ( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF ( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF +C +C Start the operations. In this version the elements of A are +C accessed sequentially with one pass through the triangular part +C of A. +C +C First form y := beta*y. +C + IF ( BETA.NE.ONE )THEN + IF ( INCY.EQ.1 )THEN + IF ( BETA.EQ.ZERO )THEN + DO 10 I = 1, N + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1, N + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF ( BETA.EQ.ZERO )THEN + DO 30 I = 1, N + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1, N + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF +C +C Quick return if possible. +C + IF ( ALPHA.EQ.ZERO ) + $ RETURN + IF ( LSAME( UPLO, 'U' ) )THEN +C +C Form y when A is stored in upper triangle. +C + IF ( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60 J = 2, N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + DO 50, I = 1, J - 1 + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 + A(I,J)*X(I) + 50 CONTINUE + Y(J) = Y(J) - ALPHA*TEMP2 + 60 CONTINUE + ELSE + JX = KX + INCX + JY = KY + INCY + DO 80 J = 2, N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70 I = 1, J - 1 + Y(IY) = Y(IY) + TEMP1*A(I,J) + TEMP2 = TEMP2 + A(I,J)*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) - ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + ELSE +C +C Form y when A is stored in lower triangle. +C + IF ( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) )THEN + DO 100 J = 1, N - 1 + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + DO 90 I = J + 1, N + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 + A(I,J)*X(I) + 90 CONTINUE + Y(J) = Y(J) - ALPHA*TEMP2 + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120 J = 1, N - 1 + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = JX + IY = JY + DO 110 I = J + 1, N + IX = IX + INCX + IY = IY + INCY + Y(IY ) = Y(IY) + TEMP1*A(I,J) + TEMP2 = TEMP2 + A(I,J)*X(IX) + 110 CONTINUE + Y(JY) = Y(JY) - ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 120 CONTINUE + END IF + END IF +C *** Last line of MB01MD *** + END diff --git a/mex/sources/libslicot/MB01ND.f b/mex/sources/libslicot/MB01ND.f new file mode 100644 index 000000000..036facf71 --- /dev/null +++ b/mex/sources/libslicot/MB01ND.f @@ -0,0 +1,249 @@ + SUBROUTINE MB01ND( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the skew-symmetric rank 2 operation +C +C A := alpha*x*y' - alpha*y*x' + A, +C +C where alpha is a scalar, x and y are vectors of length n and A is +C an n-by-n skew-symmetric matrix. +C +C This is a modified version of the vanilla implemented BLAS +C routine DSYR2 written by Jack Dongarra, Jeremy Du Croz, +C Sven Hammarling, and Richard Hanson. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies whether the upper or lower triangular part of +C the array A is to be referenced as follows: +C = 'U': only the strictly upper triangular part of A is to +C be referenced; +C = 'L': only the strictly lower triangular part of A is to +C be referenced. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. If alpha is zero X and Y are not +C referenced. +C +C X (input) DOUBLE PRECISION array, dimension +C ( 1 + ( N - 1 )*abs( INCX ) ). +C On entry, elements 1, INCX+1, .., ( N - 1 )*INCX + 1 of +C this array must contain the elements of the vector X. +C +C INCX (input) INTEGER +C The increment for the elements of X. IF INCX < 0 then the +C elements of X are accessed in reversed order. INCX <> 0. +C +C Y (input) DOUBLE PRECISION array, dimension +C ( 1 + ( N - 1 )*abs( INCY ) ). +C On entry, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of +C this array must contain the elements of the vector Y. +C +C INCY (input) INTEGER +C The increment for the elements of Y. IF INCY < 0 then the +C elements of Y are accessed in reversed order. INCY <> 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry with UPLO = 'U', the leading N-by-N part of this +C array must contain the strictly upper triangular part of +C the matrix A. The lower triangular part of this array is +C not referenced. +C On entry with UPLO = 'L', the leading N-by-N part of this +C array must contain the strictly lower triangular part of +C the matrix A. The upper triangular part of this array is +C not referenced. +C On exit with UPLO = 'U', the leading N-by-N part of this +C array contains the strictly upper triangular part of the +C updated matrix A. +C On exit with UPLO = 'L', the leading N-by-N part of this +C array contains the strictly lower triangular part of the +C updated matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N) +C +C NUMERICAL ASPECTS +C +C Though being almost identical with the vanilla implementation +C of the BLAS routine DSYR2 the performance of this routine could +C be significantly lower in the case of vendor supplied, highly +C optimized BLAS. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, May 2008 (SLICOT version of the HAPACK routine DSKR2). +C +C KEYWORDS +C +C Elementary matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX, INCY, LDA, N + CHARACTER UPLO +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +C .. Local Scalars .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable Statements .. +C +C Test the input parameters. +C + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF ( N.LT.0 )THEN + INFO = 2 + ELSE IF ( INCX.EQ.0 )THEN + INFO = 5 + ELSE IF ( INCY.EQ.0 )THEN + INFO = 7 + ELSE IF ( LDA.LT.MAX( 1, N ) )THEN + INFO = 9 + END IF +C + IF ( INFO.NE.0 )THEN + CALL XERBLA( 'MB01ND', INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) + $ RETURN +C +C Set up the start points in X and Y if the increments are not both +C unity. +C + IF ( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN + IF ( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF ( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF + JX = KX + JY = KY + END IF +C +C Start the operations. In this version the elements of A are +C accessed sequentially with one pass through the triangular part +C of A. +C + IF ( LSAME( UPLO, 'U' ) )THEN +C +C Form A when A is stored in the upper triangle. +C + IF ( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 20 J = 2, N + IF ( ( X(J).NE.ZERO ).OR.( Y(J).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y(J) + TEMP2 = ALPHA*X(J) + DO 10 I = 1, J-1 + A(I,J) = A(I,J) + X(I)*TEMP1 - Y(I)*TEMP2 + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + DO 40 J = 2, N + IF ( ( X(JX).NE.ZERO ).OR.( Y(JY).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = KX + IY = KY + DO 30 I = 1, J-1 + A(I,J) = A(I,J) + X(IX)*TEMP1 - Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 40 CONTINUE + END IF + ELSE +C +C Form A when A is stored in the lower triangle. +C + IF ( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60 J = 1, N-1 + IF ( ( X(J).NE.ZERO ).OR.( Y(J).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y(J) + TEMP2 = ALPHA*X(J) + DO 50 I = J+1, N + A(I,J) = A(I,J) + X(I)*TEMP1 - Y(I)*TEMP2 + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + DO 80 J = 1, N-1 + IF ( ( X(JX).NE.ZERO ).OR.( Y(JY).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = JX + IY = JY + DO 70 I = J+1, N + A(I,J) = A(I,J) + X(IX)*TEMP1 - Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + END IF + RETURN +C *** Last line of MB01ND *** + END diff --git a/mex/sources/libslicot/MB01PD.f b/mex/sources/libslicot/MB01PD.f new file mode 100644 index 000000000..1845ab8a8 --- /dev/null +++ b/mex/sources/libslicot/MB01PD.f @@ -0,0 +1,271 @@ + SUBROUTINE MB01PD( SCUN, TYPE, M, N, KL, KU, ANRM, NBL, NROWS, A, + $ LDA, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To scale a matrix or undo scaling. Scaling is performed, if +C necessary, so that the matrix norm will be in a safe range of +C representable numbers. +C +C ARGUMENTS +C +C Mode Parameters +C +C SCUN CHARACTER*1 +C SCUN indicates the operation to be performed. +C = 'S': scale the matrix. +C = 'U': undo scaling of the matrix. +C +C TYPE CHARACTER*1 +C TYPE indicates the storage type of the input matrix. +C = 'G': A is a full matrix. +C = 'L': A is a (block) lower triangular matrix. +C = 'U': A is an (block) upper triangular matrix. +C = 'H': A is an (block) upper Hessenberg matrix. +C = 'B': A is a symmetric band matrix with lower bandwidth +C KL and upper bandwidth KU and with the only the +C lower half stored. +C = 'Q': A is a symmetric band matrix with lower bandwidth +C KL and upper bandwidth KU and with the only the +C upper half stored. +C = 'Z': A is a band matrix with lower bandwidth KL and +C upper bandwidth KU. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C KL (input) INTEGER +C The lower bandwidth of A. Referenced only if TYPE = 'B', +C 'Q' or 'Z'. +C +C KU (input) INTEGER +C The upper bandwidth of A. Referenced only if TYPE = 'B', +C 'Q' or 'Z'. +C +C ANRM (input) DOUBLE PRECISION +C The norm of the initial matrix A. ANRM >= 0. +C When ANRM = 0 then an immediate return is effected. +C ANRM should be preserved between the call of the routine +C with SCUN = 'S' and the corresponding one with SCUN = 'U'. +C +C NBL (input) INTEGER +C The number of diagonal blocks of the matrix A, if it has a +C block structure. To specify that matrix A has no block +C structure, set NBL = 0. NBL >= 0. +C +C NROWS (input) INTEGER array, dimension max(1,NBL) +C NROWS(i) contains the number of rows and columns of the +C i-th diagonal block of matrix A. The sum of the values +C NROWS(i), for i = 1: NBL, should be equal to min(M,N). +C The elements of the array NROWS are not referenced if +C NBL = 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading M by N part of this array must +C contain the matrix to be scaled/unscaled. +C On exit, the leading M by N part of A will contain +C the modified matrix. +C The storage mode of A is specified by TYPE. +C +C LDA (input) INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C Error Indicator +C +C INFO (output) INTEGER +C = 0: successful exit +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Denote by ANRM the norm of the matrix, and by SMLNUM and BIGNUM, +C two positive numbers near the smallest and largest safely +C representable numbers, respectively. The matrix is scaled, if +C needed, such that the norm of the result is in the range +C [SMLNUM, BIGNUM]. The scaling factor is represented as a ratio +C of two numbers, one of them being ANRM, and the other one either +C SMLNUM or BIGNUM, depending on ANRM being less than SMLNUM or +C larger than BIGNUM, respectively. For undoing the scaling, the +C norm is again compared with SMLNUM or BIGNUM, and the reciprocal +C of the previous scaling factor is used. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C +C REVISIONS +C +C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER SCUN, TYPE + INTEGER INFO, KL, KU, LDA, M, MN, N, NBL + DOUBLE PRECISION ANRM +C .. Array Arguments .. + INTEGER NROWS ( * ) + DOUBLE PRECISION A( LDA, * ) +C .. Local Scalars .. + LOGICAL FIRST, LSCALE + INTEGER I, ISUM, ITYPE + DOUBLE PRECISION BIGNUM, SMLNUM +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DLABAD, MB01QD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Save statement .. + SAVE BIGNUM, FIRST, SMLNUM +C .. Data statements .. + DATA FIRST/.TRUE./ +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LSCALE = LSAME( SCUN, 'S' ) + IF( LSAME( TYPE, 'G' ) ) THEN + ITYPE = 0 + ELSE IF( LSAME( TYPE, 'L' ) ) THEN + ITYPE = 1 + ELSE IF( LSAME( TYPE, 'U' ) ) THEN + ITYPE = 2 + ELSE IF( LSAME( TYPE, 'H' ) ) THEN + ITYPE = 3 + ELSE IF( LSAME( TYPE, 'B' ) ) THEN + ITYPE = 4 + ELSE IF( LSAME( TYPE, 'Q' ) ) THEN + ITYPE = 5 + ELSE IF( LSAME( TYPE, 'Z' ) ) THEN + ITYPE = 6 + ELSE + ITYPE = -1 + END IF +C + MN = MIN( M, N ) +C + ISUM = 0 + IF( NBL.GT.0 ) THEN + DO 10 I = 1, NBL + ISUM = ISUM + NROWS(I) + 10 CONTINUE + END IF +C + IF( .NOT.LSCALE .AND. .NOT.LSAME( SCUN, 'U' ) ) THEN + INFO = -1 + ELSE IF( ITYPE.EQ.-1 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 .OR. + $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. N.NE.M ) ) THEN + INFO = -4 + ELSE IF( ANRM.LT.ZERO ) THEN + INFO = -7 + ELSE IF( NBL.LT.0 ) THEN + INFO = -8 + ELSE IF( NBL.GT.0 .AND. ISUM.NE.MN ) THEN + INFO = -9 + ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( ITYPE.GE.4 ) THEN + IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN + INFO = -5 + ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. + $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) + $ THEN + INFO = -6 + ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. + $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. + $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN + INFO = -11 + END IF + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB01PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MN.EQ.0 .OR. ANRM.EQ.ZERO ) + $ RETURN +C + IF ( FIRST ) THEN +C +C Get machine parameters. +C + SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + FIRST = .FALSE. + END IF +C + IF ( LSCALE ) THEN +C +C Scale A, if its norm is outside range [SMLNUM,BIGNUM]. +C + IF( ANRM.LT.SMLNUM ) THEN +C +C Scale matrix norm up to SMLNUM. +C + CALL MB01QD( TYPE, M, N, KL, KU, ANRM, SMLNUM, NBL, NROWS, + $ A, LDA, INFO ) + ELSE IF( ANRM.GT.BIGNUM ) THEN +C +C Scale matrix norm down to BIGNUM. +C + CALL MB01QD( TYPE, M, N, KL, KU, ANRM, BIGNUM, NBL, NROWS, + $ A, LDA, INFO ) + END IF +C + ELSE +C +C Undo scaling. +C + IF( ANRM.LT.SMLNUM ) THEN + CALL MB01QD( TYPE, M, N, KL, KU, SMLNUM, ANRM, NBL, NROWS, + $ A, LDA, INFO ) + ELSE IF( ANRM.GT.BIGNUM ) THEN + CALL MB01QD( TYPE, M, N, KL, KU, BIGNUM, ANRM, NBL, NROWS, + $ A, LDA, INFO ) + END IF + END IF +C + RETURN +C *** Last line of MB01PD *** + END diff --git a/mex/sources/libslicot/MB01QD.f b/mex/sources/libslicot/MB01QD.f new file mode 100644 index 000000000..61befc51a --- /dev/null +++ b/mex/sources/libslicot/MB01QD.f @@ -0,0 +1,334 @@ + SUBROUTINE MB01QD( TYPE, M, N, KL, KU, CFROM, CTO, NBL, NROWS, A, + $ LDA, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To multiply the M by N real matrix A by the real scalar CTO/CFROM. +C This is done without over/underflow as long as the final result +C CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that +C A may be full, (block) upper triangular, (block) lower triangular, +C (block) upper Hessenberg, or banded. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPE CHARACTER*1 +C TYPE indices the storage type of the input matrix. +C = 'G': A is a full matrix. +C = 'L': A is a (block) lower triangular matrix. +C = 'U': A is a (block) upper triangular matrix. +C = 'H': A is a (block) upper Hessenberg matrix. +C = 'B': A is a symmetric band matrix with lower bandwidth +C KL and upper bandwidth KU and with the only the +C lower half stored. +C = 'Q': A is a symmetric band matrix with lower bandwidth +C KL and upper bandwidth KU and with the only the +C upper half stored. +C = 'Z': A is a band matrix with lower bandwidth KL and +C upper bandwidth KU. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C KL (input) INTEGER +C The lower bandwidth of A. Referenced only if TYPE = 'B', +C 'Q' or 'Z'. +C +C KU (input) INTEGER +C The upper bandwidth of A. Referenced only if TYPE = 'B', +C 'Q' or 'Z'. +C +C CFROM (input) DOUBLE PRECISION +C CTO (input) DOUBLE PRECISION +C The matrix A is multiplied by CTO/CFROM. A(I,J) is +C computed without over/underflow if the final result +C CTO*A(I,J)/CFROM can be represented without over/ +C underflow. CFROM must be nonzero. +C +C NBL (input) INTEGER +C The number of diagonal blocks of the matrix A, if it has a +C block structure. To specify that matrix A has no block +C structure, set NBL = 0. NBL >= 0. +C +C NROWS (input) INTEGER array, dimension max(1,NBL) +C NROWS(i) contains the number of rows and columns of the +C i-th diagonal block of matrix A. The sum of the values +C NROWS(i), for i = 1: NBL, should be equal to min(M,N). +C The array NROWS is not referenced if NBL = 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C The matrix to be multiplied by CTO/CFROM. See TYPE for +C the storage type. +C +C LDA (input) INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C Error Indicator +C +C INFO INTEGER +C Not used in this implementation. +C +C METHOD +C +C Matrix A is multiplied by the real scalar CTO/CFROM, taking into +C account the specified storage mode of the matrix. +C MB01QD is a version of the LAPACK routine DLASCL, modified for +C dealing with block triangular, or block Hessenberg matrices. +C For efficiency, no tests of the input scalar parameters are +C performed. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. +C .. Scalar Arguments .. + CHARACTER TYPE + INTEGER INFO, KL, KU, LDA, M, N, NBL + DOUBLE PRECISION CFROM, CTO +C .. +C .. Array Arguments .. + INTEGER NROWS ( * ) + DOUBLE PRECISION A( LDA, * ) +C .. +C .. Local Scalars .. + LOGICAL DONE, NOBLC + INTEGER I, IFIN, ITYPE, J, JFIN, JINI, K, K1, K2, K3, + $ K4 + DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. +C .. Executable Statements .. +C + IF( LSAME( TYPE, 'G' ) ) THEN + ITYPE = 0 + ELSE IF( LSAME( TYPE, 'L' ) ) THEN + ITYPE = 1 + ELSE IF( LSAME( TYPE, 'U' ) ) THEN + ITYPE = 2 + ELSE IF( LSAME( TYPE, 'H' ) ) THEN + ITYPE = 3 + ELSE IF( LSAME( TYPE, 'B' ) ) THEN + ITYPE = 4 + ELSE IF( LSAME( TYPE, 'Q' ) ) THEN + ITYPE = 5 + ELSE + ITYPE = 6 + END IF +C +C Quick return if possible. +C + IF( MIN( M, N ).EQ.0 ) + $ RETURN +C +C Get machine parameters. +C + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM +C + CFROMC = CFROM + CTOC = CTO +C + 10 CONTINUE + CFROM1 = CFROMC*SMLNUM + CTO1 = CTOC / BIGNUM + IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN + MUL = SMLNUM + DONE = .FALSE. + CFROMC = CFROM1 + ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN + MUL = BIGNUM + DONE = .FALSE. + CTOC = CTO1 + ELSE + MUL = CTOC / CFROMC + DONE = .TRUE. + END IF +C + NOBLC = NBL.EQ.0 +C + IF( ITYPE.EQ.0 ) THEN +C +C Full matrix +C + DO 30 J = 1, N + DO 20 I = 1, M + A( I, J ) = A( I, J )*MUL + 20 CONTINUE + 30 CONTINUE +C + ELSE IF( ITYPE.EQ.1 ) THEN +C + IF ( NOBLC ) THEN +C +C Lower triangular matrix +C + DO 50 J = 1, N + DO 40 I = J, M + A( I, J ) = A( I, J )*MUL + 40 CONTINUE + 50 CONTINUE +C + ELSE +C +C Block lower triangular matrix +C + JFIN = 0 + DO 80 K = 1, NBL + JINI = JFIN + 1 + JFIN = JFIN + NROWS( K ) + DO 70 J = JINI, JFIN + DO 60 I = JINI, M + A( I, J ) = A( I, J )*MUL + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + END IF +C + ELSE IF( ITYPE.EQ.2 ) THEN +C + IF ( NOBLC ) THEN +C +C Upper triangular matrix +C + DO 100 J = 1, N + DO 90 I = 1, MIN( J, M ) + A( I, J ) = A( I, J )*MUL + 90 CONTINUE + 100 CONTINUE +C + ELSE +C +C Block upper triangular matrix +C + JFIN = 0 + DO 130 K = 1, NBL + JINI = JFIN + 1 + JFIN = JFIN + NROWS( K ) + IF ( K.EQ.NBL ) JFIN = N + DO 120 J = JINI, JFIN + DO 110 I = 1, MIN( JFIN, M ) + A( I, J ) = A( I, J )*MUL + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + END IF +C + ELSE IF( ITYPE.EQ.3 ) THEN +C + IF ( NOBLC ) THEN +C +C Upper Hessenberg matrix +C + DO 150 J = 1, N + DO 140 I = 1, MIN( J+1, M ) + A( I, J ) = A( I, J )*MUL + 140 CONTINUE + 150 CONTINUE +C + ELSE +C +C Block upper Hessenberg matrix +C + JFIN = 0 + DO 180 K = 1, NBL + JINI = JFIN + 1 + JFIN = JFIN + NROWS( K ) +C + IF ( K.EQ.NBL ) THEN + JFIN = N + IFIN = N + ELSE + IFIN = JFIN + NROWS( K+1 ) + END IF +C + DO 170 J = JINI, JFIN + DO 160 I = 1, MIN( IFIN, M ) + A( I, J ) = A( I, J )*MUL + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE + END IF +C + ELSE IF( ITYPE.EQ.4 ) THEN +C +C Lower half of a symmetric band matrix +C + K3 = KL + 1 + K4 = N + 1 + DO 200 J = 1, N + DO 190 I = 1, MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 190 CONTINUE + 200 CONTINUE +C + ELSE IF( ITYPE.EQ.5 ) THEN +C +C Upper half of a symmetric band matrix +C + K1 = KU + 2 + K3 = KU + 1 + DO 220 J = 1, N + DO 210 I = MAX( K1-J, 1 ), K3 + A( I, J ) = A( I, J )*MUL + 210 CONTINUE + 220 CONTINUE +C + ELSE IF( ITYPE.EQ.6 ) THEN +C +C Band matrix +C + K1 = KL + KU + 2 + K2 = KL + 1 + K3 = 2*KL + KU + 1 + K4 = KL + KU + 1 + M + DO 240 J = 1, N + DO 230 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 230 CONTINUE + 240 CONTINUE +C + END IF +C + IF( .NOT.DONE ) + $ GO TO 10 +C + RETURN +C *** Last line of MB01QD *** + END diff --git a/mex/sources/libslicot/MB01RD.f b/mex/sources/libslicot/MB01RD.f new file mode 100644 index 000000000..2c53070de --- /dev/null +++ b/mex/sources/libslicot/MB01RD.f @@ -0,0 +1,345 @@ + SUBROUTINE MB01RD( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA, + $ X, LDX, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix formula +C _ +C R = alpha*R + beta*op( A )*X*op( A )', +C _ +C where alpha and beta are scalars, R, X, and R are symmetric +C matrices, A is a general matrix, and op( A ) is one of +C +C op( A ) = A or op( A ) = A'. +C +C The result is overwritten on R. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 _ +C Specifies which triangles of the symmetric matrices R, R, +C and X are given as follows: +C = 'U': the upper triangular part is given; +C = 'L': the lower triangular part is given. +C +C TRANS CHARACTER*1 +C Specifies the form of op( A ) to be used in the matrix +C multiplication as follows: +C = 'N': op( A ) = A; +C = 'T': op( A ) = A'; +C = 'C': op( A ) = A'. +C +C Input/Output Parameters +C +C M (input) INTEGER _ +C The order of the matrices R and R and the number of rows +C of the matrix op( A ). M >= 0. +C +C N (input) INTEGER +C The order of the matrix X and the number of columns of the +C the matrix op( A ). N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then R need not be +C set before entry, except when R is identified with X in +C the call (which is possible only in this case). +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then A and X are not +C referenced. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) +C On entry with UPLO = 'U', the leading M-by-M upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix R; the strictly +C lower triangular part of the array is used as workspace. +C On entry with UPLO = 'L', the leading M-by-M lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix R; the strictly +C upper triangular part of the array is used as workspace. +C On exit, the leading M-by-M upper triangular part (if +C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of +C this array contains the corresponding triangular part of +C _ +C the computed matrix R. If beta <> 0, the remaining +C strictly triangular part of this array contains the +C corresponding part of the matrix expression +C beta*op( A )*T*op( A )', where T is the triangular matrix +C defined in the Method section. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,M). +C +C A (input) DOUBLE PRECISION array, dimension (LDA,k) +C where k is N when TRANS = 'N' and is M when TRANS = 'T' or +C TRANS = 'C'. +C On entry with TRANS = 'N', the leading M-by-N part of this +C array must contain the matrix A. +C On entry with TRANS = 'T' or TRANS = 'C', the leading +C N-by-M part of this array must contain the matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,l), +C where l is M when TRANS = 'N' and is N when TRANS = 'T' or +C TRANS = 'C'. +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, if UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix X and the strictly +C lower triangular part of the array is not referenced. +C On entry, if UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix X and the strictly +C upper triangular part of the array is not referenced. +C On exit, each diagonal element of this array has half its +C input value, but the other elements are not modified. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= MAX(1,N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, the leading M-by-N part of this +C array (with the leading dimension MAX(1,M)) returns the +C matrix product beta*op( A )*T, where T is the triangular +C matrix defined in the Method section. +C This array is not referenced when beta = 0. +C +C LDWORK The length of the array DWORK. +C LDWORK >= MAX(1,M*N), if beta <> 0; +C LDWORK >= 1, if beta = 0. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -k, the k-th argument had an illegal +C value. +C +C METHOD +C +C The matrix expression is efficiently evaluated taking the symmetry +C into account. Specifically, let X = T + T', with T an upper or +C lower triangular matrix, defined by +C +C T = triu( X ) - (1/2)*diag( X ), if UPLO = 'U', +C T = tril( X ) - (1/2)*diag( X ), if UPLO = 'L', +C +C where triu, tril, and diag denote the upper triangular part, lower +C triangular part, and diagonal part of X, respectively. Then, +C +C op( A )*X*op( A )' = B + B', +C +C where B := op( A )*T*op( A )'. Matrix B is not symmetric, but it +C can be written as tri( B ) + stri( B ), where tri denotes the +C triangular part specified by UPLO, and stri denotes the remaining +C strictly triangular part. Let R = V + V', with V defined as T +C above. Then, the required triangular part of the result can be +C written as +C +C alpha*V + beta*tri( B ) + beta*(stri( B ))' + +C alpha*diag( V ) + beta*diag( tri( B ) ). +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately +C +C 2 2 +C 3/2 x M x N + 1/2 x M +C +C operations. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004, +C Apr. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D0 ) +C .. Scalar Arguments .. + CHARACTER TRANS, UPLO + INTEGER INFO, LDA, LDR, LDWORK, LDX, M, N + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), R(LDR,*), X(LDX,*) +C .. Local Scalars .. + CHARACTER*12 NTRAN + LOGICAL LTRANS, LUPLO + INTEGER J, JWORK, LDW, NROWA +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DLACPY, DLASCL, DLASET, + $ DSCAL, DTRMM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LUPLO = LSAME( UPLO, 'U' ) + LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF ( LTRANS ) THEN + NROWA = N + NTRAN = 'No transpose' + ELSE + NROWA = M + NTRAN = 'Transpose' + END IF +C + LDW = MAX( 1, M ) +C + IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN + INFO = -1 + ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDR.LT.LDW ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN + INFO = -10 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( ( BETA.NE.ZERO .AND. LDWORK.LT.MAX( 1, M*N ) ) + $ .OR.( BETA.EQ.ZERO .AND. LDWORK.LT.1 ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + CALL DSCAL( N, HALF, X, LDX+1 ) + IF ( M.EQ.0 ) + $ RETURN +C + IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN + IF ( ALPHA.EQ.ZERO ) THEN +C +C Special case alpha = 0. +C + CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) + ELSE +C +C Special case beta = 0 or N = 0. +C + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) + END IF + RETURN + END IF +C +C General case: beta <> 0. Efficiently compute +C _ +C R = alpha*R + beta*op( A )*X*op( A )', +C +C as described in the Method section. +C +C Compute W = beta*op( A )*T in DWORK. +C Workspace: need M*N. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code.) +C + IF( LTRANS ) THEN + JWORK = 1 +C + DO 10 J = 1, N + CALL DCOPY( M, A(J,1), LDA, DWORK(JWORK), 1 ) + JWORK = JWORK + LDW + 10 CONTINUE +C + ELSE + CALL DLACPY( 'Full', M, N, A, LDA, DWORK, LDW ) + END IF +C + CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', M, N, BETA, + $ X, LDX, DWORK, LDW ) +C +C Compute Y = alpha*V + W*op( A )' in R. First, set to zero the +C strictly triangular part of R not specified by UPLO. That part +C will then contain beta*stri( B ). +C + IF ( ALPHA.NE.ZERO ) THEN + IF ( M.GT.1 ) THEN + IF ( LUPLO ) THEN + CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, R(2,1), LDR ) + ELSE + CALL DLASET( 'Upper', M-1, M-1, ZERO, ZERO, R(1,2), LDR ) + END IF + END IF + CALL DSCAL( M, HALF, R, LDR+1 ) + END IF +C + CALL DGEMM( 'No transpose', NTRAN, M, M, N, ONE, DWORK, LDW, A, + $ LDA, ALPHA, R, LDR ) +C +C Add the term corresponding to B', with B = op( A )*T*op( A )'. +C + IF( LUPLO ) THEN +C + DO 20 J = 1, M + CALL DAXPY( J, ONE, R(J,1), LDR, R(1,J), 1 ) + 20 CONTINUE +C + ELSE +C + DO 30 J = 1, M + CALL DAXPY( J, ONE, R(1,J), 1, R(J,1), LDR ) + 30 CONTINUE +C + END IF +C + RETURN +C *** Last line of MB01RD *** + END diff --git a/mex/sources/libslicot/MB01RU.f b/mex/sources/libslicot/MB01RU.f new file mode 100644 index 000000000..c22549cc7 --- /dev/null +++ b/mex/sources/libslicot/MB01RU.f @@ -0,0 +1,282 @@ + SUBROUTINE MB01RU( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA, + $ X, LDX, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix formula +C _ +C R = alpha*R + beta*op( A )*X*op( A )', +C _ +C where alpha and beta are scalars, R, X, and R are symmetric +C matrices, A is a general matrix, and op( A ) is one of +C +C op( A ) = A or op( A ) = A'. +C +C The result is overwritten on R. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies which triangles of the symmetric matrices R +C and X are given as follows: +C = 'U': the upper triangular part is given; +C = 'L': the lower triangular part is given. +C +C TRANS CHARACTER*1 +C Specifies the form of op( A ) to be used in the matrix +C multiplication as follows: +C = 'N': op( A ) = A; +C = 'T': op( A ) = A'; +C = 'C': op( A ) = A'. +C +C Input/Output Parameters +C +C M (input) INTEGER _ +C The order of the matrices R and R and the number of rows +C of the matrix op( A ). M >= 0. +C +C N (input) INTEGER +C The order of the matrix X and the number of columns of the +C the matrix op( A ). N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then R need not be +C set before entry, except when R is identified with X in +C the call. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then A and X are not +C referenced. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) +C On entry with UPLO = 'U', the leading M-by-M upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix R. +C On entry with UPLO = 'L', the leading M-by-M lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix R. +C On exit, the leading M-by-M upper triangular part (if +C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of +C this array contains the corresponding triangular part of +C _ +C the computed matrix R. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,M). +C +C A (input) DOUBLE PRECISION array, dimension (LDA,k) +C where k is N when TRANS = 'N' and is M when TRANS = 'T' or +C TRANS = 'C'. +C On entry with TRANS = 'N', the leading M-by-N part of this +C array must contain the matrix A. +C On entry with TRANS = 'T' or TRANS = 'C', the leading +C N-by-M part of this array must contain the matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,k), +C where k is M when TRANS = 'N' and is N when TRANS = 'T' or +C TRANS = 'C'. +C +C X (input) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, if UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix X and the strictly +C lower triangular part of the array is not referenced. +C On entry, if UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix X and the strictly +C upper triangular part of the array is not referenced. +C The diagonal elements of this array are modified +C internally, but are restored on exit. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= MAX(1,N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C This array is not referenced when beta = 0, or M*N = 0. +C +C LDWORK The length of the array DWORK. +C LDWORK >= M*N, if beta <> 0; +C LDWORK >= 0, if beta = 0. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -k, the k-th argument had an illegal +C value. +C +C METHOD +C +C The matrix expression is efficiently evaluated taking the symmetry +C into account. Specifically, let X = T + T', with T an upper or +C lower triangular matrix, defined by +C +C T = triu( X ) - (1/2)*diag( X ), if UPLO = 'U', +C T = tril( X ) - (1/2)*diag( X ), if UPLO = 'L', +C +C where triu, tril, and diag denote the upper triangular part, lower +C triangular part, and diagonal part of X, respectively. Then, +C +C A*X*A' = ( A*T )*A' + A*( A*T )', for TRANS = 'N', +C A'*X*A = A'*( T*A ) + ( T*A )'*A, for TRANS = 'T', or 'C', +C +C which involve BLAS 3 operations (DTRMM and DSYR2K). +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately +C +C 2 2 +C 3/2 x M x N + 1/2 x M +C +C operations. +C +C FURTHER COMMENTS +C +C This is a simpler version for MB01RD. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1999. +C +C REVISIONS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2004. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, HALF + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ HALF = 0.5D0 ) +C .. Scalar Arguments .. + CHARACTER TRANS, UPLO + INTEGER INFO, LDA, LDR, LDWORK, LDX, M, N + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), R(LDR,*), X(LDX,*) +C .. Local Scalars .. + LOGICAL LTRANS, LUPLO +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DLASCL, DLASET, DSCAL, DSYR2K, DTRMM, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LUPLO = LSAME( UPLO, 'U' ) + LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN + INFO = -1 + ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDR.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDA.LT.1 .OR. ( LTRANS .AND. LDA.LT.N ) .OR. + $ ( .NOT.LTRANS .AND. LDA.LT.M ) ) THEN + INFO = -10 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( ( BETA.NE.ZERO .AND. LDWORK.LT.M*N ) + $ .OR.( BETA.EQ.ZERO .AND. LDWORK.LT.0 ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01RU', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN + IF ( ALPHA.EQ.ZERO ) THEN +C +C Special case alpha = 0. +C + CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) + ELSE +C +C Special case beta = 0 or N = 0. +C + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) + END IF + RETURN + END IF +C +C General case: beta <> 0. +C Compute W = op( A )*T or W = T*op( A ) in DWORK, and apply the +C updating formula (see METHOD section). +C Workspace: need M*N. +C + CALL DSCAL( N, HALF, X, LDX+1 ) +C + IF( LTRANS ) THEN +C + CALL DLACPY( 'Full', N, M, A, LDA, DWORK, N ) + CALL DTRMM( 'Left', UPLO, 'NoTranspose', 'Non-unit', N, M, + $ ONE, X, LDX, DWORK, N ) + CALL DSYR2K( UPLO, TRANS, M, N, BETA, DWORK, N, A, LDA, ALPHA, + $ R, LDR ) +C + ELSE +C + CALL DLACPY( 'Full', M, N, A, LDA, DWORK, M ) + CALL DTRMM( 'Right', UPLO, 'NoTranspose', 'Non-unit', M, N, + $ ONE, X, LDX, DWORK, M ) + CALL DSYR2K( UPLO, TRANS, M, N, BETA, DWORK, M, A, LDA, ALPHA, + $ R, LDR ) +C + END IF +C + CALL DSCAL( N, TWO, X, LDX+1 ) +C + RETURN +C *** Last line of MB01RU *** + END diff --git a/mex/sources/libslicot/MB01RW.f b/mex/sources/libslicot/MB01RW.f new file mode 100644 index 000000000..1305d3ed4 --- /dev/null +++ b/mex/sources/libslicot/MB01RW.f @@ -0,0 +1,249 @@ + SUBROUTINE MB01RW( UPLO, TRANS, M, N, A, LDA, Z, LDZ, DWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the transformation of the symmetric matrix A by the +C matrix Z in the form +C +C A := op(Z)*A*op(Z)', +C +C where op(Z) is either Z or its transpose, Z'. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies whether the upper or lower triangle of A +C is stored: +C = 'U': Upper triangle of A is stored; +C = 'L': Lower triangle of A is stored. +C +C TRANS CHARACTER*1 +C Specifies whether op(Z) is Z or its transpose Z': +C = 'N': op(Z) = Z; +C = 'T': op(Z) = Z'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the resulting symmetric matrix op(Z)*A*op(Z)' +C and the number of rows of the matrix Z, if TRANS = 'N', +C or the number of columns of the matrix Z, if TRANS = 'T'. +C M >= 0. +C +C N (input) INTEGER +C The order of the symmetric matrix A and the number of +C columns of the matrix Z, if TRANS = 'N', or the number of +C rows of the matrix Z, if TRANS = 'T'. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA,MAX(M,N)) +C On entry, the leading N-by-N upper or lower triangular +C part of this array must contain the upper (UPLO = 'U') +C or lower (UPLO = 'L') triangular part of the symmetric +C matrix A. +C On exit, the leading M-by-M upper or lower triangular +C part of this array contains the upper (UPLO = 'U') or +C lower (UPLO = 'L') triangular part of the symmetric +C matrix op(Z)*A*op(Z)'. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,M,N). +C +C Z (input) DOUBLE PRECISION array, dimension (LDQ,K) +C where K = N if TRANS = 'N' and K = M if TRANS = 'T'. +C The leading M-by-N part, if TRANS = 'N', or N-by-M part, +C if TRANS = 'T', of this array contains the matrix Z. +C +C LDZ INTEGER +C The leading dimension of the array Z. +C LDZ >= MAX(1,M) if TRANS = 'N' and +C LDZ >= MAX(1,N) if TRANS = 'T'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C FURTHER COMMENTS +C +C This is a simpler, BLAS 2 version for MB01RD. +C +C CONTRIBUTOR +C +C A. Varga, DLR, Feb. 1995. +C +C REVISIONS +C +C April 1998 (T. Penzl). +C Sep. 1998 (V. Sima). +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TRANS, UPLO + INTEGER INFO, LDA, LDZ, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL NOTTRA, UPPER + INTEGER I, J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable Statements +C + NOTTRA = LSAME( TRANS, 'N' ) + UPPER = LSAME( UPLO, 'U' ) +C + INFO = 0 + IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L') ) ) THEN + INFO = -1 + ELSE IF( .NOT.( NOTTRA .OR. LSAME( TRANS, 'T') ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M, N ) ) THEN + INFO = -6 + ELSE IF( ( NOTTRA .AND. LDZ.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.NOTTRA .AND. LDZ.LT.MAX( 1, N ) ) ) THEN + INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB01RW', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + IF ( NOTTRA ) THEN +C +C Compute Z*A*Z'. +C + IF ( UPPER ) THEN +C +C Compute Z*A in A (M-by-N). +C + DO 10 J = 1, N + CALL DCOPY( J-1, A(1,J), 1, DWORK, 1 ) + CALL DCOPY( N-J+1, A(J,J), LDA, DWORK(J), 1 ) + CALL DGEMV( TRANS, M, N, ONE, Z, LDZ, DWORK, 1, ZERO, + $ A(1,J), 1 ) + 10 CONTINUE +C +C Compute A*Z' in the upper triangular part of A. +C + DO 20 I = 1, M + CALL DCOPY( N, A(I,1), LDA, DWORK, 1 ) + CALL DGEMV( TRANS, M-I+1, N, ONE, Z(I,1), LDZ, DWORK, 1, + $ ZERO, A(I,I), LDA ) + 20 CONTINUE +C + ELSE +C +C Compute A*Z' in A (N-by-M). +C + DO 30 I = 1, N + CALL DCOPY( I-1, A(I,1), LDA, DWORK, 1 ) + CALL DCOPY( N-I+1, A(I,I), 1, DWORK(I), 1 ) + CALL DGEMV( TRANS, M, N, ONE, Z, LDZ, DWORK, 1, ZERO, + $ A(I,1), LDA ) + 30 CONTINUE +C +C Compute Z*A in the lower triangular part of A. +C + DO 40 J = 1, M + CALL DCOPY( N, A(1,J), 1, DWORK, 1 ) + CALL DGEMV( TRANS, M-J+1, N, ONE, Z(J,1), LDZ, DWORK, 1, + $ ZERO, A(J,J), 1 ) + 40 CONTINUE +C + END IF + ELSE +C +C Compute Z'*A*Z. +C + IF ( UPPER ) THEN +C +C Compute Z'*A in A (M-by-N). +C + DO 50 J = 1, N + CALL DCOPY( J-1, A(1,J), 1, DWORK, 1 ) + CALL DCOPY( N-J+1, A(J,J), LDA, DWORK(J), 1 ) + CALL DGEMV( TRANS, N, M, ONE, Z, LDZ, DWORK, 1, ZERO, + $ A(1,J), 1 ) + 50 CONTINUE +C +C Compute A*Z in the upper triangular part of A. +C + DO 60 I = 1, M + CALL DCOPY( N, A(I,1), LDA, DWORK, 1 ) + CALL DGEMV( TRANS, N, M-I+1, ONE, Z(1,I), LDZ, DWORK, 1, + $ ZERO, A(I,I), LDA ) + 60 CONTINUE +C + ELSE +C +C Compute A*Z in A (N-by-M). +C + DO 70 I = 1, N + CALL DCOPY( I-1, A(I,1), LDA, DWORK, 1 ) + CALL DCOPY( N-I+1, A(I,I), 1, DWORK(I), 1 ) + CALL DGEMV( TRANS, N, M, ONE, Z, LDZ, DWORK, 1, ZERO, + $ A(I,1), LDA ) + 70 CONTINUE +C +C Compute Z'*A in the lower triangular part of A. +C + DO 80 J = 1, M + CALL DCOPY( N, A(1,J), 1, DWORK, 1 ) + CALL DGEMV( TRANS, N, M-J+1, ONE, Z(1,J), LDZ, DWORK, 1, + $ ZERO, A(J,J), 1 ) + 80 CONTINUE +C + END IF + END IF +C + RETURN +C *** Last line of MB01RW *** + END diff --git a/mex/sources/libslicot/MB01RX.f b/mex/sources/libslicot/MB01RX.f new file mode 100644 index 000000000..64abe3901 --- /dev/null +++ b/mex/sources/libslicot/MB01RX.f @@ -0,0 +1,315 @@ + SUBROUTINE MB01RX( SIDE, UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, + $ A, LDA, B, LDB, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute either the upper or lower triangular part of one of the +C matrix formulas +C _ +C R = alpha*R + beta*op( A )*B, (1) +C _ +C R = alpha*R + beta*B*op( A ), (2) +C _ +C where alpha and beta are scalars, R and R are m-by-m matrices, +C op( A ) and B are m-by-n and n-by-m matrices for (1), or n-by-m +C and m-by-n matrices for (2), respectively, and op( A ) is one of +C +C op( A ) = A or op( A ) = A', the transpose of A. +C +C The result is overwritten on R. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies whether the matrix A appears on the left or +C right in the matrix product as follows: +C _ +C = 'L': R = alpha*R + beta*op( A )*B; +C _ +C = 'R': R = alpha*R + beta*B*op( A ). +C +C UPLO CHARACTER*1 _ +C Specifies which triangles of the matrices R and R are +C computed and given, respectively, as follows: +C = 'U': the upper triangular part; +C = 'L': the lower triangular part. +C +C TRANS CHARACTER*1 +C Specifies the form of op( A ) to be used in the matrix +C multiplication as follows: +C = 'N': op( A ) = A; +C = 'T': op( A ) = A'; +C = 'C': op( A ) = A'. +C +C Input/Output Parameters +C +C M (input) INTEGER _ +C The order of the matrices R and R, the number of rows of +C the matrix op( A ) and the number of columns of the +C matrix B, for SIDE = 'L', or the number of rows of the +C matrix B and the number of columns of the matrix op( A ), +C for SIDE = 'R'. M >= 0. +C +C N (input) INTEGER +C The number of rows of the matrix B and the number of +C columns of the matrix op( A ), for SIDE = 'L', or the +C number of rows of the matrix op( A ) and the number of +C columns of the matrix B, for SIDE = 'R'. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then R need not be +C set before entry. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then A and B are not +C referenced. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) +C On entry with UPLO = 'U', the leading M-by-M upper +C triangular part of this array must contain the upper +C triangular part of the matrix R; the strictly lower +C triangular part of the array is not referenced. +C On entry with UPLO = 'L', the leading M-by-M lower +C triangular part of this array must contain the lower +C triangular part of the matrix R; the strictly upper +C triangular part of the array is not referenced. +C On exit, the leading M-by-M upper triangular part (if +C UPLO = 'U'), or lower triangular part (if UPLO = 'L') of +C this array contains the corresponding triangular part of +C _ +C the computed matrix R. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,M). +C +C A (input) DOUBLE PRECISION array, dimension (LDA,k), where +C k = N when SIDE = 'L', and TRANS = 'N', or +C SIDE = 'R', and TRANS = 'T'; +C k = M when SIDE = 'R', and TRANS = 'N', or +C SIDE = 'L', and TRANS = 'T'. +C On entry, if SIDE = 'L', and TRANS = 'N', or +C SIDE = 'R', and TRANS = 'T', +C the leading M-by-N part of this array must contain the +C matrix A. +C On entry, if SIDE = 'R', and TRANS = 'N', or +C SIDE = 'L', and TRANS = 'T', +C the leading N-by-M part of this array must contain the +C matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,l), where +C l = M when SIDE = 'L', and TRANS = 'N', or +C SIDE = 'R', and TRANS = 'T'; +C l = N when SIDE = 'R', and TRANS = 'N', or +C SIDE = 'L', and TRANS = 'T'. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,p), where +C p = M when SIDE = 'L'; +C p = N when SIDE = 'R'. +C On entry, the leading N-by-M part, if SIDE = 'L', or +C M-by-N part, if SIDE = 'R', of this array must contain the +C matrix B. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,N), if SIDE = 'L'; +C LDB >= MAX(1,M), if SIDE = 'R'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix expression is evaluated taking the triangular +C structure into account. BLAS 2 operations are used. A block +C algorithm can be easily constructed; it can use BLAS 3 GEMM +C operations for most computations, and calls of this BLAS 2 +C algorithm for computing the triangles. +C +C FURTHER COMMENTS +C +C The main application of this routine is when the result should +C be a symmetric matrix, e.g., when B = X*op( A )', for (1), or +C B = op( A )'*X, for (2), where B is already available and X = X'. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER SIDE, TRANS, UPLO + INTEGER INFO, LDA, LDB, LDR, M, N + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), R(LDR,*) +C .. Local Scalars .. + LOGICAL LSIDE, LTRANS, LUPLO + INTEGER J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEMV, DLASCL, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LSIDE = LSAME( SIDE, 'L' ) + LUPLO = LSAME( UPLO, 'U' ) + LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN + INFO = -1 + ELSE IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN + INFO = -2 + ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDR.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.1 .OR. + $ ( ( ( LSIDE .AND. .NOT.LTRANS ) .OR. + $ ( .NOT.LSIDE .AND. LTRANS ) ) .AND. LDA.LT.M ) .OR. + $ ( ( ( LSIDE .AND. LTRANS ) .OR. + $ ( .NOT.LSIDE .AND. .NOT.LTRANS ) ) .AND. LDA.LT.N ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.1 .OR. + $ ( LSIDE .AND. LDB.LT.N ) .OR. + $ ( .NOT.LSIDE .AND. LDB.LT.M ) ) THEN + INFO = -13 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01RX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN + IF ( ALPHA.EQ.ZERO ) THEN +C +C Special case alpha = 0. +C + CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) + ELSE +C +C Special case beta = 0 or N = 0. +C + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) + END IF + RETURN + END IF +C +C General case: beta <> 0. +C Compute the required triangle of (1) or (2) using BLAS 2 +C operations. +C + IF( LSIDE ) THEN + IF( LUPLO ) THEN + IF ( LTRANS ) THEN + DO 10 J = 1, M + CALL DGEMV( TRANS, N, J, BETA, A, LDA, B(1,J), 1, + $ ALPHA, R(1,J), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, M + CALL DGEMV( TRANS, J, N, BETA, A, LDA, B(1,J), 1, + $ ALPHA, R(1,J), 1 ) + 20 CONTINUE + END IF + ELSE + IF ( LTRANS ) THEN + DO 30 J = 1, M + CALL DGEMV( TRANS, N, M-J+1, BETA, A(1,J), LDA, + $ B(1,J), 1, ALPHA, R(J,J), 1 ) + 30 CONTINUE + ELSE + DO 40 J = 1, M + CALL DGEMV( TRANS, M-J+1, N, BETA, A(J,1), LDA, + $ B(1,J), 1, ALPHA, R(J,J), 1 ) + 40 CONTINUE + END IF + END IF +C + ELSE + IF( LUPLO ) THEN + IF( LTRANS ) THEN + DO 50 J = 1, M + CALL DGEMV( 'NoTranspose', J, N, BETA, B, LDB, A(J,1), + $ LDA, ALPHA, R(1,J), 1 ) + 50 CONTINUE + ELSE + DO 60 J = 1, M + CALL DGEMV( 'NoTranspose', J, N, BETA, B, LDB, A(1,J), + $ 1, ALPHA, R(1,J), 1 ) + 60 CONTINUE + END IF + ELSE + IF( LTRANS ) THEN + DO 70 J = 1, M + CALL DGEMV( 'NoTranspose', M-J+1, N, BETA, B(J,1), + $ LDB, A(J,1), LDA, ALPHA, R(J,J), 1 ) + 70 CONTINUE + ELSE + DO 80 J = 1, M + CALL DGEMV( 'NoTranspose', M-J+1, N, BETA, B(J,1), + $ LDB, A(1,J), 1, ALPHA, R(J,J), 1 ) + 80 CONTINUE + END IF + END IF + END IF +C + RETURN +C *** Last line of MB01RX *** + END diff --git a/mex/sources/libslicot/MB01RY.f b/mex/sources/libslicot/MB01RY.f new file mode 100644 index 000000000..af32cfe63 --- /dev/null +++ b/mex/sources/libslicot/MB01RY.f @@ -0,0 +1,429 @@ + SUBROUTINE MB01RY( SIDE, UPLO, TRANS, M, ALPHA, BETA, R, LDR, H, + $ LDH, B, LDB, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute either the upper or lower triangular part of one of the +C matrix formulas +C _ +C R = alpha*R + beta*op( H )*B, (1) +C _ +C R = alpha*R + beta*B*op( H ), (2) +C _ +C where alpha and beta are scalars, H, B, R, and R are m-by-m +C matrices, H is an upper Hessenberg matrix, and op( H ) is one of +C +C op( H ) = H or op( H ) = H', the transpose of H. +C +C The result is overwritten on R. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies whether the Hessenberg matrix H appears on the +C left or right in the matrix product as follows: +C _ +C = 'L': R = alpha*R + beta*op( H )*B; +C _ +C = 'R': R = alpha*R + beta*B*op( H ). +C +C UPLO CHARACTER*1 _ +C Specifies which triangles of the matrices R and R are +C computed and given, respectively, as follows: +C = 'U': the upper triangular part; +C = 'L': the lower triangular part. +C +C TRANS CHARACTER*1 +C Specifies the form of op( H ) to be used in the matrix +C multiplication as follows: +C = 'N': op( H ) = H; +C = 'T': op( H ) = H'; +C = 'C': op( H ) = H'. +C +C Input/Output Parameters +C +C M (input) INTEGER _ +C The order of the matrices R, R, H and B. M >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then R need not be +C set before entry. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then H and B are not +C referenced. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) +C On entry with UPLO = 'U', the leading M-by-M upper +C triangular part of this array must contain the upper +C triangular part of the matrix R; the strictly lower +C triangular part of the array is not referenced. +C On entry with UPLO = 'L', the leading M-by-M lower +C triangular part of this array must contain the lower +C triangular part of the matrix R; the strictly upper +C triangular part of the array is not referenced. +C On exit, the leading M-by-M upper triangular part (if +C UPLO = 'U'), or lower triangular part (if UPLO = 'L') of +C this array contains the corresponding triangular part of +C _ +C the computed matrix R. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,M). +C +C H (input) DOUBLE PRECISION array, dimension (LDH,M) +C On entry, the leading M-by-M upper Hessenberg part of +C this array must contain the upper Hessenberg part of the +C matrix H. +C The elements below the subdiagonal are not referenced, +C except possibly for those in the first column, which +C could be overwritten, but are restored on exit. +C +C LDH INTEGER +C The leading dimension of array H. LDH >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading M-by-M part of this array must +C contain the matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C LDWORK >= M, if beta <> 0 and SIDE = 'L'; +C LDWORK >= 0, if beta = 0 or SIDE = 'R'. +C This array is not referenced when beta = 0 or SIDE = 'R'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix expression is efficiently evaluated taking the +C Hessenberg/triangular structure into account. BLAS 2 operations +C are used. A block algorithm can be constructed; it can use BLAS 3 +C GEMM operations for most computations, and calls of this BLAS 2 +C algorithm for computing the triangles. +C +C FURTHER COMMENTS +C +C The main application of this routine is when the result should +C be a symmetric matrix, e.g., when B = X*op( H )', for (1), or +C B = op( H )'*X, for (2), where B is already available and X = X'. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER SIDE, TRANS, UPLO + INTEGER INFO, LDB, LDH, LDR, M + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION B(LDB,*), DWORK(*), H(LDH,*), R(LDR,*) +C .. Local Scalars .. + LOGICAL LSIDE, LTRANS, LUPLO + INTEGER I, J +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL DDOT, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DLASCL, DLASET, DSCAL, DSWAP, + $ DTRMV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LSIDE = LSAME( SIDE, 'L' ) + LUPLO = LSAME( UPLO, 'U' ) + LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN + INFO = -1 + ELSE IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN + INFO = -2 + ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( LDR.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDH.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01RY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + IF ( BETA.EQ.ZERO ) THEN + IF ( ALPHA.EQ.ZERO ) THEN +C +C Special case when both alpha = 0 and beta = 0. +C + CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) + ELSE +C +C Special case beta = 0. +C + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) + END IF + RETURN + END IF +C +C General case: beta <> 0. +C Compute the required triangle of (1) or (2) using BLAS 2 +C operations. +C + IF( LSIDE ) THEN +C +C To avoid repeated references to the subdiagonal elements of H, +C these are swapped with the corresponding elements of H in the +C first column, and are finally restored. +C + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) +C + IF( LUPLO ) THEN + IF ( LTRANS ) THEN +C + DO 20 J = 1, M +C +C Multiply the transposed upper triangle of the leading +C j-by-j submatrix of H by the leading part of the j-th +C column of B. +C + CALL DCOPY( J, B( 1, J ), 1, DWORK, 1 ) + CALL DTRMV( 'Upper', TRANS, 'Non-unit', J, H, LDH, + $ DWORK, 1 ) +C +C Add the contribution of the subdiagonal of H to +C the j-th column of the product. +C + DO 10 I = 1, MIN( J, M - 1 ) + R( I, J ) = ALPHA*R( I, J ) + BETA*( DWORK( I ) + + $ H( I+1, 1 )*B( I+1, J ) ) + 10 CONTINUE +C + 20 CONTINUE +C + R( M, M ) = ALPHA*R( M, M ) + BETA*DWORK( M ) +C + ELSE +C + DO 40 J = 1, M +C +C Multiply the upper triangle of the leading j-by-j +C submatrix of H by the leading part of the j-th column +C of B. +C + CALL DCOPY( J, B( 1, J ), 1, DWORK, 1 ) + CALL DTRMV( 'Upper', TRANS, 'Non-unit', J, H, LDH, + $ DWORK, 1 ) + IF( J.LT.M ) THEN +C +C Multiply the remaining right part of the leading +C j-by-M submatrix of H by the trailing part of the +C j-th column of B. +C + CALL DGEMV( TRANS, J, M-J, BETA, H( 1, J+1 ), LDH, + $ B( J+1, J ), 1, ALPHA, R( 1, J ), 1 ) + ELSE + CALL DSCAL( M, ALPHA, R( 1, M ), 1 ) + END IF +C +C Add the contribution of the subdiagonal of H to +C the j-th column of the product. +C + R( 1, J ) = R( 1, J ) + BETA*DWORK( 1 ) +C + DO 30 I = 2, J + R( I, J ) = R( I, J ) + BETA*( DWORK( I ) + + $ H( I, 1 )*B( I-1, J ) ) + 30 CONTINUE +C + 40 CONTINUE +C + END IF +C + ELSE +C + IF ( LTRANS ) THEN +C + DO 60 J = M, 1, -1 +C +C Multiply the transposed upper triangle of the trailing +C (M-j+1)-by-(M-j+1) submatrix of H by the trailing part +C of the j-th column of B. +C + CALL DCOPY( M-J+1, B( J, J ), 1, DWORK( J ), 1 ) + CALL DTRMV( 'Upper', TRANS, 'Non-unit', M-J+1, + $ H( J, J ), LDH, DWORK( J ), 1 ) + IF( J.GT.1 ) THEN +C +C Multiply the remaining left part of the trailing +C (M-j+1)-by-(j-1) submatrix of H' by the leading +C part of the j-th column of B. +C + CALL DGEMV( TRANS, J-1, M-J+1, BETA, H( 1, J ), + $ LDH, B( 1, J ), 1, ALPHA, R( J, J ), + $ 1 ) + ELSE + CALL DSCAL( M, ALPHA, R( 1, 1 ), 1 ) + END IF +C +C Add the contribution of the subdiagonal of H to +C the j-th column of the product. +C + DO 50 I = J, M - 1 + R( I, J ) = R( I, J ) + BETA*( DWORK( I ) + + $ H( I+1, 1 )*B( I+1, J ) ) + 50 CONTINUE +C + R( M, J ) = R( M, J ) + BETA*DWORK( M ) + 60 CONTINUE +C + ELSE +C + DO 80 J = M, 1, -1 +C +C Multiply the upper triangle of the trailing +C (M-j+1)-by-(M-j+1) submatrix of H by the trailing +C part of the j-th column of B. +C + CALL DCOPY( M-J+1, B( J, J ), 1, DWORK( J ), 1 ) + CALL DTRMV( 'Upper', TRANS, 'Non-unit', M-J+1, + $ H( J, J ), LDH, DWORK( J ), 1 ) +C +C Add the contribution of the subdiagonal of H to +C the j-th column of the product. +C + DO 70 I = MAX( J, 2 ), M + R( I, J ) = ALPHA*R( I, J ) + BETA*( DWORK( I ) + $ + H( I, 1 )*B( I-1, J ) ) + 70 CONTINUE +C + 80 CONTINUE +C + R( 1, 1 ) = ALPHA*R( 1, 1 ) + BETA*DWORK( 1 ) +C + END IF + END IF +C + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) +C + ELSE +C +C Row-wise calculations are used for H, if SIDE = 'R' and +C TRANS = 'T'. +C + IF( LUPLO ) THEN + IF( LTRANS ) THEN + R( 1, 1 ) = ALPHA*R( 1, 1 ) + + $ BETA*DDOT( M, B, LDB, H, LDH ) +C + DO 90 J = 2, M + CALL DGEMV( 'NoTranspose', J, M-J+2, BETA, + $ B( 1, J-1 ), LDB, H( J, J-1 ), LDH, + $ ALPHA, R( 1, J ), 1 ) + 90 CONTINUE +C + ELSE +C + DO 100 J = 1, M - 1 + CALL DGEMV( 'NoTranspose', J, J+1, BETA, B, LDB, + $ H( 1, J ), 1, ALPHA, R( 1, J ), 1 ) + 100 CONTINUE +C + CALL DGEMV( 'NoTranspose', M, M, BETA, B, LDB, + $ H( 1, M ), 1, ALPHA, R( 1, M ), 1 ) +C + END IF +C + ELSE +C + IF( LTRANS ) THEN +C + CALL DGEMV( 'NoTranspose', M, M, BETA, B, LDB, H, LDH, + $ ALPHA, R( 1, 1 ), 1 ) +C + DO 110 J = 2, M + CALL DGEMV( 'NoTranspose', M-J+1, M-J+2, BETA, + $ B( J, J-1 ), LDB, H( J, J-1 ), LDH, ALPHA, + $ R( J, J ), 1 ) + 110 CONTINUE +C + ELSE +C + DO 120 J = 1, M - 1 + CALL DGEMV( 'NoTranspose', M-J+1, J+1, BETA, + $ B( J, 1 ), LDB, H( 1, J ), 1, ALPHA, + $ R( J, J ), 1 ) + 120 CONTINUE +C + R( M, M ) = ALPHA*R( M, M ) + + $ BETA*DDOT( M, B( M, 1 ), LDB, H( 1, M ), 1 ) +C + END IF + END IF + END IF +C + RETURN +C *** Last line of MB01RY *** + END diff --git a/mex/sources/libslicot/MB01SD.f b/mex/sources/libslicot/MB01SD.f new file mode 100644 index 000000000..b29437379 --- /dev/null +++ b/mex/sources/libslicot/MB01SD.f @@ -0,0 +1,123 @@ + SUBROUTINE MB01SD( JOBS, M, N, A, LDA, R, C ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To scale a general M-by-N matrix A using the row and column +C scaling factors in the vectors R and C. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBS CHARACTER*1 +C Specifies the scaling operation to be done, as follows: +C = 'R': row scaling, i.e., A will be premultiplied +C by diag(R); +C = 'C': column scaling, i.e., A will be postmultiplied +C by diag(C); +C = 'B': both row and column scaling, i.e., A will be +C replaced by diag(R) * A * diag(C). +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the M-by-N matrix A. +C On exit, the scaled matrix. See JOBS for the form of the +C scaled matrix. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C R (input) DOUBLE PRECISION array, dimension (M) +C The row scale factors for A. +C R is not referenced if JOBS = 'C'. +C +C C (input) DOUBLE PRECISION array, dimension (N) +C The column scale factors for A. +C C is not referenced if JOBS = 'R'. +C +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, April 1998. +C Based on the RASP routine DMSCAL. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER JOBS + INTEGER LDA, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), C(*), R(*) +C .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION CJ +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. Executable Statements .. +C +C Quick return if possible. +C + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +C + IF( LSAME( JOBS, 'C' ) ) THEN +C +C Column scaling, no row scaling. +C + DO 20 J = 1, N + CJ = C(J) + DO 10 I = 1, M + A(I,J) = CJ*A(I,J) + 10 CONTINUE + 20 CONTINUE + ELSE IF( LSAME( JOBS, 'R' ) ) THEN +C +C Row scaling, no column scaling. +C + DO 40 J = 1, N + DO 30 I = 1, M + A(I,J) = R(I)*A(I,J) + 30 CONTINUE + 40 CONTINUE + ELSE IF( LSAME( JOBS, 'B' ) ) THEN +C +C Row and column scaling. +C + DO 60 J = 1, N + CJ = C(J) + DO 50 I = 1, M + A(I,J) = CJ*R(I)*A(I,J) + 50 CONTINUE + 60 CONTINUE + END IF +C + RETURN +C *** Last line of MB01SD *** + END diff --git a/mex/sources/libslicot/MB01TD.f b/mex/sources/libslicot/MB01TD.f new file mode 100644 index 000000000..d4e06e626 --- /dev/null +++ b/mex/sources/libslicot/MB01TD.f @@ -0,0 +1,173 @@ + SUBROUTINE MB01TD( N, A, LDA, B, LDB, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix product A * B, where A and B are upper +C quasi-triangular matrices (that is, block upper triangular with +C 1-by-1 or 2-by-2 diagonal blocks) with the same structure. +C The result is returned in the array B. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and B. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C upper quasi-triangular matrix A. The elements below the +C subdiagonal are not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain the upper quasi-triangular matrix B, with the same +C structure as matrix A. +C On exit, the leading N-by-N part of this array contains +C the computed product A * B, with the same structure as +C on entry. +C The elements below the subdiagonal are not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N-1) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrices A and B have not the same structure, +C and/or A and B are not upper quasi-triangular. +C +C METHOD +C +C The matrix product A * B is computed column by column, using +C BLAS 2 and BLAS 1 operations. +C +C FURTHER COMMENTS +C +C This routine can be used, for instance, for computing powers of +C a real Schur form matrix. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C +C REVISIONS +C +C V. Sima, Feb. 2000. +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*) +C .. Local Scalars .. + INTEGER I, J, JMIN, JMNM +C .. External Subroutines .. + EXTERNAL DAXPY, DTRMV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -3 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01TD', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF ( N.EQ.0 ) THEN + RETURN + ELSE IF ( N.EQ.1 ) THEN + B(1,1) = A(1,1)*B(1,1) + RETURN + END IF +C +C Test the upper quasi-triangular structure of A and B for identity. +C + DO 10 I = 1, N - 1 + IF ( A(I+1,I).EQ.ZERO ) THEN + IF ( B(I+1,I).NE.ZERO ) THEN + INFO = 1 + RETURN + END IF + ELSE IF ( I.LT.N-1 ) THEN + IF ( A(I+2,I+1).NE.ZERO ) THEN + INFO = 1 + RETURN + END IF + END IF + 10 CONTINUE +C + DO 30 J = 1, N + JMIN = MIN( J+1, N ) + JMNM = MIN( JMIN, N-1 ) +C +C Compute the contribution of the subdiagonal of A to the +C j-th column of the product. +C + DO 20 I = 1, JMNM + DWORK(I) = A(I+1,I)*B(I,J) + 20 CONTINUE +C +C Multiply the upper triangle of A by the j-th column of B, +C and add to the above result. +C + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', JMIN, A, LDA, + $ B(1,J), 1 ) + CALL DAXPY( JMNM, ONE, DWORK, 1, B(2,J), 1 ) + 30 CONTINUE +C + RETURN +C *** Last line of MB01TD *** + END diff --git a/mex/sources/libslicot/MB01UD.f b/mex/sources/libslicot/MB01UD.f new file mode 100644 index 000000000..0bdacadf5 --- /dev/null +++ b/mex/sources/libslicot/MB01UD.f @@ -0,0 +1,238 @@ + SUBROUTINE MB01UD( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA, B, + $ LDB, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute one of the matrix products +C +C B = alpha*op( H ) * A, or B = alpha*A * op( H ), +C +C where alpha is a scalar, A and B are m-by-n matrices, H is an +C upper Hessenberg matrix, and op( H ) is one of +C +C op( H ) = H or op( H ) = H', the transpose of H. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies whether the Hessenberg matrix H appears on the +C left or right in the matrix product as follows: +C = 'L': B = alpha*op( H ) * A; +C = 'R': B = alpha*A * op( H ). +C +C TRANS CHARACTER*1 +C Specifies the form of op( H ) to be used in the matrix +C multiplication as follows: +C = 'N': op( H ) = H; +C = 'T': op( H ) = H'; +C = 'C': op( H ) = H'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices A and B. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrices A and B. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then H is not +C referenced and A need not be set before entry. +C +C H (input) DOUBLE PRECISION array, dimension (LDH,k) +C where k is M when SIDE = 'L' and is N when SIDE = 'R'. +C On entry with SIDE = 'L', the leading M-by-M upper +C Hessenberg part of this array must contain the upper +C Hessenberg matrix H. +C On entry with SIDE = 'R', the leading N-by-N upper +C Hessenberg part of this array must contain the upper +C Hessenberg matrix H. +C The elements below the subdiagonal are not referenced, +C except possibly for those in the first column, which +C could be overwritten, but are restored on exit. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,k), +C where k is M when SIDE = 'L' and is N when SIDE = 'R'. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading M-by-N part of this array must contain the +C matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,N) +C The leading M-by-N part of this array contains the +C computed product. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The required matrix product is computed in two steps. In the first +C step, the upper triangle of H is used; in the second step, the +C contribution of the subdiagonal is added. A fast BLAS 3 DTRMM +C operation is used in the first step. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, January 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, LDB, LDH, M, N + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), H(LDH,*) +C .. Local Scalars .. + LOGICAL LSIDE, LTRANS + INTEGER I, J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DLACPY, DLASET, DSWAP, DTRMM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LSIDE = LSAME( SIDE, 'L' ) + LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN + INFO = -1 + ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDH.LT.1 .OR. ( LSIDE .AND. LDH.LT.M ) .OR. + $ ( .NOT.LSIDE .AND. LDH.LT.N ) ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01UD', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF ( MIN( M, N ).EQ.0 ) + $ RETURN +C + IF( ALPHA.EQ.ZERO ) THEN +C +C Set B to zero and return. +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, B, LDB ) + RETURN + END IF +C +C Copy A in B and compute one of the matrix products +C B = alpha*op( triu( H ) ) * A, or +C B = alpha*A * op( triu( H ) ), +C involving the upper triangle of H. +C + CALL DLACPY( 'Full', M, N, A, LDA, B, LDB ) + CALL DTRMM( SIDE, 'Upper', TRANS, 'Non-unit', M, N, ALPHA, H, + $ LDH, B, LDB ) +C +C Add the contribution of the subdiagonal of H. +C If SIDE = 'L', the subdiagonal of H is swapped with the +C corresponding elements in the first column of H, and the +C calculations are organized for column operations. +C + IF( LSIDE ) THEN + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) + IF( LTRANS ) THEN + DO 20 J = 1, N + DO 10 I = 1, M - 1 + B( I, J ) = B( I, J ) + ALPHA*H( I+1, 1 )*A( I+1, J ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = 2, M + B( I, J ) = B( I, J ) + ALPHA*H( I, 1 )*A( I-1, J ) + 30 CONTINUE + 40 CONTINUE + END IF + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) +C + ELSE +C + IF( LTRANS ) THEN + DO 50 J = 1, N - 1 + IF ( H( J+1, J ).NE.ZERO ) + $ CALL DAXPY( M, ALPHA*H( J+1, J ), A( 1, J ), 1, + $ B( 1, J+1 ), 1 ) + 50 CONTINUE + ELSE + DO 60 J = 1, N - 1 + IF ( H( J+1, J ).NE.ZERO ) + $ CALL DAXPY( M, ALPHA*H( J+1, J ), A( 1, J+1 ), 1, + $ B( 1, J ), 1 ) + 60 CONTINUE + END IF + END IF +C + RETURN +C *** Last line of MB01UD *** + END diff --git a/mex/sources/libslicot/MB01UW.f b/mex/sources/libslicot/MB01UW.f new file mode 100644 index 000000000..ff8489636 --- /dev/null +++ b/mex/sources/libslicot/MB01UW.f @@ -0,0 +1,377 @@ + SUBROUTINE MB01UW( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute one of the matrix products +C +C A : = alpha*op( H ) * A, or A : = alpha*A * op( H ), +C +C where alpha is a scalar, A is an m-by-n matrix, H is an upper +C Hessenberg matrix, and op( H ) is one of +C +C op( H ) = H or op( H ) = H', the transpose of H. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies whether the Hessenberg matrix H appears on the +C left or right in the matrix product as follows: +C = 'L': A := alpha*op( H ) * A; +C = 'R': A := alpha*A * op( H ). +C +C TRANS CHARACTER*1 +C Specifies the form of op( H ) to be used in the matrix +C multiplication as follows: +C = 'N': op( H ) = H; +C = 'T': op( H ) = H'; +C = 'C': op( H ) = H'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then H is not +C referenced and A need not be set before entry. +C +C H (input) DOUBLE PRECISION array, dimension (LDH,k) +C where k is M when SIDE = 'L' and is N when SIDE = 'R'. +C On entry with SIDE = 'L', the leading M-by-M upper +C Hessenberg part of this array must contain the upper +C Hessenberg matrix H. +C On entry with SIDE = 'R', the leading N-by-N upper +C Hessenberg part of this array must contain the upper +C Hessenberg matrix H. +C The elements below the subdiagonal are not referenced, +C except possibly for those in the first column, which +C could be overwritten, but are restored on exit. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,k), +C where k is M when SIDE = 'L' and is N when SIDE = 'R'. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix A. +C On exit, the leading M-by-N part of this array contains +C the computed product. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, alpha <> 0, and LDWORK >= M*N > 0, +C DWORK contains a copy of the matrix A, having the leading +C dimension M. +C This array is not referenced when alpha = 0. +C +C LDWORK The length of the array DWORK. +C LDWORK >= 0, if alpha = 0 or MIN(M,N) = 0; +C LDWORK >= M-1, if SIDE = 'L'; +C LDWORK >= N-1, if SIDE = 'R'. +C For maximal efficiency LDWORK should be at least M*N. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The required matrix product is computed in two steps. In the first +C step, the upper triangle of H is used; in the second step, the +C contribution of the subdiagonal is added. If the workspace can +C accomodate a copy of A, a fast BLAS 3 DTRMM operation is used in +C the first step. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, January 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, LDH, LDWORK, M, N + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), H(LDH,*) +C .. Local Scalars .. + LOGICAL LSIDE, LTRANS + INTEGER I, J, JW +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DLACPY, DLASCL, DLASET, DSCAL, DSWAP, + $ DTRMM, DTRMV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LSIDE = LSAME( SIDE, 'L' ) + LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN + INFO = -1 + ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDH.LT.1 .OR. ( LSIDE .AND. LDH.LT.M ) .OR. + $ ( .NOT.LSIDE .AND. LDH.LT.N ) ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( LDWORK.LT.0 .OR. + $ ( ALPHA.NE.ZERO .AND. MIN( M, N ).GT.0 .AND. + $ ( ( LSIDE .AND. LDWORK.LT.M-1 ) .OR. + $ ( .NOT.LSIDE .AND. LDWORK.LT.N-1 ) ) ) ) THEN + INFO = -11 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01UW', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF ( MIN( M, N ).EQ.0 ) THEN + RETURN + ELSE IF ( LSIDE ) THEN + IF ( M.EQ.1 ) THEN + CALL DSCAL( N, ALPHA*H(1,1), A, LDA ) + RETURN + END IF + ELSE + IF ( N.EQ.1 ) THEN + CALL DSCAL( M, ALPHA*H(1,1), A, 1 ) + RETURN + END IF + END IF +C + IF( ALPHA.EQ.ZERO ) THEN +C +C Set A to zero and return. +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) + RETURN + END IF +C + IF( LDWORK.GE.M*N ) THEN +C +C Enough workspace for a fast BLAS 3 calculation. +C Save A in the workspace and compute one of the matrix products +C A : = alpha*op( triu( H ) ) * A, or +C A : = alpha*A * op( triu( H ) ), +C involving the upper triangle of H. +C + CALL DLACPY( 'Full', M, N, A, LDA, DWORK, M ) + CALL DTRMM( SIDE, 'Upper', TRANS, 'Non-unit', M, N, ALPHA, H, + $ LDH, A, LDA ) +C +C Add the contribution of the subdiagonal of H. +C If SIDE = 'L', the subdiagonal of H is swapped with the +C corresponding elements in the first column of H, and the +C calculations are organized for column operations. +C + IF( LSIDE ) THEN + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) + IF( LTRANS ) THEN + JW = 1 + DO 20 J = 1, N + JW = JW + 1 + DO 10 I = 1, M - 1 + A( I, J ) = A( I, J ) + + $ ALPHA*H( I+1, 1 )*DWORK( JW ) + JW = JW + 1 + 10 CONTINUE + 20 CONTINUE + ELSE + JW = 0 + DO 40 J = 1, N + JW = JW + 1 + DO 30 I = 2, M + A( I, J ) = A( I, J ) + + $ ALPHA*H( I, 1 )*DWORK( JW ) + JW = JW + 1 + 30 CONTINUE + 40 CONTINUE + END IF + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) +C + ELSE +C + IF( LTRANS ) THEN + JW = 1 + DO 50 J = 1, N - 1 + IF ( H( J+1, J ).NE.ZERO ) + $ CALL DAXPY( M, ALPHA*H( J+1, J ), DWORK( JW ), 1, + $ A( 1, J+1 ), 1 ) + JW = JW + M + 50 CONTINUE + ELSE + JW = M + 1 + DO 60 J = 1, N - 1 + IF ( H( J+1, J ).NE.ZERO ) + $ CALL DAXPY( M, ALPHA*H( J+1, J ), DWORK( JW ), 1, + $ A( 1, J ), 1 ) + JW = JW + M + 60 CONTINUE + END IF + END IF +C + ELSE +C +C Use a BLAS 2 calculation. +C + IF( LSIDE ) THEN + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) + IF( LTRANS ) THEN + DO 80 J = 1, N +C +C Compute the contribution of the subdiagonal of H to +C the j-th column of the product. +C + DO 70 I = 1, M - 1 + DWORK( I ) = H( I+1, 1 )*A( I+1, J ) + 70 CONTINUE +C +C Multiply the upper triangle of H by the j-th column +C of A, and add to the above result. +C + CALL DTRMV( 'Upper', TRANS, 'Non-unit', M, H, LDH, + $ A( 1, J ), 1 ) + CALL DAXPY( M-1, ONE, DWORK, 1, A( 1, J ), 1 ) + 80 CONTINUE +C + ELSE + DO 100 J = 1, N +C +C Compute the contribution of the subdiagonal of H to +C the j-th column of the product. +C + DO 90 I = 1, M - 1 + DWORK( I ) = H( I+1, 1 )*A( I, J ) + 90 CONTINUE +C +C Multiply the upper triangle of H by the j-th column +C of A, and add to the above result. +C + CALL DTRMV( 'Upper', TRANS, 'Non-unit', M, H, LDH, + $ A( 1, J ), 1 ) + CALL DAXPY( M-1, ONE, DWORK, 1, A( 2, J ), 1 ) + 100 CONTINUE + END IF + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) +C + ELSE +C +C Below, row-wise calculations are used for A. +C + IF( N.GT.2 ) + $ CALL DSWAP( N-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) + IF( LTRANS ) THEN + DO 120 I = 1, M +C +C Compute the contribution of the subdiagonal of H to +C the i-th row of the product. +C + DO 110 J = 1, N - 1 + DWORK( J ) = A( I, J )*H( J+1, 1 ) + 110 CONTINUE +C +C Multiply the i-th row of A by the upper triangle of H, +C and add to the above result. +C + CALL DTRMV( 'Upper', 'NoTranspose', 'Non-unit', N, H, + $ LDH, A( I, 1 ), LDA ) + CALL DAXPY( N-1, ONE, DWORK, 1, A( I, 2 ), LDA ) + 120 CONTINUE +C + ELSE + DO 140 I = 1, M +C +C Compute the contribution of the subdiagonal of H to +C the i-th row of the product. +C + DO 130 J = 1, N - 1 + DWORK( J ) = A( I, J+1 )*H( J+1, 1 ) + 130 CONTINUE +C +C Multiply the i-th row of A by the upper triangle of H, +C and add to the above result. +C + CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', N, H, + $ LDH, A( I, 1 ), LDA ) + CALL DAXPY( N-1, ONE, DWORK, 1, A( I, 1 ), LDA ) + 140 CONTINUE + END IF + IF( N.GT.2 ) + $ CALL DSWAP( N-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) +C + END IF +C +C Scale the result by alpha. +C + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( 'General', 0, 0, ONE, ALPHA, M, N, A, LDA, + $ INFO ) + END IF + RETURN +C *** Last line of MB01UW *** + END diff --git a/mex/sources/libslicot/MB01UX.f b/mex/sources/libslicot/MB01UX.f new file mode 100644 index 000000000..166c23c44 --- /dev/null +++ b/mex/sources/libslicot/MB01UX.f @@ -0,0 +1,373 @@ + SUBROUTINE MB01UX( SIDE, UPLO, TRANS, M, N, ALPHA, T, LDT, A, LDA, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute one of the matrix products +C +C A : = alpha*op( T ) * A, or A : = alpha*A * op( T ), +C +C where alpha is a scalar, A is an m-by-n matrix, T is a quasi- +C triangular matrix, and op( T ) is one of +C +C op( T ) = T or op( T ) = T', the transpose of T. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies whether the upper quasi-triangular matrix H +C appears on the left or right in the matrix product as +C follows: +C = 'L': A := alpha*op( T ) * A; +C = 'R': A := alpha*A * op( T ). +C +C UPLO CHARACTER*1. +C Specifies whether the matrix T is an upper or lower +C quasi-triangular matrix as follows: +C = 'U': T is an upper quasi-triangular matrix; +C = 'L': T is a lower quasi-triangular matrix. +C +C TRANS CHARACTER*1 +C Specifies the form of op( T ) to be used in the matrix +C multiplication as follows: +C = 'N': op( T ) = T; +C = 'T': op( T ) = T'; +C = 'C': op( T ) = T'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then T is not +C referenced and A need not be set before entry. +C +C T (input) DOUBLE PRECISION array, dimension (LDT,k) +C where k is M when SIDE = 'L' and is N when SIDE = 'R'. +C On entry with UPLO = 'U', the leading k-by-k upper +C Hessenberg part of this array must contain the upper +C quasi-triangular matrix T. The elements below the +C subdiagonal are not referenced. +C On entry with UPLO = 'L', the leading k-by-k lower +C Hessenberg part of this array must contain the lower +C quasi-triangular matrix T. The elements above the +C supdiagonal are not referenced. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= max(1,k), +C where k is M when SIDE = 'L' and is N when SIDE = 'R'. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix A. +C On exit, the leading M-by-N part of this array contains +C the computed product. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 and ALPHA<>0, DWORK(1) returns the +C optimal value of LDWORK. +C On exit, if INFO = -12, DWORK(1) returns the minimum +C value of LDWORK. +C This array is not referenced when alpha = 0. +C +C LDWORK The length of the array DWORK. +C LDWORK >= 1, if alpha = 0 or MIN(M,N) = 0; +C LDWORK >= 2*(M-1), if SIDE = 'L'; +C LDWORK >= 2*(N-1), if SIDE = 'R'. +C For maximal efficiency LDWORK should be at least +C NOFF*N + M - 1, if SIDE = 'L'; +C NOFF*M + N - 1, if SIDE = 'R'; +C where NOFF is the number of nonzero elements on the +C subdiagonal (if UPLO = 'U') or supdiagonal (if UPLO = 'L') +C of T. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The technique used in this routine is similiar to the technique +C used in the SLICOT [1] subroutine MB01UW developed by Vasile Sima. +C The required matrix product is computed in two steps. In the first +C step, the triangle of T specified by UPLO is used; in the second +C step, the contribution of the sub-/supdiagonal is added. If the +C workspace can accommodate parts of A, a fast BLAS 3 DTRMM +C operation is used in the first step. +C +C REFERENCES +C +C [1] Benner, P., Mehrmann, V., Sima, V., Van Huffel, S., and +C Varga, A. +C SLICOT - A subroutine library in systems and control theory. +C In: Applied and computational control, signals, and circuits, +C Vol. 1, pp. 499-539, Birkhauser, Boston, 1999. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, May 2008 (SLICOT version of the HAPACK routine DTRQML). +C +C KEYWORDS +C +C Elementary matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER SIDE, TRANS, UPLO + INTEGER INFO, LDA, LDT, LDWORK, M, N + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), T(LDT,*) +C .. Local Scalars .. + LOGICAL LSIDE, LTRAN, LUP + CHARACTER ATRAN + INTEGER I, IERR, J, K, NOFF, PDW, PSAV, WRKMIN, WRKOPT, + $ XDIF + DOUBLE PRECISION TEMP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DLASCL, DLASET, DTRMM, DTRMV, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Decode and test the input scalar arguments. +C + INFO = 0 + LSIDE = LSAME( SIDE, 'L' ) + LUP = LSAME( UPLO, 'U' ) + LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) + IF ( LSIDE ) THEN + K = M + ELSE + K = N + END IF + WRKMIN = 2*( K - 1 ) +C + IF ( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) ) THEN + INFO = -1 + ELSE IF ( ( .NOT.LUP ).AND.( .NOT.LSAME( UPLO, 'L' ) ) ) THEN + INFO = -2 + ELSE IF ( ( .NOT.LTRAN ).AND.( .NOT.LSAME( TRANS, 'N' ) ) ) THEN + INFO = -3 + ELSE IF ( M.LT.0 ) THEN + INFO = -4 + ELSE IF ( N.LT.0 ) THEN + INFO = -5 + ELSE IF ( LDT.LT.MAX( 1, K ) ) THEN + INFO = -8 + ELSE IF ( LDA.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF ( LDWORK.LT.0 .OR. + $ ( ALPHA.NE.ZERO .AND. MIN( M, N ).GT.0 .AND. + $ LDWORK.LT.WRKMIN ) ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01UX', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF ( MIN( M, N ).EQ.0 ) + $ RETURN +C + IF ( ALPHA.EQ.ZERO ) THEN +C +C Set A to zero and return. +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) + RETURN + END IF +C +C Save and count off-diagonal entries of T. +C + IF ( LUP ) THEN + CALL DCOPY( K-1, T(2,1), LDT+1, DWORK, 1 ) + ELSE + CALL DCOPY( K-1, T(1,2), LDT+1, DWORK, 1 ) + END IF + NOFF = 0 + DO 5 I = 1, K-1 + IF ( DWORK(I).NE.ZERO ) + $ NOFF = NOFF + 1 + 5 CONTINUE +C +C Compute optimal workspace. +C + IF ( LSIDE ) THEN + WRKOPT = NOFF*N + M - 1 + ELSE + WRKOPT = NOFF*M + N - 1 + END IF + PSAV = K + IF ( .NOT.LTRAN ) THEN + XDIF = 0 + ELSE + XDIF = 1 + END IF + IF ( .NOT.LUP ) + $ XDIF = 1 - XDIF + IF ( .NOT.LSIDE ) + $ XDIF = 1 - XDIF +C + IF ( LDWORK.GE.WRKOPT ) THEN +C +C Enough workspace for a fast BLAS 3 calculation. +C Save relevant parts of A in the workspace and compute one of +C the matrix products +C A : = alpha*op( triu( T ) ) * A, or +C A : = alpha*A * op( triu( T ) ), +C involving the upper/lower triangle of T. +C + PDW = PSAV + IF ( LSIDE ) THEN + DO 20 J = 1, N + DO 10 I = 1, M-1 + IF ( DWORK(I).NE.ZERO ) THEN + DWORK(PDW) = A(I+XDIF,J) + PDW = PDW + 1 + END IF + 10 CONTINUE + 20 CONTINUE + ELSE + DO 30 J = 1, N-1 + IF ( DWORK(J).NE.ZERO ) THEN + CALL DCOPY( M, A(1,J+XDIF), 1, DWORK(PDW), 1 ) + PDW = PDW + M + END IF + 30 CONTINUE + END IF + CALL DTRMM( SIDE, UPLO, TRANS, 'Non-unit', M, N, ALPHA, T, + $ LDT, A, LDA ) +C +C Add the contribution of the offdiagonal of T. +C + PDW = PSAV + XDIF = 1 - XDIF + IF( LSIDE ) THEN + DO 50 J = 1, N + DO 40 I = 1, M-1 + TEMP = DWORK(I) + IF ( TEMP.NE.ZERO ) THEN + A(I+XDIF,J) = A(I+XDIF,J) + ALPHA * TEMP * + $ DWORK(PDW) + PDW = PDW + 1 + END IF + 40 CONTINUE + 50 CONTINUE + ELSE + DO 60 J = 1, N-1 + TEMP = DWORK(J)*ALPHA + IF ( TEMP.NE.ZERO ) THEN + CALL DAXPY( M, TEMP, DWORK(PDW), 1, A(1,J+XDIF), 1 ) + PDW = PDW + M + END IF + 60 CONTINUE + END IF + ELSE +C +C Use a BLAS 2 calculation. +C + IF ( LSIDE ) THEN + DO 80 J = 1, N +C +C Compute the contribution of the offdiagonal of T to +C the j-th column of the product. +C + DO 70 I = 1, M - 1 + DWORK(PSAV+I-1) = DWORK(I)*A(I+XDIF,J) + 70 CONTINUE +C +C Multiply the triangle of T by the j-th column of A, +C and add to the above result. +C + CALL DTRMV( UPLO, TRANS, 'Non-unit', M, T, LDT, A(1,J), + $ 1 ) + CALL DAXPY( M-1, ONE, DWORK(PSAV), 1, A(2-XDIF,J), 1 ) + 80 CONTINUE + ELSE + IF ( LTRAN ) THEN + ATRAN = 'N' + ELSE + ATRAN = 'T' + END IF + DO 100 I = 1, M +C +C Compute the contribution of the offdiagonal of T to +C the i-th row of the product. +C + DO 90 J = 1, N - 1 + DWORK(PSAV+J-1) = A(I,J+XDIF)*DWORK(J) + 90 CONTINUE +C +C Multiply the i-th row of A by the triangle of T, +C and add to the above result. +C + CALL DTRMV( UPLO, ATRAN, 'Non-unit', N, T, LDT, A(I,1), + $ LDA ) + CALL DAXPY( N-1, ONE, DWORK(PSAV), 1, A(I,2-XDIF), LDA ) + 100 CONTINUE + END IF +C +C Scale the result by alpha. +C + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( 'General', 0, 0, ONE, ALPHA, M, N, A, LDA, + $ IERR ) + END IF + DWORK(1) = DBLE( MAX( WRKMIN, WRKOPT ) ) + RETURN +C *** Last line of MB01UX *** + END diff --git a/mex/sources/libslicot/MB01VD.f b/mex/sources/libslicot/MB01VD.f new file mode 100644 index 000000000..bcd924d68 --- /dev/null +++ b/mex/sources/libslicot/MB01VD.f @@ -0,0 +1,1693 @@ + SUBROUTINE MB01VD( TRANA, TRANB, MA, NA, MB, NB, ALPHA, BETA, + $ A, LDA, B, LDB, C, LDC, MC, NC, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the following matrix operation +C +C C = alpha*kron( op(A), op(B) ) + beta*C, +C +C where alpha and beta are real scalars, op(M) is either matrix M or +C its transpose, M', and kron( X, Y ) denotes the Kronecker product +C of the matrices X and Y. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used as follows: +C = 'N': op(A) = A; +C = 'T': op(A) = A'; +C = 'C': op(A) = A'. +C +C TRANB CHARACTER*1 +C Specifies the form of op(B) to be used as follows: +C = 'N': op(B) = B; +C = 'T': op(B) = B'; +C = 'C': op(B) = B'. +C +C Input/Output Parameters +C +C MA (input) INTEGER +C The number of rows of the matrix op(A). MA >= 0. +C +C NA (input) INTEGER +C The number of columns of the matrix op(A). NA >= 0. +C +C MB (input) INTEGER +C The number of rows of the matrix op(B). MB >= 0. +C +C NB (input) INTEGER +C The number of columns of the matrix op(B). NB >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then A and B need not +C be set before entry. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then C need not be +C set before entry. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,ka), +C where ka is NA when TRANA = 'N', and is MA otherwise. +C If TRANA = 'N', the leading MA-by-NA part of this array +C must contain the matrix A; otherwise, the leading NA-by-MA +C part of this array must contain the matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= max(1,MA), if TRANA = 'N'; +C LDA >= max(1,NA), if TRANA = 'T' or 'C'. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,kb) +C where kb is NB when TRANB = 'N', and is MB otherwise. +C If TRANB = 'N', the leading MB-by-NB part of this array +C must contain the matrix B; otherwise, the leading NB-by-MB +C part of this array must contain the matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= max(1,MB), if TRANB = 'N'; +C LDB >= max(1,NB), if TRANB = 'T' or 'C'. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,NC) +C On entry, if beta is nonzero, the leading MC-by-NC part of +C this array must contain the given matric C, where +C MC = MA*MB and NC = NA*NB. +C On exit, the leading MC-by-NC part of this array contains +C the computed matrix expression +C C = alpha*kron( op(A), op(B) ) + beta*C. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= max(1,MC). +C +C MC (output) INTEGER +C The number of rows of the matrix C. MC = MA*MB. +C +C NC (output) INTEGER +C The number of columns of the matrix C. NC = NA*NB. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The Kronecker product of the matrices op(A) and op(B) is computed +C column by column. +C +C FURTHER COMMENTS +C +C The multiplications by zero elements in A are avoided, if the +C matrix A is considered to be sparse, i.e., if +C (number of zeros in A)/(MA*NA) >= SPARST = 0.8. The code makes +C NB+1 passes through the matrix A, and MA*NA passes through the +C matrix B. If LDA and/or LDB are very large, and op(A) = A' and/or +C op(B) = B', it could be more efficient to transpose A and/or B +C before calling this routine, and use the 'N' values for TRANA +C and/or TRANB. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, February 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + DOUBLE PRECISION SPARST + PARAMETER ( SPARST = 0.8D0 ) +C .. Scalar Arguments .. + CHARACTER TRANA, TRANB + INTEGER INFO, LDA, LDB, LDC, MA, MB, MC, NA, NB, NC + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*) +C .. Local Scalars .. + LOGICAL SPARSE, TRANSA, TRANSB + INTEGER I, IC, J, JC, K, L, LC, NZ + DOUBLE PRECISION AIJ +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLASET, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + TRANSA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) + TRANSB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) + MC = MA*MB + INFO = 0 + IF( .NOT.( TRANSA .OR. LSAME( TRANA, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( TRANSB .OR. LSAME( TRANB, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( MA.LT.0 ) THEN + INFO = -3 + ELSE IF( NA.LT.0 ) THEN + INFO = -4 + ELSE IF( MB.LT.0 ) THEN + INFO = -5 + ELSE IF( NB.LT.0 ) THEN + INFO = -6 + ELSE IF( ( TRANSA .AND. LDA.LT.NA ) .OR. LDA.LT.1 .OR. + $ ( .NOT.TRANSA .AND. LDA.LT.MA ) ) THEN + INFO = -10 + ELSE IF( ( TRANSB .AND. LDB.LT.NB ) .OR. LDB.LT.1 .OR. + $ ( .NOT.TRANSB .AND. LDB.LT.MB ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, MC ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01VD', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + NC = NA*NB + IF ( MC.EQ.0 .OR. NC.EQ.0 ) + $ RETURN +C + IF ( ALPHA.EQ.ZERO ) THEN + IF ( BETA.EQ.ZERO ) THEN + CALL DLASET( 'Full', MC, NC, ZERO, ZERO, C, LDC ) + ELSE IF ( BETA.NE.ONE ) THEN +C + DO 10 J = 1, NC + CALL DSCAL( MC, BETA, C(1,J), 1 ) + 10 CONTINUE +C + END IF + RETURN + END IF +C + DUM(1) = ZERO + JC = 1 + NZ = 0 +C +C Compute the Kronecker product of the matrices op(A) and op(B), +C C = alpha*kron( op(A), op(B) ) + beta*C. +C First, check if A is sparse. Here, A is considered as being sparse +C if (number of zeros in A)/(MA*NA) >= SPARST. +C + DO 30 J = 1, NA +C + DO 20 I = 1, MA + IF ( TRANSA ) THEN + IF ( A(J,I).EQ.ZERO ) + $ NZ = NZ + 1 + ELSE + IF ( A(I,J).EQ.ZERO ) + $ NZ = NZ + 1 + END IF + 20 CONTINUE +C + 30 CONTINUE +C + SPARSE = DBLE( NZ )/DBLE( MA*NA ).GE.SPARST +C + IF ( .NOT.TRANSA .AND. .NOT.TRANSB ) THEN +C +C Case op(A) = A and op(B) = B. +C + IF ( BETA.EQ.ZERO ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha = 1, A sparse. +C + DO 80 J = 1, NA +C + DO 70 K = 1, NB + IC = 1 +C + DO 60 I = 1, MA + AIJ = A(I,J) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE IF ( AIJ.EQ.ONE ) THEN + CALL DCOPY( MB, B(1,K), 1, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 50 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 50 CONTINUE +C + END IF + IC = IC + MB + 60 CONTINUE +C + JC = JC + 1 + 70 CONTINUE +C + 80 CONTINUE +C + ELSE +C +C Case beta = 0, alpha = 1, A not sparse. +C + DO 120 J = 1, NA +C + DO 110 K = 1, NB + IC = 1 +C + DO 100 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 90 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 90 CONTINUE +C + IC = IC + MB + 100 CONTINUE +C + JC = JC + 1 + 110 CONTINUE +C + 120 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha <> 1, A sparse. +C + DO 160 J = 1, NA +C + DO 150 K = 1, NB + IC = 1 +C + DO 140 I = 1, MA + AIJ = ALPHA*A(I,J) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 130 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 130 CONTINUE +C + END IF + IC = IC + MB + 140 CONTINUE +C + JC = JC + 1 + 150 CONTINUE +C + 160 CONTINUE +C + ELSE +C +C Case beta = 0, alpha <> 1, A not sparse. +C + DO 200 J = 1, NA +C + DO 190 K = 1, NB + IC = 1 +C + DO 180 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 170 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 170 CONTINUE +C + IC = IC + MB + 180 CONTINUE +C + JC = JC + 1 + 190 CONTINUE +C + 200 CONTINUE +C + END IF + END IF + ELSE IF ( BETA.EQ.ONE ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha = 1, A sparse. +C + DO 240 J = 1, NA +C + DO 230 K = 1, NB + IC = 1 +C + DO 220 I = 1, MA + AIJ = A(I,J) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 210 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 210 CONTINUE +C + END IF + IC = IC + MB + 220 CONTINUE +C + JC = JC + 1 + 230 CONTINUE +C + 240 CONTINUE +C + ELSE +C +C Case beta = 1, alpha = 1, A not sparse. +C + DO 280 J = 1, NA +C + DO 270 K = 1, NB + IC = 1 +C + DO 260 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 250 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 250 CONTINUE +C + IC = IC + MB + 260 CONTINUE +C + JC = JC + 1 + 270 CONTINUE +C + 280 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha <> 1, A sparse. +C + DO 320 J = 1, NA +C + DO 310 K = 1, NB + IC = 1 +C + DO 300 I = 1, MA + AIJ = ALPHA*A(I,J) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 290 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 290 CONTINUE +C + END IF + IC = IC + MB + 300 CONTINUE +C + JC = JC + 1 + 310 CONTINUE +C + 320 CONTINUE +C + ELSE +C +C Case beta = 1, alpha <> 1, A not sparse. +C + DO 360 J = 1, NA +C + DO 350 K = 1, NB + IC = 1 +C + DO 340 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 330 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 330 CONTINUE +C + IC = IC + MB + 340 CONTINUE +C + JC = JC + 1 + 350 CONTINUE +C + 360 CONTINUE +C + END IF + END IF + ELSE + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha = 1, A sparse. +C + DO 400 J = 1, NA +C + DO 390 K = 1, NB + IC = 1 +C + DO 380 I = 1, MA + AIJ = A(I,J) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 370 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 370 CONTINUE +C + END IF + IC = IC + MB + 380 CONTINUE +C + JC = JC + 1 + 390 CONTINUE +C + 400 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha = 1, A not sparse. +C + DO 440 J = 1, NA +C + DO 430 K = 1, NB + IC = 1 +C + DO 420 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 410 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 410 CONTINUE +C + IC = IC + MB + 420 CONTINUE +C + JC = JC + 1 + 430 CONTINUE +C + 440 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha <> 1, A sparse. +C + DO 480 J = 1, NA +C + DO 470 K = 1, NB + IC = 1 +C + DO 460 I = 1, MA + AIJ = ALPHA*A(I,J) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 450 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 450 CONTINUE +C + END IF + IC = IC + MB + 460 CONTINUE +C + JC = JC + 1 + 470 CONTINUE +C + 480 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha <> 1, A not sparse. +C + DO 520 J = 1, NA +C + DO 510 K = 1, NB + IC = 1 +C + DO 500 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 490 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 490 CONTINUE +C + IC = IC + MB + 500 CONTINUE +C + JC = JC + 1 + 510 CONTINUE +C + 520 CONTINUE +C + END IF + END IF + END IF + ELSE IF ( TRANSA .AND. .NOT.TRANSB ) THEN +C +C Case op(A) = A' and op(B) = B. +C + IF ( BETA.EQ.ZERO ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha = 1, A sparse. +C + DO 560 J = 1, NA +C + DO 550 K = 1, NB + IC = 1 +C + DO 540 I = 1, MA + AIJ = A(J,I) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE IF ( AIJ.EQ.ONE ) THEN + CALL DCOPY( MB, B(1,K), 1, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 530 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 530 CONTINUE +C + END IF + IC = IC + MB + 540 CONTINUE +C + JC = JC + 1 + 550 CONTINUE +C + 560 CONTINUE +C + ELSE +C +C Case beta = 0, alpha = 1, A not sparse. +C + DO 600 J = 1, NA +C + DO 590 K = 1, NB + IC = 1 +C + DO 580 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 570 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 570 CONTINUE +C + IC = IC + MB + 580 CONTINUE +C + JC = JC + 1 + 590 CONTINUE +C + 600 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha <> 1, A sparse. +C + DO 640 J = 1, NA +C + DO 630 K = 1, NB + IC = 1 +C + DO 620 I = 1, MA + AIJ = ALPHA*A(J,I) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 610 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 610 CONTINUE +C + END IF + IC = IC + MB + 620 CONTINUE +C + JC = JC + 1 + 630 CONTINUE +C + 640 CONTINUE +C + ELSE +C +C Case beta = 0, alpha <> 1, A not sparse. +C + DO 680 J = 1, NA +C + DO 670 K = 1, NB + IC = 1 +C + DO 660 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 650 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 650 CONTINUE +C + IC = IC + MB + 660 CONTINUE +C + JC = JC + 1 + 670 CONTINUE +C + 680 CONTINUE +C + END IF + END IF + ELSE IF ( BETA.EQ.ONE ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha = 1, A sparse. +C + DO 720 J = 1, NA +C + DO 710 K = 1, NB + IC = 1 +C + DO 700 I = 1, MA + AIJ = A(J,I) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 690 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 690 CONTINUE +C + END IF + IC = IC + MB + 700 CONTINUE +C + JC = JC + 1 + 710 CONTINUE +C + 720 CONTINUE +C + ELSE +C +C Case beta = 1, alpha = 1, A not sparse. +C + DO 760 J = 1, NA +C + DO 750 K = 1, NB + IC = 1 +C + DO 740 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 730 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 730 CONTINUE +C + IC = IC + MB + 740 CONTINUE +C + JC = JC + 1 + 750 CONTINUE +C + 760 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha <> 1, A sparse. +C + DO 800 J = 1, NA +C + DO 790 K = 1, NB + IC = 1 +C + DO 780 I = 1, MA + AIJ = ALPHA*A(J,I) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 770 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 770 CONTINUE +C + END IF + IC = IC + MB + 780 CONTINUE +C + JC = JC + 1 + 790 CONTINUE +C + 800 CONTINUE +C + ELSE +C +C Case beta = 1, alpha <> 1, A not sparse. +C + DO 840 J = 1, NA +C + DO 830 K = 1, NB + IC = 1 +C + DO 820 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 810 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 810 CONTINUE +C + IC = IC + MB + 820 CONTINUE +C + JC = JC + 1 + 830 CONTINUE +C + 840 CONTINUE +C + END IF + END IF + ELSE + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha = 1, A sparse. +C + DO 880 J = 1, NA +C + DO 870 K = 1, NB + IC = 1 +C + DO 860 I = 1, MA + AIJ = A(J,I) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 850 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 850 CONTINUE +C + END IF + IC = IC + MB + 860 CONTINUE +C + JC = JC + 1 + 870 CONTINUE +C + 880 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha = 1, A not sparse. +C + DO 920 J = 1, NA +C + DO 910 K = 1, NB + IC = 1 +C + DO 900 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 890 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 890 CONTINUE +C + IC = IC + MB + 900 CONTINUE +C + JC = JC + 1 + 910 CONTINUE +C + 920 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha <> 1, A sparse. +C + DO 960 J = 1, NA +C + DO 950 K = 1, NB + IC = 1 +C + DO 940 I = 1, MA + AIJ = ALPHA*A(J,I) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 930 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 930 CONTINUE +C + END IF + IC = IC + MB + 940 CONTINUE +C + JC = JC + 1 + 950 CONTINUE +C + 960 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha <> 1, A not sparse. +C + DO 1000 J = 1, NA +C + DO 990 K = 1, NB + IC = 1 +C + DO 980 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 970 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 970 CONTINUE +C + IC = IC + MB + 980 CONTINUE +C + JC = JC + 1 + 990 CONTINUE +C + 1000 CONTINUE +C + END IF + END IF + END IF + ELSE IF ( TRANSB .AND. .NOT.TRANSA ) THEN +C +C Case op(A) = A and op(B) = B'. +C + IF ( BETA.EQ.ZERO ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha = 1, A sparse. +C + DO 1080 J = 1, NA +C + DO 1070 K = 1, NB + IC = 1 +C + DO 1060 I = 1, MA + AIJ = A(I,J) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE IF ( AIJ.EQ.ONE ) THEN + CALL DCOPY( MB, B(K,1), LDB, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1050 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1050 CONTINUE +C + END IF + IC = IC + MB + 1060 CONTINUE +C + JC = JC + 1 + 1070 CONTINUE +C + 1080 CONTINUE +C + ELSE +C +C Case beta = 0, alpha = 1, A not sparse. +C + DO 1120 J = 1, NA +C + DO 1110 K = 1, NB + IC = 1 +C + DO 1100 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 1090 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1090 CONTINUE +C + IC = IC + MB + 1100 CONTINUE +C + JC = JC + 1 + 1110 CONTINUE +C + 1120 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha <> 1, A sparse. +C + DO 1160 J = 1, NA +C + DO 1150 K = 1, NB + IC = 1 +C + DO 1140 I = 1, MA + AIJ = ALPHA*A(I,J) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1130 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1130 CONTINUE +C + END IF + IC = IC + MB + 1140 CONTINUE +C + JC = JC + 1 + 1150 CONTINUE +C + 1160 CONTINUE +C + ELSE +C +C Case beta = 0, alpha <> 1, A not sparse. +C + DO 1200 J = 1, NA +C + DO 1190 K = 1, NB + IC = 1 +C + DO 1180 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 1170 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1170 CONTINUE +C + IC = IC + MB + 1180 CONTINUE +C + JC = JC + 1 + 1190 CONTINUE +C + 1200 CONTINUE +C + END IF + END IF + ELSE IF ( BETA.EQ.ONE ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha = 1, A sparse. +C + DO 1240 J = 1, NA +C + DO 1230 K = 1, NB + IC = 1 +C + DO 1220 I = 1, MA + AIJ = A(I,J) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 1210 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1210 CONTINUE +C + END IF + IC = IC + MB + 1220 CONTINUE +C + JC = JC + 1 + 1230 CONTINUE +C + 1240 CONTINUE +C + ELSE +C +C Case beta = 1, alpha = 1, A not sparse. +C + DO 1280 J = 1, NA +C + DO 1270 K = 1, NB + IC = 1 +C + DO 1260 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 1250 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1250 CONTINUE +C + IC = IC + MB + 1260 CONTINUE +C + JC = JC + 1 + 1270 CONTINUE +C + 1280 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha <> 1, A sparse. +C + DO 1320 J = 1, NA +C + DO 1310 K = 1, NB + IC = 1 +C + DO 1300 I = 1, MA + AIJ = ALPHA*A(I,J) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 1290 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1290 CONTINUE +C + END IF + IC = IC + MB + 1300 CONTINUE +C + JC = JC + 1 + 1310 CONTINUE +C + 1320 CONTINUE +C + ELSE +C +C Case beta = 1, alpha <> 1, A not sparse. +C + DO 1360 J = 1, NA +C + DO 1350 K = 1, NB + IC = 1 +C + DO 1340 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 1330 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1330 CONTINUE +C + IC = IC + MB + 1340 CONTINUE +C + JC = JC + 1 + 1350 CONTINUE +C + 1360 CONTINUE +C + END IF + END IF + ELSE + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha = 1, A sparse. +C + DO 1400 J = 1, NA +C + DO 1390 K = 1, NB + IC = 1 +C + DO 1380 I = 1, MA + AIJ = A(I,J) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1370 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1370 CONTINUE +C + END IF + IC = IC + MB + 1380 CONTINUE +C + JC = JC + 1 + 1390 CONTINUE +C + 1400 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha = 1, A not sparse. +C + DO 1440 J = 1, NA +C + DO 1430 K = 1, NB + IC = 1 +C + DO 1420 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 1410 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1410 CONTINUE +C + IC = IC + MB + 1420 CONTINUE +C + JC = JC + 1 + 1430 CONTINUE +C + 1440 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha <> 1, A sparse. +C + DO 1480 J = 1, NA +C + DO 1470 K = 1, NB + IC = 1 +C + DO 1460 I = 1, MA + AIJ = ALPHA*A(I,J) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1450 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1450 CONTINUE +C + END IF + IC = IC + MB + 1460 CONTINUE +C + JC = JC + 1 + 1470 CONTINUE +C + 1480 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha <> 1, A not sparse. +C + DO 1520 J = 1, NA +C + DO 1510 K = 1, NB + IC = 1 +C + DO 1500 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 1490 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1490 CONTINUE +C + IC = IC + MB + 1500 CONTINUE +C + JC = JC + 1 + 1510 CONTINUE +C + 1520 CONTINUE +C + END IF + END IF + END IF + ELSE +C +C Case op(A) = A' and op(B) = B'. +C + IF ( BETA.EQ.ZERO ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha = 1, A sparse. +C + DO 1580 J = 1, NA +C + DO 1570 K = 1, NB + IC = 1 +C + DO 1560 I = 1, MA + AIJ = A(J,I) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE IF ( AIJ.EQ.ONE ) THEN + CALL DCOPY( MB, B(K,1), LDB, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1550 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1550 CONTINUE +C + END IF + IC = IC + MB + 1560 CONTINUE +C + JC = JC + 1 + 1570 CONTINUE +C + 1580 CONTINUE +C + ELSE +C +C Case beta = 0, alpha = 1, A not sparse. +C + DO 1620 J = 1, NA +C + DO 1610 K = 1, NB + IC = 1 +C + DO 1600 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 1590 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1590 CONTINUE +C + IC = IC + MB + 1600 CONTINUE +C + JC = JC + 1 + 1610 CONTINUE +C + 1620 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha <> 1, A sparse. +C + DO 1660 J = 1, NA +C + DO 1650 K = 1, NB + IC = 1 +C + DO 1640 I = 1, MA + AIJ = ALPHA*A(J,I) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1630 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1630 CONTINUE +C + END IF + IC = IC + MB + 1640 CONTINUE +C + JC = JC + 1 + 1650 CONTINUE +C + 1660 CONTINUE +C + ELSE +C +C Case beta = 0, alpha <> 1, A not sparse. +C + DO 1700 J = 1, NA +C + DO 1690 K = 1, NB + IC = 1 +C + DO 1680 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 1670 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1670 CONTINUE +C + IC = IC + MB + 1680 CONTINUE +C + JC = JC + 1 + 1690 CONTINUE +C + 1700 CONTINUE +C + END IF + END IF + ELSE IF ( BETA.EQ.ONE ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha = 1, A sparse. +C + DO 1740 J = 1, NA +C + DO 1730 K = 1, NB + IC = 1 +C + DO 1720 I = 1, MA + AIJ = A(J,I) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 1710 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1710 CONTINUE +C + END IF + IC = IC + MB + 1720 CONTINUE +C + JC = JC + 1 + 1730 CONTINUE +C + 1740 CONTINUE +C + ELSE +C +C Case beta = 1, alpha = 1, A not sparse. +C + DO 1780 J = 1, NA +C + DO 1770 K = 1, NB + IC = 1 +C + DO 1760 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 1750 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1750 CONTINUE +C + IC = IC + MB + 1760 CONTINUE +C + JC = JC + 1 + 1770 CONTINUE +C + 1780 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha <> 1, A sparse. +C + DO 1820 J = 1, NA +C + DO 1810 K = 1, NB + IC = 1 +C + DO 1800 I = 1, MA + AIJ = ALPHA*A(J,I) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 1790 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1790 CONTINUE +C + END IF + IC = IC + MB + 1800 CONTINUE +C + JC = JC + 1 + 1810 CONTINUE +C + 1820 CONTINUE +C + ELSE +C +C Case beta = 1, alpha <> 1, A not sparse. +C + DO 1860 J = 1, NA +C + DO 1850 K = 1, NB + IC = 1 +C + DO 1840 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 1830 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1830 CONTINUE +C + IC = IC + MB + 1840 CONTINUE +C + JC = JC + 1 + 1850 CONTINUE +C + 1860 CONTINUE +C + END IF + END IF + ELSE + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha = 1, A sparse. +C + DO 1900 J = 1, NA +C + DO 1890 K = 1, NB + IC = 1 +C + DO 1880 I = 1, MA + AIJ = A(J,I) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1870 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1870 CONTINUE +C + END IF + IC = IC + MB + 1880 CONTINUE +C + JC = JC + 1 + 1890 CONTINUE +C + 1900 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha = 1, A not sparse. +C + DO 1940 J = 1, NA +C + DO 1930 K = 1, NB + IC = 1 +C + DO 1920 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 1910 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1910 CONTINUE +C + IC = IC + MB + 1920 CONTINUE +C + JC = JC + 1 + 1930 CONTINUE +C + 1940 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha <> 1, A sparse. +C + DO 1980 J = 1, NA +C + DO 1970 K = 1, NB + IC = 1 +C + DO 1960 I = 1, MA + AIJ = ALPHA*A(J,I) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1950 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1950 CONTINUE +C + END IF + IC = IC + MB + 1960 CONTINUE +C + JC = JC + 1 + 1970 CONTINUE +C + 1980 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha <> 1, A not sparse. +C + DO 2020 J = 1, NA +C + DO 2010 K = 1, NB + IC = 1 +C + DO 2000 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 1990 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1990 CONTINUE +C + IC = IC + MB + 2000 CONTINUE +C + JC = JC + 1 + 2010 CONTINUE +C + 2020 CONTINUE +C + END IF + END IF + END IF + END IF + RETURN +C *** Last line of MB01VD *** + END diff --git a/mex/sources/libslicot/MB01WD.f b/mex/sources/libslicot/MB01WD.f new file mode 100644 index 000000000..53c85f9da --- /dev/null +++ b/mex/sources/libslicot/MB01WD.f @@ -0,0 +1,343 @@ + SUBROUTINE MB01WD( DICO, UPLO, TRANS, HESS, N, ALPHA, BETA, R, + $ LDR, A, LDA, T, LDT, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix formula +C _ +C R = alpha*( op( A )'*op( T )'*op( T ) + op( T )'*op( T )*op( A ) ) +C + beta*R, (1) +C +C if DICO = 'C', or +C _ +C R = alpha*( op( A )'*op( T )'*op( T )*op( A ) - op( T )'*op( T )) +C + beta*R, (2) +C _ +C if DICO = 'D', where alpha and beta are scalars, R, and R are +C symmetric matrices, T is a triangular matrix, A is a general or +C Hessenberg matrix, and op( M ) is one of +C +C op( M ) = M or op( M ) = M'. +C +C The result is overwritten on R. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the formula to be evaluated, as follows: +C = 'C': formula (1), "continuous-time" case; +C = 'D': formula (2), "discrete-time" case. +C +C UPLO CHARACTER*1 +C Specifies which triangles of the symmetric matrix R and +C triangular matrix T are given, as follows: +C = 'U': the upper triangular parts of R and T are given; +C = 'L': the lower triangular parts of R and T are given; +C +C TRANS CHARACTER*1 +C Specifies the form of op( M ) to be used, as follows: +C = 'N': op( M ) = M; +C = 'T': op( M ) = M'; +C = 'C': op( M ) = M'. +C +C HESS CHARACTER*1 +C Specifies the form of the matrix A, as follows: +C = 'F': matrix A is full; +C = 'H': matrix A is Hessenberg (or Schur), either upper +C (if UPLO = 'U'), or lower (if UPLO = 'L'). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices R, A, and T. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then the arrays A +C and T are not referenced. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then the array R need +C not be set before entry. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) +C On entry with UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix R. +C On entry with UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix R. +C On exit, the leading N-by-N upper triangular part (if +C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of +C this array contains the corresponding triangular part of +C _ +C the computed matrix R. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. If HESS = 'H' the elements below the +C first subdiagonal, if UPLO = 'U', or above the first +C superdiagonal, if UPLO = 'L', need not be set to zero, +C and are not referenced if DICO = 'D'. +C On exit, the leading N-by-N part of this array contains +C the following matrix product +C alpha*T'*T*A, if TRANS = 'N', or +C alpha*A*T*T', otherwise, +C if DICO = 'C', or +C T*A, if TRANS = 'N', or +C A*T, otherwise, +C if DICO = 'D' (and in this case, these products have a +C Hessenberg form, if HESS = 'H'). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C T (input) DOUBLE PRECISION array, dimension (LDT,N) +C If UPLO = 'U', the leading N-by-N upper triangular part of +C this array must contain the upper triangular matrix T and +C the strictly lower triangular part need not be set to zero +C (and it is not referenced). +C If UPLO = 'L', the leading N-by-N lower triangular part of +C this array must contain the lower triangular matrix T and +C the strictly upper triangular part need not be set to zero +C (and it is not referenced). +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -k, the k-th argument had an illegal +C value. +C +C METHOD +C +C The matrix expression (1) or (2) is efficiently evaluated taking +C the structure into account. BLAS 3 operations (DTRMM, DSYRK and +C their specializations) are used throughout. +C +C NUMERICAL ASPECTS +C +C If A is a full matrix, the algorithm requires approximately +C 3 +C N operations, if DICO = 'C'; +C 3 +C 7/6 x N operations, if DICO = 'D'. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, HESS, TRANS, UPLO + INTEGER INFO, LDA, LDR, LDT, N + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), R(LDR,*), T(LDT,*) +C .. Local Scalars .. + LOGICAL DISCR, REDUC, TRANSP, UPPER + CHARACTER NEGTRA, SIDE + INTEGER I, INFO2, J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLASCL, DLASET, DSYRK, DTRMM, MB01YD, MB01ZD, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + UPPER = LSAME( UPLO, 'U' ) + TRANSP = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) + REDUC = LSAME( HESS, 'H' ) +C + IF( .NOT.( DISCR .OR. LSAME( DICO, 'C' ) ) )THEN + INFO = -1 + ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) )THEN + INFO = -2 + ELSE IF( .NOT.( TRANSP .OR. LSAME( TRANS, 'N' ) ) )THEN + INFO = -3 + ELSE IF( .NOT.( REDUC .OR. LSAME( HESS, 'F' ) ) )THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDR.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -13 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01WD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + IF ( ALPHA.EQ.ZERO ) THEN + IF ( BETA.EQ.ZERO ) THEN +C +C Special case when both alpha = 0 and beta = 0. +C + CALL DLASET( UPLO, N, N, ZERO, ZERO, R, LDR ) + ELSE +C +C Special case alpha = 0. +C + IF ( BETA.NE.ONE ) + $ CALL DLASCL( UPLO, 0, 0, ONE, BETA, N, N, R, LDR, INFO2 ) + END IF + RETURN + END IF +C +C General case: alpha <> 0. +C +C Compute (in A) T*A, if TRANS = 'N', or +C A*T, otherwise. +C + IF ( TRANSP ) THEN + SIDE = 'R' + NEGTRA = 'N' + ELSE + SIDE = 'L' + NEGTRA = 'T' + END IF +C + IF ( REDUC .AND. N.GT.2 ) THEN + CALL MB01ZD( SIDE, UPLO, 'NoTranspose', 'Non-unit', N, N, 1, + $ ONE, T, LDT, A, LDA, INFO2 ) + ELSE + CALL DTRMM( SIDE, UPLO, 'NoTranspose', 'Non-unit', N, N, ONE, + $ T, LDT, A, LDA ) + END IF +C + IF( .NOT.DISCR ) THEN +C +C Compute (in A) alpha*T'*T*A, if TRANS = 'N', or +C alpha*A*T*T', otherwise. +C + IF ( REDUC .AND. N.GT.2 ) THEN + CALL MB01ZD( SIDE, UPLO, 'Transpose', 'Non-unit', N, N, 1, + $ ALPHA, T, LDT, A, LDA, INFO2 ) + ELSE + CALL DTRMM( SIDE, UPLO, 'Transpose', 'Non-unit', N, N, + $ ALPHA, T, LDT, A, LDA ) + END IF +C +C Compute the required triangle of the result, using symmetry. +C + IF ( UPPER ) THEN + IF ( BETA.EQ.ZERO ) THEN +C + DO 20 J = 1, N + DO 10 I = 1, J + R( I, J ) = A( I, J ) + A( J, I ) + 10 CONTINUE + 20 CONTINUE +C + ELSE +C + DO 40 J = 1, N + DO 30 I = 1, J + R( I, J ) = A( I, J ) + A( J, I ) + BETA*R( I, J ) + 30 CONTINUE + 40 CONTINUE +C + END IF +C + ELSE +C + IF ( BETA.EQ.ZERO ) THEN +C + DO 60 J = 1, N + DO 50 I = J, N + R( I, J ) = A( I, J ) + A( J, I ) + 50 CONTINUE + 60 CONTINUE +C + ELSE +C + DO 80 J = 1, N + DO 70 I = J, N + R( I, J ) = A( I, J ) + A( J, I ) + BETA*R( I, J ) + 70 CONTINUE + 80 CONTINUE +C + END IF +C + END IF +C + ELSE +C +C Compute (in R) alpha*A'*T'*T*A + beta*R, if TRANS = 'N', or +C alpha*A*T*T'*A' + beta*R, otherwise. +C + IF ( REDUC .AND. N.GT.2 ) THEN + CALL MB01YD( UPLO, NEGTRA, N, N, 1, ALPHA, BETA, A, LDA, R, + $ LDR, INFO2 ) + ELSE + CALL DSYRK( UPLO, NEGTRA, N, N, ALPHA, A, LDA, BETA, R, + $ LDR ) + END IF +C +C Compute (in R) -alpha*T'*T + R, if TRANS = 'N', or +C -alpha*T*T' + R, otherwise. +C + CALL MB01YD( UPLO, NEGTRA, N, N, 0, -ALPHA, ONE, T, LDT, R, + $ LDR, INFO2 ) +C + END IF +C + RETURN +C *** Last line of MB01WD *** + END diff --git a/mex/sources/libslicot/MB01XD.f b/mex/sources/libslicot/MB01XD.f new file mode 100644 index 000000000..3a54a2e2a --- /dev/null +++ b/mex/sources/libslicot/MB01XD.f @@ -0,0 +1,207 @@ + SUBROUTINE MB01XD( UPLO, N, A, LDA, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix product U' * U or L * L', where U and L are +C upper and lower triangular matrices, respectively, stored in the +C corresponding upper or lower triangular part of the array A. +C +C If UPLO = 'U' then the upper triangle of the result is stored, +C overwriting the matrix U in A. +C If UPLO = 'L' then the lower triangle of the result is stored, +C overwriting the matrix L in A. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies which triangle (U or L) is given in the array A, +C as follows: +C = 'U': the upper triangular part U is given; +C = 'L': the lower triangular part L is given. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the triangular matrices U or L. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, if UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular matrix U. +C On entry, if UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular matrix L. +C On exit, if UPLO = 'U', the leading N-by-N upper +C triangular part of this array contains the upper +C triangular part of the product U' * U. The strictly lower +C triangular part is not referenced. +C On exit, if UPLO = 'L', the leading N-by-N lower +C triangular part of this array contains the lower +C triangular part of the product L * L'. The strictly upper +C triangular part is not referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= max(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix product U' * U or L * L' is computed using BLAS 3 +C operations as much as possible (a block algorithm). +C +C FURTHER COMMENTS +C +C This routine is a counterpart of LAPACK Library routine DLAUUM, +C which computes the matrix product U * U' or L' * L. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +C .. +C .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IB, II, NB +C .. +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DSYRK, DTRMM, MB01XY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01XD', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF( N.EQ.0 ) + $ RETURN +C +C Determine the block size for this environment (as for DLAUUM). +C + NB = ILAENV( 1, 'DLAUUM', UPLO, N, -1, -1, -1 ) +C + IF( NB.LE.1 .OR. NB.GE.N ) THEN +C +C Use unblocked code. +C + CALL MB01XY( UPLO, N, A, LDA, INFO ) + ELSE +C +C Use blocked code. +C + IF( UPPER ) THEN +C +C Compute the product U' * U. +C + DO 10 I = N, 1, -NB + IB = MIN( NB, I ) + II = I - IB + 1 + IF( I.LT.N ) THEN + CALL DTRMM( 'Left', 'Upper', 'Transpose', 'Non-unit', + $ IB, N-I, ONE, A( II, II ), LDA, + $ A( II, II+IB ), LDA ) + CALL DGEMM( 'Transpose', 'No transpose', IB, N-I, + $ I-IB, ONE, A( 1, II ), LDA, A( 1, II+IB ), + $ LDA, ONE, A( II, II+IB ), LDA ) + END IF + CALL MB01XY( 'Upper', IB, A( II, II ), LDA, INFO ) + CALL DSYRK( 'Upper', 'Transpose', IB, II-1, ONE, + $ A( 1, II ), LDA, ONE, A( II, II ), LDA ) + 10 CONTINUE + ELSE +C +C Compute the product L * L'. +C + DO 20 I = N, 1, -NB + IB = MIN( NB, I ) + II = I - IB + 1 + IF( I.LT.N ) THEN + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Non-unit', + $ N-I, IB, ONE, A( II, II ), LDA, + $ A( II+IB, II ), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', N-I, IB, + $ I-IB, ONE, A( II+IB, 1 ), LDA, A( II, 1 ), + $ LDA, ONE, A( II+IB, II ), LDA ) + END IF + CALL MB01XY( 'Lower', IB, A( II, II ), LDA, INFO ) + CALL DSYRK( 'Lower', 'No Transpose', IB, II-1, ONE, + $ A( II, 1 ), LDA, ONE, A( II, II ), LDA ) + 20 CONTINUE + END IF + END IF +C + RETURN +C +C *** Last line of MB01XD *** + END diff --git a/mex/sources/libslicot/MB01XY.f b/mex/sources/libslicot/MB01XY.f new file mode 100644 index 000000000..6af6275cd --- /dev/null +++ b/mex/sources/libslicot/MB01XY.f @@ -0,0 +1,191 @@ + SUBROUTINE MB01XY( UPLO, N, A, LDA, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix product U' * U or L * L', where U and L are +C upper and lower triangular matrices, respectively, stored in the +C corresponding upper or lower triangular part of the array A. +C +C If UPLO = 'U' then the upper triangle of the result is stored, +C overwriting the matrix U in A. +C If UPLO = 'L' then the lower triangle of the result is stored, +C overwriting the matrix L in A. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies which triangle (U or L) is given in the array A, +C as follows: +C = 'U': the upper triangular part U is given; +C = 'L': the lower triangular part L is given. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the triangular matrices U or L. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, if UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular matrix U. +C On entry, if UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular matrix L. +C On exit, if UPLO = 'U', the leading N-by-N upper +C triangular part of this array contains the upper +C triangular part of the product U' * U. The strictly lower +C triangular part is not referenced. +C On exit, if UPLO = 'L', the leading N-by-N lower +C triangular part of this array contains the lower +C triangular part of the product L * L'. The strictly upper +C triangular part is not referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= max(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix product U' * U or L * L' is computed using BLAS 2 and +C BLAS 1 operations (an unblocked algorithm). +C +C FURTHER COMMENTS +C +C This routine is a counterpart of LAPACK Library routine DLAUU2, +C which computes the matrix product U * U' or L' * L. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +C .. +C .. Local Scalars .. + LOGICAL UPPER + INTEGER I + DOUBLE PRECISION AII +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL DDOT, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DGEMV, DSCAL, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01XY', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF( N.EQ.0 ) + $ RETURN +C + IF( UPPER ) THEN +C +C Compute the product U' * U. +C + A( N, N ) = DDOT( N, A( 1, N ), 1, A( 1, N ), 1 ) +C + DO 10 I = N-1, 2, -1 + AII = A( I, I ) + A( I, I ) = DDOT( I, A( 1, I ), 1, A( 1, I ), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), LDA, + $ A( 1, I ), 1, AII, A( I, I+1 ), LDA ) + 10 CONTINUE +C + IF( N.GT.1 ) THEN + AII = A( 1, 1 ) + CALL DSCAL( N, AII, A( 1, 1 ), LDA ) + END IF +C + ELSE +C +C Compute the product L * L'. +C + A( N, N ) = DDOT( N, A( N, 1 ), LDA, A( N, 1 ), LDA ) +C + DO 20 I = N-1, 2, -1 + AII = A( I, I ) + A( I, I ) = DDOT( I, A( I, 1 ), LDA, A( I, 1 ), LDA ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A( I+1, 1 ), + $ LDA, A( I, 1 ), LDA, AII, A( I+1, I ), 1 ) + 20 CONTINUE +C + IF( N.GT.1 ) THEN + AII = A( 1, 1 ) + CALL DSCAL( N, AII, A( 1, 1 ), 1 ) + END IF + END IF +C + RETURN +C +C *** Last line of MB01XY *** + END diff --git a/mex/sources/libslicot/MB01YD.f b/mex/sources/libslicot/MB01YD.f new file mode 100644 index 000000000..6d5c2a0fe --- /dev/null +++ b/mex/sources/libslicot/MB01YD.f @@ -0,0 +1,352 @@ + SUBROUTINE MB01YD( UPLO, TRANS, N, K, L, ALPHA, BETA, A, LDA, C, + $ LDC, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the symmetric rank k operations +C +C C := alpha*op( A )*op( A )' + beta*C, +C +C where alpha and beta are scalars, C is an n-by-n symmetric matrix, +C op( A ) is an n-by-k matrix, and op( A ) is one of +C +C op( A ) = A or op( A ) = A'. +C +C The matrix A has l nonzero codiagonals, either upper or lower. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies which triangle of the symmetric matrix C +C is given and computed, as follows: +C = 'U': the upper triangular part is given/computed; +C = 'L': the lower triangular part is given/computed. +C UPLO also defines the pattern of the matrix A (see below). +C +C TRANS CHARACTER*1 +C Specifies the form of op( A ) to be used, as follows: +C = 'N': op( A ) = A; +C = 'T': op( A ) = A'; +C = 'C': op( A ) = A'. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix C. N >= 0. +C +C K (input) INTEGER +C The number of columns of the matrix op( A ). K >= 0. +C +C L (input) INTEGER +C If UPLO = 'U', matrix A has L nonzero subdiagonals. +C If UPLO = 'L', matrix A has L nonzero superdiagonals. +C MAX(0,NR-1) >= L >= 0, if UPLO = 'U', +C MAX(0,NC-1) >= L >= 0, if UPLO = 'L', +C where NR and NC are the numbers of rows and columns of the +C matrix A, respectively. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then the array A is +C not referenced. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then the array C need +C not be set before entry. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,NC), where +C NC is K when TRANS = 'N', and is N otherwise. +C If TRANS = 'N', the leading N-by-K part of this array must +C contain the matrix A, otherwise the leading K-by-N part of +C this array must contain the matrix A. +C If UPLO = 'U', only the upper triangular part and the +C first L subdiagonals are referenced, and the remaining +C subdiagonals are assumed to be zero. +C If UPLO = 'L', only the lower triangular part and the +C first L superdiagonals are referenced, and the remaining +C superdiagonals are assumed to be zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= max(1,NR), +C where NR = N, if TRANS = 'N', and NR = K, otherwise. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry with UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix C. +C On entry with UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix C. +C On exit, the leading N-by-N upper triangular part (if +C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of +C this array contains the corresponding triangular part of +C the updated matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The calculations are efficiently performed taking the symmetry +C and structure into account. +C +C FURTHER COMMENTS +C +C The matrix A may have the following patterns, when n = 7, k = 5, +C and l = 2 are used for illustration: +C +C UPLO = 'U', TRANS = 'N' UPLO = 'L', TRANS = 'N' +C +C [ x x x x x ] [ x x x 0 0 ] +C [ x x x x x ] [ x x x x 0 ] +C [ x x x x x ] [ x x x x x ] +C A = [ 0 x x x x ], A = [ x x x x x ], +C [ 0 0 x x x ] [ x x x x x ] +C [ 0 0 0 x x ] [ x x x x x ] +C [ 0 0 0 0 x ] [ x x x x x ] +C +C UPLO = 'U', TRANS = 'T' UPLO = 'L', TRANS = 'T' +C +C [ x x x x x x x ] [ x x x 0 0 0 0 ] +C [ x x x x x x x ] [ x x x x 0 0 0 ] +C A = [ x x x x x x x ], A = [ x x x x x 0 0 ]. +C [ 0 x x x x x x ] [ x x x x x x 0 ] +C [ 0 0 x x x x x ] [ x x x x x x x ] +C +C If N = K, the matrix A is upper or lower triangular, for L = 0, +C and upper or lower Hessenberg, for L = 1. +C +C This routine is a specialization of the BLAS 3 routine DSYRK. +C BLAS 1 calls are used when appropriate, instead of in-line code, +C in order to increase the efficiency. If the matrix A is full, or +C its zero triangle has small order, an optimized DSYRK code could +C be faster than MB01YD. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. +C .. Scalar Arguments .. + CHARACTER TRANS, UPLO + INTEGER INFO, LDA, LDC, K, L, N + DOUBLE PRECISION ALPHA, BETA +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ) +C .. +C .. Local Scalars .. + LOGICAL TRANSP, UPPER + INTEGER I, J, M, NCOLA, NROWA + DOUBLE PRECISION TEMP +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL DDOT, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DLASCL, DLASET, DSCAL, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + TRANSP = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF( TRANSP )THEN + NROWA = K + NCOLA = N + ELSE + NROWA = N + NCOLA = K + END IF +C + IF( UPPER )THEN + M = NROWA + ELSE + M = NCOLA + END IF +C + IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( TRANSP .OR. LSAME( TRANS, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( K.LT.0 ) THEN + INFO = -4 + ELSE IF( L.LT.0 .OR. L.GT.MAX( 0, M-1 ) ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -11 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01YD', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF( ( N.EQ.0 ).OR. + $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +C + IF ( ALPHA.EQ.ZERO ) THEN + IF ( BETA.EQ.ZERO ) THEN +C +C Special case when both alpha = 0 and beta = 0. +C + CALL DLASET( UPLO, N, N, ZERO, ZERO, C, LDC ) + ELSE +C +C Special case alpha = 0. +C + CALL DLASCL( UPLO, 0, 0, ONE, BETA, N, N, C, LDC, INFO ) + END IF + RETURN + END IF +C +C General case: alpha <> 0. +C + IF ( .NOT.TRANSP ) THEN +C +C Form C := alpha*A*A' + beta*C. +C + IF ( UPPER ) THEN +C + DO 30 J = 1, N + IF ( BETA.EQ.ZERO ) THEN +C + DO 10 I = 1, J + C( I, J ) = ZERO + 10 CONTINUE +C + ELSE IF ( BETA.NE.ONE ) THEN + CALL DSCAL ( J, BETA, C( 1, J ), 1 ) + END IF +C + DO 20 M = MAX( 1, J-L ), K + CALL DAXPY ( MIN( J, L+M ), ALPHA*A( J, M ), + $ A( 1, M ), 1, C( 1, J ), 1 ) + 20 CONTINUE +C + 30 CONTINUE +C + ELSE +C + DO 60 J = 1, N + IF ( BETA.EQ.ZERO ) THEN +C + DO 40 I = J, N + C( I, J ) = ZERO + 40 CONTINUE +C + ELSE IF ( BETA.NE.ONE ) THEN + CALL DSCAL ( N-J+1, BETA, C( J, J ), 1 ) + END IF +C + DO 50 M = 1, MIN( J+L, K ) + CALL DAXPY ( N-J+1, ALPHA*A( J, M ), A( J, M ), 1, + $ C( J, J ), 1 ) + 50 CONTINUE +C + 60 CONTINUE +C + END IF +C + ELSE +C +C Form C := alpha*A'*A + beta*C. +C + IF ( UPPER ) THEN +C + DO 80 J = 1, N +C + DO 70 I = 1, J + TEMP = ALPHA*DDOT ( MIN( J+L, K ), A( 1, I ), 1, + $ A( 1, J ), 1 ) + IF ( BETA.EQ.ZERO ) THEN + C( I, J ) = TEMP + ELSE + C( I, J ) = TEMP + BETA*C( I, J ) + END IF + 70 CONTINUE +C + 80 CONTINUE +C + ELSE +C + DO 100 J = 1, N +C + DO 90 I = J, N + M = MAX( 1, I-L ) + TEMP = ALPHA*DDOT ( K-M+1, A( M, I ), 1, A( M, J ), + $ 1 ) + IF ( BETA.EQ.ZERO ) THEN + C( I, J ) = TEMP + ELSE + C( I, J ) = TEMP + BETA*C( I, J ) + END IF + 90 CONTINUE +C + 100 CONTINUE +C + END IF +C + END IF +C + RETURN +C +C *** Last line of MB01YD *** + END diff --git a/mex/sources/libslicot/MB01ZD.f b/mex/sources/libslicot/MB01ZD.f new file mode 100644 index 000000000..abdbbf473 --- /dev/null +++ b/mex/sources/libslicot/MB01ZD.f @@ -0,0 +1,475 @@ + SUBROUTINE MB01ZD( SIDE, UPLO, TRANST, DIAG, M, N, L, ALPHA, T, + $ LDT, H, LDH, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix product +C +C H := alpha*op( T )*H, or H := alpha*H*op( T ), +C +C where alpha is a scalar, H is an m-by-n upper or lower +C Hessenberg-like matrix (with l nonzero subdiagonals or +C superdiagonals, respectively), T is a unit, or non-unit, +C upper or lower triangular matrix, and op( T ) is one of +C +C op( T ) = T or op( T ) = T'. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies whether the triangular matrix T appears on the +C left or right in the matrix product, as follows: +C = 'L': the product alpha*op( T )*H is computed; +C = 'R': the product alpha*H*op( T ) is computed. +C +C UPLO CHARACTER*1 +C Specifies the form of the matrices T and H, as follows: +C = 'U': the matrix T is upper triangular and the matrix H +C is upper Hessenberg-like; +C = 'L': the matrix T is lower triangular and the matrix H +C is lower Hessenberg-like. +C +C TRANST CHARACTER*1 +C Specifies the form of op( T ) to be used, as follows: +C = 'N': op( T ) = T; +C = 'T': op( T ) = T'; +C = 'C': op( T ) = T'. +C +C DIAG CHARACTER*1. +C Specifies whether or not T is unit triangular, as follows: +C = 'U': the matrix T is assumed to be unit triangular; +C = 'N': the matrix T is not assumed to be unit triangular. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of H. M >= 0. +C +C N (input) INTEGER +C The number of columns of H. N >= 0. +C +C L (input) INTEGER +C If UPLO = 'U', matrix H has L nonzero subdiagonals. +C If UPLO = 'L', matrix H has L nonzero superdiagonals. +C MAX(0,M-1) >= L >= 0, if UPLO = 'U'; +C MAX(0,N-1) >= L >= 0, if UPLO = 'L'. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then T is not +C referenced and H need not be set before entry. +C +C T (input) DOUBLE PRECISION array, dimension (LDT,k), where +C k is m when SIDE = 'L' and is n when SIDE = 'R'. +C If UPLO = 'U', the leading k-by-k upper triangular part +C of this array must contain the upper triangular matrix T +C and the strictly lower triangular part is not referenced. +C If UPLO = 'L', the leading k-by-k lower triangular part +C of this array must contain the lower triangular matrix T +C and the strictly upper triangular part is not referenced. +C Note that when DIAG = 'U', the diagonal elements of T are +C not referenced either, but are assumed to be unity. +C +C LDT INTEGER +C The leading dimension of array T. +C LDT >= MAX(1,M), if SIDE = 'L'; +C LDT >= MAX(1,N), if SIDE = 'R'. +C +C H (input/output) DOUBLE PRECISION array, dimension (LDH,N) +C On entry, if UPLO = 'U', the leading M-by-N upper +C Hessenberg part of this array must contain the upper +C Hessenberg-like matrix H. +C On entry, if UPLO = 'L', the leading M-by-N lower +C Hessenberg part of this array must contain the lower +C Hessenberg-like matrix H. +C On exit, the leading M-by-N part of this array contains +C the matrix product alpha*op( T )*H, if SIDE = 'L', +C or alpha*H*op( T ), if SIDE = 'R'. If TRANST = 'N', this +C product has the same pattern as the given matrix H; +C the elements below the L-th subdiagonal (if UPLO = 'U'), +C or above the L-th superdiagonal (if UPLO = 'L'), are not +C referenced in this case. If TRANST = 'T', the elements +C below the (N+L)-th row (if UPLO = 'U', SIDE = 'R', and +C M > N+L), or at the right of the (M+L)-th column +C (if UPLO = 'L', SIDE = 'L', and N > M+L), are not set to +C zero nor referenced. +C +C LDH INTEGER +C The leading dimension of array H. LDH >= max(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The calculations are efficiently performed taking the problem +C structure into account. +C +C FURTHER COMMENTS +C +C The matrix H may have the following patterns, when m = 7, n = 6, +C and l = 2 are used for illustration: +C +C UPLO = 'U' UPLO = 'L' +C +C [ x x x x x x ] [ x x x 0 0 0 ] +C [ x x x x x x ] [ x x x x 0 0 ] +C [ x x x x x x ] [ x x x x x 0 ] +C H = [ 0 x x x x x ], H = [ x x x x x x ]. +C [ 0 0 x x x x ] [ x x x x x x ] +C [ 0 0 0 x x x ] [ x x x x x x ] +C [ 0 0 0 0 x x ] [ x x x x x x ] +C +C The products T*H or H*T have the same pattern as H, but the +C products T'*H or H*T' may be full matrices. +C +C If m = n, the matrix H is upper or lower triangular, for l = 0, +C and upper or lower Hessenberg, for l = 1. +C +C This routine is a specialization of the BLAS 3 routine DTRMM. +C BLAS 1 calls are used when appropriate, instead of in-line code, +C in order to increase the efficiency. If the matrix H is full, or +C its zero triangle has small order, an optimized DTRMM code could +C be faster than MB01ZD. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. +C .. Scalar Arguments .. + CHARACTER DIAG, SIDE, TRANST, UPLO + INTEGER INFO, L, LDH, LDT, M, N + DOUBLE PRECISION ALPHA +C .. +C .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), T( LDT, * ) +C .. +C .. Local Scalars .. + LOGICAL LSIDE, NOUNIT, TRANS, UPPER + INTEGER I, I1, I2, J, K, M2, NROWT + DOUBLE PRECISION TEMP +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL DDOT, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DSCAL, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + LSIDE = LSAME( SIDE, 'L' ) + UPPER = LSAME( UPLO, 'U' ) + TRANS = LSAME( TRANST, 'T' ) .OR. LSAME( TRANST, 'C' ) + NOUNIT = LSAME( DIAG, 'N' ) + IF( LSIDE )THEN + NROWT = M + ELSE + NROWT = N + END IF +C + IF( UPPER )THEN + M2 = M + ELSE + M2 = N + END IF +C + INFO = 0 + IF( .NOT.( LSIDE .OR. LSAME( SIDE, 'R' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( TRANS .OR. LSAME( TRANST, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT.( NOUNIT .OR. LSAME( DIAG, 'U' ) ) ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( L.LT.0 .OR. L.GT.MAX( 0, M2-1 ) ) THEN + INFO = -7 + ELSE IF( LDT.LT.MAX( 1, NROWT ) ) THEN + INFO = -10 + ELSE IF( LDH.LT.MAX( 1, M ) )THEN + INFO = -12 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01ZD', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF( MIN( M, N ).EQ.0 ) + $ RETURN +C +C Also, when alpha = 0. +C + IF( ALPHA.EQ.ZERO ) THEN +C + DO 20, J = 1, N + IF( UPPER ) THEN + I1 = 1 + I2 = MIN( J+L, M ) + ELSE + I1 = MAX( 1, J-L ) + I2 = M + END IF +C + DO 10, I = I1, I2 + H( I, J ) = ZERO + 10 CONTINUE +C + 20 CONTINUE +C + RETURN + END IF +C +C Start the operations. +C + IF( LSIDE )THEN + IF( .NOT.TRANS ) THEN +C +C Form H := alpha*T*H. +C + IF( UPPER ) THEN +C + DO 40, J = 1, N +C + DO 30, K = 1, MIN( J+L, M ) + IF( H( K, J ).NE.ZERO ) THEN + TEMP = ALPHA*H( K, J ) + CALL DAXPY ( K-1, TEMP, T( 1, K ), 1, H( 1, J ), + $ 1 ) + IF( NOUNIT ) + $ TEMP = TEMP*T( K, K ) + H( K, J ) = TEMP + END IF + 30 CONTINUE +C + 40 CONTINUE +C + ELSE +C + DO 60, J = 1, N +C + DO 50 K = M, MAX( 1, J-L ), -1 + IF( H( K, J ).NE.ZERO ) THEN + TEMP = ALPHA*H( K, J ) + H( K, J ) = TEMP + IF( NOUNIT ) + $ H( K, J ) = H( K, J )*T( K, K ) + CALL DAXPY ( M-K, TEMP, T( K+1, K ), 1, + $ H( K+1, J ), 1 ) + END IF + 50 CONTINUE +C + 60 CONTINUE +C + END IF +C + ELSE +C +C Form H := alpha*T'*H. +C + IF( UPPER ) THEN +C + DO 80, J = 1, N + I1 = J + L +C + DO 70, I = M, 1, -1 + IF( I.GT.I1 ) THEN + TEMP = DDOT( I1, T( 1, I ), 1, H( 1, J ), 1 ) + ELSE + TEMP = H( I, J ) + IF( NOUNIT ) + $ TEMP = TEMP*T( I, I ) + TEMP = TEMP + DDOT( I-1, T( 1, I ), 1, + $ H( 1, J ), 1 ) + END IF + H( I, J ) = ALPHA*TEMP + 70 CONTINUE +C + 80 CONTINUE +C + ELSE +C + DO 100, J = 1, MIN( M+L, N ) + I1 = J - L +C + DO 90, I = 1, M + IF( I.LT.I1 ) THEN + TEMP = DDOT( M-I1+1, T( I1, I ), 1, H( I1, J ), + $ 1 ) + ELSE + TEMP = H( I, J ) + IF( NOUNIT ) + $ TEMP = TEMP*T( I, I ) + TEMP = TEMP + DDOT( M-I, T( I+1, I ), 1, + $ H( I+1, J ), 1 ) + END IF + H( I, J ) = ALPHA*TEMP + 90 CONTINUE +C + 100 CONTINUE +C + END IF +C + END IF +C + ELSE +C + IF( .NOT.TRANS ) THEN +C +C Form H := alpha*H*T. +C + IF( UPPER ) THEN +C + DO 120, J = N, 1, -1 + I2 = MIN( J+L, M ) + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*T( J, J ) + CALL DSCAL ( I2, TEMP, H( 1, J ), 1 ) +C + DO 110, K = 1, J - 1 + CALL DAXPY ( I2, ALPHA*T( K, J ), H( 1, K ), 1, + $ H( 1, J ), 1 ) + 110 CONTINUE +C + 120 CONTINUE +C + ELSE +C + DO 140, J = 1, N + I1 = MAX( 1, J-L ) + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*T( J, J ) + CALL DSCAL ( M-I1+1, TEMP, H( I1, J ), 1 ) +C + DO 130, K = J + 1, N + CALL DAXPY ( M-I1+1, ALPHA*T( K, J ), H( I1, K ), + $ 1, H( I1, J ), 1 ) + 130 CONTINUE +C + 140 CONTINUE +C + END IF +C + ELSE +C +C Form H := alpha*H*T'. +C + IF( UPPER ) THEN + M2 = MIN( N+L, M ) +C + DO 170, K = 1, N + I1 = MIN( K+L, M ) + I2 = MIN( K+L, M2 ) +C + DO 160, J = 1, K - 1 + IF( T( J, K ).NE.ZERO ) THEN + TEMP = ALPHA*T( J, K ) + CALL DAXPY ( I1, TEMP, H( 1, K ), 1, H( 1, J ), + $ 1 ) +C + DO 150, I = I1 + 1, I2 + H( I, J ) = TEMP*H( I, K ) + 150 CONTINUE +C + END IF + 160 CONTINUE +C + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*T( K, K ) + IF( TEMP.NE.ONE ) + $ CALL DSCAL( I2, TEMP, H( 1, K ), 1 ) + 170 CONTINUE +C + ELSE +C + DO 200, K = N, 1, -1 + I1 = MAX( 1, K-L ) + I2 = MAX( 1, K-L+1 ) + M2 = MIN( M, I2-1 ) +C + DO 190, J = K + 1, N + IF( T( J, K ).NE.ZERO ) THEN + TEMP = ALPHA*T( J, K ) + CALL DAXPY ( M-I2+1, TEMP, H( I2, K ), 1, + $ H( I2, J ), 1 ) +C + DO 180, I = I1, M2 + H( I, J ) = TEMP*H( I, K ) + 180 CONTINUE +C + END IF + 190 CONTINUE +C + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*T( K, K ) + IF( TEMP.NE.ONE ) + $ CALL DSCAL( M-I1+1, TEMP, H( I1, K ), 1 ) + 200 CONTINUE +C + END IF +C + END IF +C + END IF +C + RETURN +C +C *** Last line of MB01ZD *** + END diff --git a/mex/sources/libslicot/MB02CD.f b/mex/sources/libslicot/MB02CD.f new file mode 100644 index 000000000..2c878db9d --- /dev/null +++ b/mex/sources/libslicot/MB02CD.f @@ -0,0 +1,597 @@ + SUBROUTINE MB02CD( JOB, TYPET, K, N, T, LDT, G, LDG, R, LDR, L, + $ LDL, CS, LCS, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Cholesky factor and the generator and/or the +C Cholesky factor of the inverse of a symmetric positive definite +C (s.p.d.) block Toeplitz matrix T, defined by either its first +C block row, or its first block column, depending on the routine +C parameter TYPET. Transformation information is stored. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the output of the routine, as follows: +C = 'G': only computes the generator G of the inverse; +C = 'R': computes the generator G of the inverse and the +C Cholesky factor R of T, i.e., if TYPET = 'R', +C then R'*R = T, and if TYPET = 'C', then R*R' = T; +C = 'L': computes the generator G and the Cholesky factor L +C of the inverse, i.e., if TYPET = 'R', then +C L'*L = inv(T), and if TYPET = 'C', then +C L*L' = inv(T); +C = 'A': computes the generator G, the Cholesky factor L +C of the inverse and the Cholesky factor R of T; +C = 'O': only computes the Cholesky factor R of T. +C +C TYPET CHARACTER*1 +C Specifies the type of T, as follows: +C = 'R': T contains the first block row of an s.p.d. block +C Toeplitz matrix; if demanded, the Cholesky factors +C R and L are upper and lower triangular, +C respectively, and G contains the transposed +C generator of the inverse; +C = 'C': T contains the first block column of an s.p.d. +C block Toeplitz matrix; if demanded, the Cholesky +C factors R and L are lower and upper triangular, +C respectively, and G contains the generator of the +C inverse. This choice results in a column oriented +C algorithm which is usually faster. +C Note: in the sequel, the notation x / y means that +C x corresponds to TYPET = 'R' and y corresponds to +C TYPET = 'C'. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows / columns in T, which should be equal +C to the blocksize. K >= 0. +C +C N (input) INTEGER +C The number of blocks in T. N >= 0. +C +C T (input/output) DOUBLE PRECISION array, dimension +C (LDT,N*K) / (LDT,K) +C On entry, the leading K-by-N*K / N*K-by-K part of this +C array must contain the first block row / column of an +C s.p.d. block Toeplitz matrix. +C On exit, if INFO = 0, then the leading K-by-N*K / N*K-by-K +C part of this array contains, in the first K-by-K block, +C the upper / lower Cholesky factor of T(1:K,1:K), and in +C the remaining part, the Householder transformations +C applied during the process. +C +C LDT INTEGER +C The leading dimension of the array T. +C LDT >= MAX(1,K), if TYPET = 'R'; +C LDT >= MAX(1,N*K), if TYPET = 'C'. +C +C G (output) DOUBLE PRECISION array, dimension +C (LDG,N*K) / (LDG,2*K) +C If INFO = 0 and JOB = 'G', 'R', 'L', or 'A', the leading +C 2*K-by-N*K / N*K-by-2*K part of this array contains, in +C the first K-by-K block of the second block row / column, +C the lower right block of L (necessary for updating +C factorizations in SLICOT Library routine MB02DD), and +C in the remaining part, the generator of the inverse of T. +C Actually, to obtain a generator one has to set +C G(K+1:2*K, 1:K) = 0, if TYPET = 'R'; +C G(1:K, K+1:2*K) = 0, if TYPET = 'C'. +C +C LDG INTEGER +C The leading dimension of the array G. +C LDG >= MAX(1,2*K), if TYPET = 'R' and +C JOB = 'G', 'R', 'L', or 'A'; +C LDG >= MAX(1,N*K), if TYPET = 'C' and +C JOB = 'G', 'R', 'L', or 'A'; +C LDG >= 1, if JOB = 'O'. +C +C R (output) DOUBLE PRECISION array, dimension (LDR,N*K) +C If INFO = 0 and JOB = 'R', 'A', or 'O', then the leading +C N*K-by-N*K part of this array contains the upper / lower +C Cholesky factor of T. +C The elements in the strictly lower / upper triangular part +C are not referenced. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= MAX(1,N*K), if JOB = 'R', 'A', or 'O'; +C LDR >= 1, if JOB = 'G', or 'L'. +C +C L (output) DOUBLE PRECISION array, dimension (LDL,N*K) +C If INFO = 0 and JOB = 'L', or 'A', then the leading +C N*K-by-N*K part of this array contains the lower / upper +C Cholesky factor of the inverse of T. +C The elements in the strictly upper / lower triangular part +C are not referenced. +C +C LDL INTEGER +C The leading dimension of the array L. +C LDL >= MAX(1,N*K), if JOB = 'L', or 'A'; +C LDL >= 1, if JOB = 'G', 'R', or 'O'. +C +C CS (output) DOUBLE PRECISION array, dimension (LCS) +C If INFO = 0, then the leading 3*(N-1)*K part of this +C array contains information about the hyperbolic rotations +C and Householder transformations applied during the +C process. This information is needed for updating the +C factorizations in SLICOT Library routine MB02DD. +C +C LCS INTEGER +C The length of the array CS. LCS >= 3*(N-1)*K. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -16, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,(N-1)*K). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction algorithm failed. The Toeplitz matrix +C associated with T is not (numerically) positive +C definite. +C +C METHOD +C +C Householder transformations and modified hyperbolic rotations +C are used in the Schur algorithm [1], [2]. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C 3 2 +C The algorithm requires 0(K N ) floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 2000, +C February 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB, TYPET + INTEGER INFO, K, LCS, LDG, LDL, LDR, LDT, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION CS(*), DWORK(*), G(LDG, *), L(LDL,*), R(LDR,*), + $ T(LDT,*) +C .. Local Scalars .. + INTEGER I, IERR, MAXWRK, STARTI, STARTR, STARTT + LOGICAL COMPG, COMPL, COMPR, ISROW +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DLASET, DPOTRF, DTRSM, MB02CX, MB02CY, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + COMPL = LSAME( JOB, 'L' ) .OR. LSAME( JOB, 'A' ) + COMPG = LSAME( JOB, 'G' ) .OR. LSAME( JOB, 'R' ) .OR. COMPL + COMPR = LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' ) .OR. + $ LSAME( JOB, 'O' ) + ISROW = LSAME( TYPET, 'R' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( COMPG .OR. COMPR ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN + INFO = -2 + ELSE IF ( K.LT.0 ) THEN + INFO = -3 + ELSE IF ( N.LT.0 ) THEN + INFO = -4 + ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. + $ ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN + INFO = -6 + ELSE IF ( LDG.LT.1 .OR. + $ ( COMPG .AND. ( ( ISROW .AND. LDG.LT.2*K ) + $ .OR. ( .NOT.ISROW .AND. LDG.LT.N*K ) ) ) ) THEN + INFO = -8 + ELSE IF ( LDR.LT.1 .OR. ( COMPR .AND. ( LDR.LT.N*K ) ) ) THEN + INFO = -10 + ELSE IF ( LDL.LT.1 .OR. ( COMPL .AND. ( LDL.LT.N*K ) ) ) THEN + INFO = -12 + ELSE IF ( LCS.LT.3*( N - 1 )*K ) THEN + INFO = -14 + ELSE IF ( LDWORK.LT.MAX( 1, ( N - 1 )*K ) ) THEN + DWORK(1) = MAX( 1, ( N - 1 )*K ) + INFO = -16 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02CD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( K, N ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + MAXWRK = 1 + IF ( ISROW ) THEN +C +C T is the first block row of a block Toeplitz matrix. +C Bring T to proper form by triangularizing its first block. +C + CALL DPOTRF( 'Upper', K, T, LDT, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + IF ( N.GT.1 ) + $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, + $ (N-1)*K, ONE, T, LDT, T(1,K+1), LDT ) +C +C Initialize the output matrices. +C + IF ( COMPG ) THEN + CALL DLASET( 'All', 2*K, N*K, ZERO, ZERO, G, LDG ) + CALL DLASET( 'All', 1, K, ONE, ONE, G(K+1,1), LDG+1 ) + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, K, + $ ONE, T, LDT, G(K+1,1), LDG ) + IF ( N.GT.1 ) + $ CALL DLACPY( 'Upper', K, (N-1)*K, T, LDT, G(K+1,K+1), + $ LDG ) + CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, G, LDG ) + END IF +C + IF ( COMPL ) THEN + CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, L, LDL ) + END IF +C + IF ( COMPR ) THEN + CALL DLACPY( 'Upper', K, N*K, T, LDT, R, LDR ) + END IF +C +C Processing the generator. +C + IF ( COMPG ) THEN +C +C Here we use G as working array for holding the generator. +C T contains the second row of the generator. +C G contains in its first block row the second row of the +C inverse generator. +C The second block row of G is partitioned as follows: +C +C [ First block of the inverse generator, ... +C First row of the generator, ... +C The rest of the blocks of the inverse generator ] +C +C The reason for the odd partitioning is that the first block +C of the inverse generator will be thrown out at the end and +C we want to avoid reordering. +C +C (N-1)*K locations of DWORK are used by SLICOT Library +C routine MB02CY. +C + DO 10 I = 2, N + STARTR = ( I - 1 )*K + 1 + STARTI = ( N - I + 1 )*K + 1 + STARTT = 3*( I - 2 )*K + 1 +C +C Transformations acting on the generator: +C + CALL MB02CX( 'Row', K, K, K, G(K+1,K+1), LDG, + $ T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) +C + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + IF ( N.GT.I ) THEN + CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K, + $ G(K+1,2*K+1), LDG, T(1,STARTR+K), LDT, + $ T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + END IF +C + IF ( COMPR ) THEN + CALL DLACPY( 'Upper', K, (N-I+1)*K, G(K+1,K+1), LDG, + $ R(STARTR,STARTR), LDR) + END IF +C +C Transformations acting on the inverse generator: +C + CALL DLASET( 'All', K, K, ZERO, ZERO, G(K+1,STARTI), + $ LDG ) + CALL MB02CY( 'Row', 'Triangular', K, K, K, K, G(K+1,1), + $ LDG, G(1,STARTR), LDG, T(1,STARTR), LDT, + $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + CALL MB02CY( 'Row', 'NoStructure', K, K, (I-1)*K, K, + $ G(K+1,STARTI), LDG, G, LDG, T(1,STARTR), + $ LDT, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + IF ( COMPL ) THEN + CALL DLACPY( 'All', K, (I-1)*K, G(K+1,STARTI), LDG, + $ L(STARTR,1), LDL ) + CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, + $ L(STARTR,(I-1)*K+1), LDL ) + END IF + 10 CONTINUE +C + ELSE +C +C Here R is used as working array for holding the generator. +C Again, T contains the second row of the generator. +C The current row of R contains the first row of the +C generator. +C + IF ( N.GT.1 ) + $ CALL DLACPY( 'Upper', K, (N-1)*K, T, LDT, R(K+1,K+1), + $ LDR ) +C + DO 20 I = 2, N + STARTR = ( I - 1 )*K + 1 + STARTT = 3*( I - 2 )*K + 1 + CALL MB02CX( 'Row', K, K, K, R(STARTR,STARTR), LDR, + $ T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + IF ( N.GT.I ) THEN + CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K, + $ R(STARTR,STARTR+K), LDR, T(1,STARTR+K), + $ LDT, T(1,STARTR), LDT, CS(STARTT), 3*K, + $ DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + CALL DLACPY( 'Upper', K, (N-I)*K, R(STARTR,STARTR), + $ LDR, R(STARTR+K,STARTR+K), LDR ) + END IF + 20 CONTINUE +C + END IF +C + ELSE +C +C T is the first block column of a block Toeplitz matrix. +C Bring T to proper form by triangularizing its first block. +C + CALL DPOTRF( 'Lower', K, T, LDT, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + IF ( N.GT.1 ) + $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', + $ (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT ) +C +C Initialize the output matrices. +C + IF ( COMPG ) THEN + CALL DLASET( 'All', N*K, 2*K, ZERO, ZERO, G, LDG ) + CALL DLASET( 'All', 1, K, ONE, ONE, G(1,K+1), LDG+1 ) + CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', K, K, + $ ONE, T, LDT, G(1,K+1), LDG ) + IF ( N.GT.1 ) + $ CALL DLACPY( 'Lower', (N-1)*K, K, T, LDT, G(K+1,K+1), + $ LDG ) + CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, G, LDG ) + END IF +C + IF ( COMPL ) THEN + CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, L, LDL ) + END IF +C + IF ( COMPR ) THEN + CALL DLACPY( 'Lower', N*K, K, T, LDT, R, LDR ) + END IF +C +C Processing the generator. +C + IF ( COMPG ) THEN +C +C Here we use G as working array for holding the generator. +C T contains the second column of the generator. +C G contains in its first block column the second column of +C the inverse generator. +C The second block column of G is partitioned as follows: +C +C [ First block of the inverse generator; ... +C First column of the generator; ... +C The rest of the blocks of the inverse generator ] +C +C The reason for the odd partitioning is that the first block +C of the inverse generator will be thrown out at the end and +C we want to avoid reordering. +C +C (N-1)*K locations of DWORK are used by SLICOT Library +C routine MB02CY. +C + DO 30 I = 2, N + STARTR = ( I - 1 )*K + 1 + STARTI = ( N - I + 1 )*K + 1 + STARTT = 3*( I - 2 )*K + 1 +C +C Transformations acting on the generator: +C + CALL MB02CX( 'Column', K, K, K, G(K+1,K+1), LDG, + $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) +C + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + IF ( N.GT.I ) THEN + CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K, + $ K, G(2*K+1,K+1), LDG, T(STARTR+K,1), LDT, + $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + END IF +C + IF ( COMPR ) THEN + CALL DLACPY( 'Lower', (N-I+1)*K, K, G(K+1,K+1), LDG, + $ R(STARTR,STARTR), LDR) + END IF +C +C Transformations acting on the inverse generator: +C + CALL DLASET( 'All', K, K, ZERO, ZERO, G(STARTI,K+1), + $ LDG ) + CALL MB02CY( 'Column', 'Triangular', K, K, K, K, + $ G(1,K+1), LDG, G(STARTR,1), LDG, + $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + CALL MB02CY( 'Column', 'NoStructure', K, K, (I-1)*K, K, + $ G(STARTI,K+1), LDG, G, LDG, T(STARTR,1), + $ LDT, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + IF ( COMPL ) THEN + CALL DLACPY( 'All', (I-1)*K, K, G(STARTI,K+1), LDG, + $ L(1,STARTR), LDL ) + CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, + $ L((I-1)*K+1,STARTR), LDL ) + END IF + 30 CONTINUE +C + ELSE +C +C Here R is used as working array for holding the generator. +C Again, T contains the second column of the generator. +C The current column of R contains the first column of the +C generator. +C + IF ( N.GT.1 ) + $ CALL DLACPY( 'Lower', (N-1)*K, K, T, LDT, R(K+1,K+1), + $ LDR ) +C + DO 40 I = 2, N + STARTR = ( I - 1 )*K + 1 + STARTT = 3*( I - 2 )*K + 1 + CALL MB02CX( 'Column', K, K, K, R(STARTR,STARTR), LDR, + $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + IF ( N.GT.I ) THEN + CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K, + $ K, R(STARTR+K,STARTR), LDR, + $ T(STARTR+K,1), LDT, T(STARTR,1), LDT, + $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + CALL DLACPY( 'Lower', (N-I)*K, K, R(STARTR,STARTR), + $ LDR, R(STARTR+K,STARTR+K), LDR ) + END IF + 40 CONTINUE +C + END IF + END IF +C + DWORK(1) = MAXWRK +C + RETURN +C +C *** Last line of MB02CD *** + END diff --git a/mex/sources/libslicot/MB02CU.f b/mex/sources/libslicot/MB02CU.f new file mode 100644 index 000000000..38bddf38f --- /dev/null +++ b/mex/sources/libslicot/MB02CU.f @@ -0,0 +1,1015 @@ + SUBROUTINE MB02CU( TYPEG, K, P, Q, NB, A1, LDA1, A2, LDA2, B, LDB, + $ RNK, IPVT, CS, TOL, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To bring the first blocks of a generator to proper form. +C The positive part of the generator is contained in the arrays A1 +C and A2. The negative part of the generator is contained in B. +C Transformation information will be stored and can be applied +C via SLICOT Library routine MB02CV. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPEG CHARACTER*1 +C Specifies the type of the generator, as follows: +C = 'D': generator is column oriented and rank +C deficiencies are expected; +C = 'C': generator is column oriented and rank +C deficiencies are not expected; +C = 'R': generator is row oriented and rank +C deficiencies are not expected. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows in A1 to be processed. K >= 0. +C +C P (input) INTEGER +C The number of columns of the positive generator. P >= K. +C +C Q (input) INTEGER +C The number of columns in B containing the negative +C generators. +C If TYPEG = 'D', Q >= K; +C If TYPEG = 'C' or 'R', Q >= 0. +C +C NB (input) INTEGER +C On entry, if TYPEG = 'C' or TYPEG = 'R', NB specifies +C the block size to be used in the blocked parts of the +C algorithm. If NB <= 0, an unblocked algorithm is used. +C +C A1 (input/output) DOUBLE PRECISION array, dimension +C (LDA1, K) +C On entry, the leading K-by-K part of this array must +C contain the leading submatrix of the positive part of the +C generator. If TYPEG = 'C', A1 is assumed to be lower +C triangular and the strictly upper triangular part is not +C referenced. If TYPEG = 'R', A1 is assumed to be upper +C triangular and the strictly lower triangular part is not +C referenced. +C On exit, if TYPEG = 'D', the leading K-by-RNK part of this +C array contains the lower trapezoidal part of the proper +C generator and information for the Householder +C transformations applied during the reduction process. +C On exit, if TYPEG = 'C', the leading K-by-K part of this +C array contains the leading lower triangular part of the +C proper generator. +C On exit, if TYPEG = 'R', the leading K-by-K part of this +C array contains the leading upper triangular part of the +C proper generator. +C +C LDA1 INTEGER +C The leading dimension of the array A1. LDA1 >= MAX(1,K). +C +C A2 (input/output) DOUBLE PRECISION array, +C if TYPEG = 'D' or TYPEG = 'C', dimension (LDA2, P-K); +C if TYPEG = 'R', dimension (LDA2, K). +C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading +C K-by-(P-K) part of this array must contain the (K+1)-st +C to P-th columns of the positive part of the generator. +C On entry, if TYPEG = 'R', the leading (P-K)-by-K part of +C this array must contain the (K+1)-st to P-th rows of the +C positive part of the generator. +C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading +C K-by-(P-K) part of this array contains information for +C Householder transformations. +C On exit, if TYPEG = 'R', the leading (P-K)-by-K part of +C this array contains information for Householder +C transformations. +C +C LDA2 INTEGER +C The leading dimension of the array A2. +C If P = K, LDA2 >= 1; +C If P > K and (TYPEG = 'D' or TYPEG = 'C'), +C LDA2 >= MAX(1,K); +C if P > K and TYPEG = 'R', LDA2 >= P-K. +C +C B (input/output) DOUBLE PRECISION array, +C if TYPEG = 'D' or TYPEG = 'C', dimension (LDB, Q); +C if TYPEG = 'R', dimension (LDB, K). +C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading +C K-by-Q part of this array must contain the negative part +C of the generator. +C On entry, if TYPEG = 'R', the leading Q-by-K part of this +C array must contain the negative part of the generator. +C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading +C K-by-Q part of this array contains information for +C Householder transformations. +C On exit, if TYPEG = 'R', the leading Q-by-K part of this +C array contains information for Householder transformations. +C +C LDB INTEGER +C The leading dimension of the array B. +C If Q = 0, LDB >= 1; +C if Q > 0 and (TYPEG = 'D' or TYPEG = 'C'), +C LDB >= MAX(1,K); +C if Q > 0 and TYPEG = 'R', LDB >= Q. +C +C RNK (output) INTEGER +C If TYPEG = 'D', the number of columns in the reduced +C generator which are found to be linearly independent. +C If TYPEG = 'C' or TYPEG = 'R', then RNK is not set. +C +C IPVT (output) INTEGER array, dimension (K) +C If TYPEG = 'D', then if IPVT(i) = k, the k-th row of the +C proper generator is the reduced i-th row of the input +C generator. +C If TYPEG = 'C' or TYPEG = 'R', this array is not +C referenced. +C +C CS (output) DOUBLE PRECISION array, dimension (x) +C If TYPEG = 'D' and P = K, x = 3*K; +C if TYPEG = 'D' and P > K, x = 5*K; +C if (TYPEG = 'C' or TYPEG = 'R') and P = K, x = 4*K; +C if (TYPEG = 'C' or TYPEG = 'R') and P > K, x = 6*K. +C On exit, the first x elements of this array contain +C necessary information for the SLICOT library routine +C MB02CV (Givens and modified hyperbolic rotation +C parameters, scalar factors of the Householder +C transformations). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If TYPEG = 'D', this number specifies the used tolerance +C for handling deficiencies. If the hyperbolic norm +C of two diagonal elements in the positive and negative +C generators appears to be less than or equal to TOL, then +C the corresponding columns are not reduced. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = -17, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,4*K), if TYPEG = 'D'; +C LDWORK >= MAX(1,MAX(NB,1)*K), if TYPEG = 'C' or 'R'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if TYPEG = 'D', the generator represents a +C (numerically) indefinite matrix; and if TYPEG = 'C' +C or TYPEG = 'R', the generator represents a +C (numerically) semidefinite matrix. +C +C METHOD +C +C If TYPEG = 'C' or TYPEG = 'R', blocked Householder transformations +C and modified hyperbolic rotations are used to downdate the +C matrix [ A1 A2 sqrt(-1)*B ], cf. [1], [2]. +C If TYPEG = 'D', then an algorithm with row pivoting is used. In +C the first stage it maximizes the hyperbolic norm of the active +C row. As soon as the hyperbolic norm is below the threshold TOL, +C the strategy is changed. Now, in the second stage, the algorithm +C applies an LQ decomposition with row pivoting on B such that +C the Euclidean norm of the active row is maximized. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0(K *( P + Q )) floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001. +C D. Kressner, Technical Univ. Berlin, Germany, July 2002. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, P05 + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D0 ) +C .. Scalar Arguments .. + CHARACTER TYPEG + INTEGER INFO, K, LDA1, LDA2, LDB, LDWORK, NB, P, Q, RNK + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IPVT(*) + DOUBLE PRECISION A1(LDA1,*), A2(LDA2,*), B(LDB,*), CS(*), + $ DWORK(*) +C .. Local Scalars .. + LOGICAL LCOL, LRDEF + INTEGER COL2, I, IB, IERR, IMAX, ITEMP, J, JJ, LEN, + $ NBL, PDW, PHV, POS, PST2, PVT, WRKMIN + DOUBLE PRECISION ALPHA, ALPHA2, BETA, C, DMAX, S, TAU1, TAU2, + $ TEMP, TEMP2 +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAPY2, DNRM2 + EXTERNAL IDAMAX, DLAPY2, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DGELQ2, DGEQR2, DLARF, DLARFB, DLARFG, + $ DLARFT, DLARTG, DROT, DSCAL, DSWAP, MA02FD, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SIGN, SQRT +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + COL2 = P - K + LRDEF = LSAME( TYPEG, 'D' ) + LCOL = LSAME( TYPEG, 'C' ) + IF ( LRDEF ) THEN + WRKMIN = MAX( 1, 4*K ) + ELSE + WRKMIN = MAX( 1, NB*K, K ) + END IF +C +C Check the scalar input parameters. +C + IF ( .NOT.( LCOL .OR. LRDEF .OR. LSAME( TYPEG, 'R' ) ) ) THEN + INFO = -1 + ELSE IF ( K.LT.0 ) THEN + INFO = -2 + ELSE IF ( P.LT.K ) THEN + INFO = -3 + ELSE IF ( Q.LT.0 .OR. ( LRDEF .AND. Q.LT.K ) ) THEN + INFO = -4 + ELSE IF ( LDA1.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF ( ( ( P.EQ.K ) .AND. LDA2.LT.1 ) .OR. + $ ( ( P.GT.K ) .AND. ( LRDEF .OR. LCOL ) .AND. + $ ( LDA2.LT.MAX( 1, K ) ) ) .OR. + $ ( ( P.GT.K ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. + $ ( LDA2.LT.( P - K ) ) ) ) THEN + INFO = -9 + ELSE IF ( ( ( Q.EQ.0 ) .AND. LDB.LT.1 ) .OR. + $ ( ( Q.GT.0 ) .AND. ( LRDEF .OR. LCOL ) .AND. + $ ( LDB.LT.MAX( 1, K ) ) ) .OR. + $ ( ( Q.GT.0 ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. + $ ( LDB.LT.Q ) ) ) THEN + INFO = -11 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = -17 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02CU', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( K.EQ.0 .OR. ( .NOT.LRDEF .AND. Q.EQ.0 .AND. P.EQ.K ) ) THEN + IF ( LRDEF ) + $ RNK = 0 + RETURN + END IF +C + IF ( LRDEF ) THEN +C +C Deficient generator. +C + IF ( COL2.EQ.0 ) THEN + PST2 = 2*K + ELSE + PST2 = 4*K + END IF +C +C Initialize partial hyperbolic row norms. +C + RNK = 0 + PHV = 3*K +C + DO 10 I = 1, K + IPVT(I) = I + DWORK(I) = DNRM2( K, A1(I,1), LDA1 ) + 10 CONTINUE +C + DO 20 I = 1, K + DWORK(I) = DLAPY2( DWORK(I), + $ DNRM2( COL2, A2(I,1), LDA2 ) ) + DWORK(I+K) = DWORK(I) + 20 CONTINUE +C + PDW = 2*K +C + DO 30 I = 1, K + PDW = PDW + 1 + DWORK(PDW) = DNRM2( Q, B(I,1), LDB ) + 30 CONTINUE +C +C Compute factorization. +C + DO 90 I = 1, K +C +C Determine pivot row and swap if necessary. +C + PDW = I + ALPHA = ABS( DWORK(PDW) ) + BETA = ABS( DWORK(PDW+2*K) ) + DMAX = SIGN( SQRT( ABS( ALPHA - BETA ) )* + $ SQRT( ALPHA + BETA ), ALPHA - BETA ) + IMAX = I +C + DO 40 J = 1, K - I + PDW = PDW + 1 + ALPHA = ABS( DWORK(PDW) ) + BETA = ABS ( DWORK(PDW+2*K) ) + TEMP = SIGN( SQRT( ABS( ALPHA - BETA ) )* + $ SQRT( ALPHA + BETA ), ALPHA - BETA ) + IF ( TEMP.GT.DMAX ) THEN + IMAX = I + J + DMAX = TEMP + END IF + 40 CONTINUE +C +C Proceed with the reduction if the hyperbolic norm is +C beyond the threshold. +C + IF ( DMAX.GT.TOL ) THEN +C + PVT = IMAX + IF ( PVT.NE.I ) THEN + CALL DSWAP( K, A1(PVT,1), LDA1, A1(I,1), LDA1 ) + CALL DSWAP( COL2, A2(PVT,1), LDA2, A2(I,1), LDA2 ) + CALL DSWAP( Q, B(PVT,1), LDB, B(I,1), LDB ) + ITEMP = IPVT(PVT) + IPVT(PVT) = IPVT(I) + IPVT(I) = ITEMP + DWORK(PVT) = DWORK(I) + DWORK(K+PVT) = DWORK(K+I) + DWORK(2*K+PVT) = DWORK(2*K+I) + END IF +C +C Generate and apply elementary reflectors. +C + IF ( COL2.GT.1 ) THEN + CALL DLARFG( COL2, A2(I,1), A2(I,2), LDA2, TAU2 ) + ALPHA2 = A2(I,1) + IF ( K.GT.I ) THEN + A2(I,1) = ONE + CALL DLARF( 'Right', K-I, COL2, A2(I,1), LDA2, + $ TAU2, A2(I+1,1), LDA2, DWORK(PHV+1) ) + END IF + A2(I,1) = TAU2 + ELSE IF ( COL2.GT.0 ) THEN + ALPHA2 = A2(I,1) + A2(I,1) = ZERO + END IF +C + IF ( K.GT.I ) THEN + CALL DLARFG( K-I+1, A1(I,I), A1(I,I+1), LDA1, TAU1 ) + ALPHA = A1(I,I) + A1(I,I) = ONE + CALL DLARF( 'Right', K-I, K-I+1, A1(I,I), LDA1, TAU1, + $ A1(I+1,I), LDA1, DWORK(PHV+1) ) + CS(PST2+I) = TAU1 + ELSE + ALPHA = A1(I,I) + END IF +C + IF ( COL2.GT.0 ) THEN + TEMP = ALPHA + CALL DLARTG( TEMP, ALPHA2, C, S, ALPHA ) + IF ( K.GT.I ) + $ CALL DROT( K-I, A1(I+1,I), 1, A2(I+1,1), 1, C, S ) + CS(2*K+I*2-1) = C + CS(2*K+I*2) = S + END IF + A1(I,I) = ALPHA +C + IF ( Q.GT.1 ) THEN + CALL DLARFG( Q, B(I,1), B(I,2), LDB, TAU2 ) + BETA = B(I,1) + IF ( K.GT.I ) THEN + B(I,1) = ONE + CALL DLARF( 'Right', K-I, Q, B(I,1), LDB, TAU2, + $ B(I+1,1), LDB, DWORK(PHV+1) ) + END IF + B(I,1) = TAU2 + ELSE IF ( Q.GT.0 ) THEN + BETA = B(I,1) + B(I,1) = ZERO + ELSE + BETA = ZERO + END IF +C +C Create hyperbolic Givens rotation. +C + CALL MA02FD( A1(I,I), BETA, C, S, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: This should not happen. +C + INFO = 1 + RETURN + END IF +C +C Apply hyperbolic rotation. +C + IF ( K.GT.I ) THEN + CALL DSCAL( K-I, ONE/C, A1(I+1,I), 1 ) + CALL DAXPY( K-I, -S/C, B(I+1,1), 1, A1(I+1,I), 1 ) + CALL DSCAL( K-I, C, B(I+1,1), 1 ) + CALL DAXPY( K-I, -S, A1(I+1,I), 1, B(I+1,1), 1 ) + END IF + CS(I*2-1) = C + CS(I*2) = S +C +C Downdate the norms in A1. +C + DO 50 J = I + 1, K + TEMP = ONE - ( ABS( A1(J,I) ) / DWORK(J) )**2 + TEMP2 = ONE + P05*TEMP* + $ ( DWORK(J) / DWORK(K+J) )**2 + IF ( TEMP2.EQ.ONE ) THEN + DWORK(J) = DLAPY2( DNRM2( K-I, A1(J,I+1), LDA1 ), + $ DNRM2( COL2, A2(J,1), LDA2 ) ) + DWORK(K+J) = DWORK(J) + DWORK(2*K+J) = DNRM2( Q, B(J,1), LDB ) + ELSE + IF ( TEMP.GE.ZERO ) THEN + DWORK(J) = DWORK(J)*SQRT( TEMP ) + ELSE + DWORK(J) = -DWORK(J)*SQRT( -TEMP ) + END IF + END IF + 50 CONTINUE +C + RNK = RNK + 1 + ELSE IF ( ABS( DMAX ).LT.TOL ) THEN +C +C Displacement is positive semidefinite. +C Do an LQ decomposition with pivoting of the leftover +C negative part to find diagonal elements with almost zero +C norm. These columns cannot be removed from the +C generator. +C +C Initialize norms. +C + DO 60 J = I, K + DWORK(J) = DNRM2( Q, B(J,1), LDB ) + DWORK(J+K) = DWORK(J) + 60 CONTINUE +C + LEN = Q + POS = 1 +C + DO 80 J = I, K +C +C Generate and apply elementary reflectors. +C + PVT = ( J-1 ) + IDAMAX( K-J+1, DWORK(J), 1 ) +C +C Swap rows if necessary. +C + IF ( PVT.NE.J ) THEN + CALL DSWAP( K, A1(PVT,1), LDA1, A1(J,1), LDA1 ) + CALL DSWAP( COL2, A2(PVT,1), LDA2, A2(J,1), LDA2 ) + CALL DSWAP( Q, B(PVT,1), LDB, B(J,1), LDB ) + ITEMP = IPVT(PVT) + IPVT(PVT) = IPVT(J) + IPVT(J) = ITEMP + DWORK(PVT) = DWORK(J) + DWORK(K+PVT) = DWORK(K+J) + END IF +C +C Annihilate second part of the positive generators. +C + IF ( COL2.GT.1 ) THEN + CALL DLARFG( COL2, A2(J,1), A2(J,2), LDA2, TAU2 ) + ALPHA2 = A2(J,1) + IF ( K.GT.J ) THEN + A2(J,1) = ONE + CALL DLARF( 'Right', K-J, COL2, A2(J,1), LDA2, + $ TAU2, A2(J+1,1), LDA2, DWORK(PHV+1)) + END IF + A2(J,1) = TAU2 + ELSE IF ( COL2.GT.0 ) THEN + ALPHA2 = A2(J,1) + A2(J,1) = ZERO + END IF +C +C Transform first part of the positive generators to +C lower triangular form. +C + IF ( K.GT.J ) THEN + CALL DLARFG( K-J+1, A1(J,J), A1(J,J+1), LDA1, + $ TAU1 ) + ALPHA = A1(J,J) + A1(J,J) = ONE + CALL DLARF( 'Right', K-J, K-J+1, A1(J,J), LDA1, + $ TAU1, A1(J+1,J), LDA1, DWORK(PHV+1) ) + CS(PST2+J) = TAU1 + ELSE + ALPHA = A1(J,J) + END IF +C + IF ( COL2.GT.0 ) THEN + TEMP = ALPHA + CALL DLARTG( TEMP, ALPHA2, C, S, ALPHA ) + IF ( K.GT.J ) + $ CALL DROT( K-J, A1(J+1,J), 1, A2(J+1,1), 1, C, + $ S ) + CS(2*K+J*2-1) = C + CS(2*K+J*2) = S + END IF + A1(J,J) = ALPHA +C +C Transform negative part to lower triangular form. +C + IF ( LEN.GT.1) THEN + CALL DLARFG( LEN, B(J,POS), B(J,POS+1), LDB, TAU2 ) + BETA = B(J,POS) + IF ( K.GT.J ) THEN + B(J,POS) = ONE + CALL DLARF( 'Right', K-J, LEN, B(J,POS), LDB, + $ TAU2, B(J+1,POS), LDB, DWORK(PHV+1)) + END IF + B(J,POS) = BETA + CS(J*2-1) = TAU2 + END IF +C +C Downdate the norms of the rows in the negative part. +C + DO 70 JJ = J + 1, K + IF ( DWORK(JJ).NE.ZERO ) THEN + TEMP = ONE - ( ABS( B(JJ,POS) ) + $ / DWORK(JJ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = ONE + P05*TEMP* + $ ( DWORK(JJ) / DWORK(K+JJ) )**2 + IF ( TEMP2.EQ.ONE ) THEN + DWORK(JJ) = DNRM2( LEN-1, B(JJ,POS+1), LDB) + DWORK(K+JJ) = DWORK(JJ) + ELSE + IF ( TEMP.GE.ZERO ) THEN + DWORK(JJ) = DWORK(JJ)*SQRT( TEMP ) + ELSE + DWORK(JJ) = -DWORK(JJ)*SQRT( -TEMP ) + END IF + END IF + END IF + 70 CONTINUE +C + LEN = LEN - 1 + POS = POS + 1 + 80 CONTINUE +C + RETURN + ELSE +C +C Error return: +C +C Displacement is indefinite. +C Due to roundoff error, positive semidefiniteness is +C violated. This is a rather bad situation. There is no +C meaningful way to continue the computations from this +C point. +C + INFO = 1 + RETURN + END IF + 90 CONTINUE +C + ELSE IF ( LCOL ) THEN +C +C Column oriented and not deficient generator. +C +C Apply an LQ like hyperbolic/orthogonal blocked decomposition. +C + IF ( COL2.GT.0 ) THEN + NBL = MIN( COL2, NB ) + IF ( NBL.GT.0 ) THEN +C +C Blocked version. +C + DO 110 I = 1, K - NBL + 1, NBL + IB = MIN( K-I+1, NBL ) + CALL DGELQ2( IB, COL2, A2(I,1), LDA2, CS(4*K+I), + $ DWORK, IERR ) + IF ( I+IB.LE.K ) THEN + CALL DLARFT( 'Forward', 'Rowwise', COL2, IB, + $ A2(I,1), LDA2, CS(4*K+I), DWORK, K ) + CALL DLARFB( 'Right', 'No Transpose', 'Forward', + $ 'Rowwise', K-I-IB+1, COL2, IB, + $ A2(I,1), LDA2, DWORK, K, A2(I+IB,1), + $ LDA2, DWORK(IB+1), K ) + END IF +C +C Annihilate the remaining parts of A2. +C + DO 100 J = I, I + IB - 1 + IF ( COL2.GT.1 ) THEN + LEN = MIN( COL2, J-I+1 ) + CALL DLARFG( LEN, A2(J,1), A2(J,2), LDA2, TAU2 ) + ALPHA2 = A2(J,1) + IF ( K.GT.J ) THEN + A2(J,1) = ONE + CALL DLARF( 'Right', K-J, LEN, A2(J,1), LDA2, + $ TAU2, A2(J+1,1), LDA2, DWORK ) + END IF + A2(J,1) = TAU2 + ELSE + ALPHA2 = A2(J,1) + A2(J,1) = ZERO + END IF + ALPHA = A1(J,J) + CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) + IF ( K.GT.J ) + $ CALL DROT( K-J, A1(J+1,J), 1, A2(J+1,1), 1, C, + $ S ) + CS(2*K+J*2-1) = C + CS(2*K+J*2) = S + 100 CONTINUE +C + 110 CONTINUE +C + ELSE + I = 1 + END IF +C +C Unblocked version for the last or only block. +C + DO 120 J = I, K + IF ( COL2.GT.1 ) THEN + CALL DLARFG( COL2, A2(J,1), A2(J,2), LDA2, TAU2 ) + ALPHA2 = A2(J,1) + IF ( K.GT.J ) THEN + A2(J,1) = ONE + CALL DLARF( 'Right', K-J, COL2, A2(J,1), LDA2, + $ TAU2, A2(J+1,1), LDA2, DWORK ) + END IF + A2(J,1) = TAU2 + ELSE + ALPHA2 = A2(J,1) + A2(J,1) = ZERO + END IF + ALPHA = A1(J,J) + CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) + IF ( K.GT.J ) + $ CALL DROT( K-J, A1(J+1,J), 1, A2(J+1,1), 1, C, S ) + CS(2*K+J*2-1) = C + CS(2*K+J*2) = S + 120 CONTINUE +C + PST2 = 5*K + ELSE + PST2 = 2*K + END IF +C +C Annihilate B with hyperbolic transformations. +C + NBL = MIN( NB, Q ) + IF ( NBL.GT.0 ) THEN +C +C Blocked version. +C + DO 140 I = 1, K - NBL + 1, NBL + IB = MIN( K-I+1, NBL ) + CALL DGELQ2( IB, Q, B(I,1), LDB, CS(PST2+I), DWORK, + $ IERR ) + IF ( I+IB.LE.K ) THEN + CALL DLARFT( 'Forward', 'Rowwise', Q, IB, B(I,1), + $ LDB, CS(PST2+I), DWORK, K ) + CALL DLARFB( 'Right', 'No Transpose', 'Forward', + $ 'Rowwise', K-I-IB+1, Q, IB, B(I,1), + $ LDB, DWORK, K, B(I+IB,1), LDB, + $ DWORK( IB+1 ), K ) + END IF +C +C Annihilate the remaining parts of B. +C + DO 130 J = I, I + IB - 1 + IF ( Q.GT.1 ) THEN + CALL DLARFG( J-I+1, B(J,1), B(J,2), LDB, TAU2 ) + ALPHA2 = B(J,1) + IF ( K.GT.J ) THEN + B(J,1) = ONE + CALL DLARF( 'Right', K-J, J-I+1, B(J,1), LDB, + $ TAU2, B(J+1,1), LDB, DWORK ) + END IF + B(J,1) = TAU2 + ELSE + ALPHA2 = B(J,1) + B(J,1) = ZERO + END IF +C +C Create hyperbolic rotation. +C + CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C +C Apply hyperbolic rotation. +C + IF ( K.GT.J ) THEN + CALL DSCAL( K-J, ONE/C, A1(J+1,J), 1 ) + CALL DAXPY( K-J, -S/C, B(J+1,1), 1, A1(J+1,J), 1 ) + CALL DSCAL( K-J, C, B(J+1,1), 1 ) + CALL DAXPY( K-J, -S, A1(J+1,J), 1, B(J+1,1), 1 ) + END IF + CS(J*2-1) = C + CS(J*2) = S + 130 CONTINUE +C + 140 CONTINUE +C + ELSE + I = 1 + END IF +C +C Unblocked version for the last or only block. +C + DO 150 J = I, K + IF ( Q.GT.1 ) THEN + CALL DLARFG( Q, B(J,1), B(J,2), LDB, TAU2 ) + ALPHA2 = B(J,1) + IF ( K.GT.J ) THEN + B(J,1) = ONE + CALL DLARF( 'Right', K-J, Q, B(J,1), LDB, TAU2, + $ B(J+1,1), LDB, DWORK ) + END IF + B(J,1) = TAU2 + ELSE IF ( Q.GT.0 ) THEN + ALPHA2 = B(J,1) + B(J,1) = ZERO + END IF + IF ( Q.GT.0 ) THEN +C +C Create hyperbolic rotation. +C + CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C +C Apply hyperbolic rotation. +C + IF ( K.GT.J ) THEN + CALL DSCAL( K-J, ONE/C, A1(J+1,J), 1 ) + CALL DAXPY( K-J, -S/C, B(J+1,1), 1, A1(J+1,J), 1 ) + CALL DSCAL( K-J, C, B(J+1,1), 1 ) + CALL DAXPY( K-J, -S, A1(J+1,J), 1, B(J+1,1), 1 ) + END IF + CS(J*2-1) = C + CS(J*2) = S + END IF + 150 CONTINUE +C + ELSE +C +C Row oriented and not deficient generator. +C + IF ( COL2.GT.0 ) THEN + NBL = MIN( NB, COL2 ) + IF ( NBL.GT.0 ) THEN +C +C Blocked version. +C + DO 170 I = 1, K - NBL + 1, NBL + IB = MIN( K-I+1, NBL ) + CALL DGEQR2( COL2, IB, A2(1,I), LDA2, CS(4*K+I), + $ DWORK, IERR ) + IF ( I+IB.LE.K ) THEN + CALL DLARFT( 'Forward', 'Columnwise', COL2, IB, + $ A2(1,I), LDA2, CS(4*K+I), DWORK, K ) + CALL DLARFB( 'Left', 'Transpose', 'Forward', + $ 'Columnwise', COL2, K-I-IB+1, IB, + $ A2(1,I), LDA2, DWORK, K, A2(1,I+IB), + $ LDA2, DWORK(IB+1), K ) + END IF +C +C Annihilate the remaining parts of A2. +C + DO 160 J = I, I + IB - 1 + IF ( COL2.GT.1 ) THEN + LEN = MIN( COL2, J-I+1 ) + CALL DLARFG( LEN, A2(1,J), A2(2,J), 1, TAU2 ) + ALPHA2 = A2(1,J) + IF ( K.GT.J ) THEN + A2(1,J) = ONE + CALL DLARF( 'Left', LEN, K-J, A2(1,J), 1, + $ TAU2, A2(1,J+1), LDA2, DWORK ) + END IF + A2(1,J) = TAU2 + ELSE + ALPHA2 = A2(1,J) + A2(1,J) = ZERO + END IF + ALPHA = A1(J,J) + CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) + IF ( K.GT.J ) + $ CALL DROT( K-J, A1(J,J+1), LDA1, A2(1,J+1), + $ LDA2, C, S ) + CS(2*K+J*2-1) = C + CS(2*K+J*2) = S + 160 CONTINUE +C + 170 CONTINUE +C + ELSE + I = 1 + END IF +C +C Unblocked version for the last or only block. +C + DO 180 J = I, K + IF ( COL2.GT.1 ) THEN + CALL DLARFG( COL2, A2(1,J), A2(2,J), 1, TAU2 ) + ALPHA2 = A2(1,J) + IF ( K.GT.J ) THEN + A2(1,J) = ONE + CALL DLARF( 'Left', COL2, K-J, A2(1,J), 1, TAU2, + $ A2(1,J+1), LDA2, DWORK ) + END IF + A2(1,J) = TAU2 + ELSE + ALPHA2 = A2(1,J) + A2(1,J) = ZERO + END IF + ALPHA = A1(J,J) + CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) + IF ( K.GT.J ) + $ CALL DROT( K-J, A1(J,J+1), LDA1, A2(1,J+1), LDA2, C, + $ S ) + CS(2*K+J*2-1) = C + CS(2*K+J*2) = S + 180 CONTINUE +C + PST2 = 5*K + ELSE + PST2 = 2*K + END IF +C +C Annihilate B with hyperbolic transformations. +C + NBL = MIN( NB, Q ) + IF ( NBL.GT.0 ) THEN +C +C Blocked version. +C + DO 200 I = 1, K - NBL + 1, NBL + IB = MIN( K-I+1, NBL ) + CALL DGEQR2( Q, IB, B(1,I), LDB, CS(PST2+I), DWORK, + $ IERR ) + IF ( I+IB.LE.K ) THEN + CALL DLARFT( 'Forward', 'Columnwise', Q, IB, B(1,I), + $ LDB, CS(PST2+I), DWORK, K ) + CALL DLARFB( 'Left', 'Transpose', 'Forward', + $ 'Columnwise', Q, K-I-IB+1, IB, B(1,I), + $ LDB, DWORK, K, B(1,I+IB), LDB, + $ DWORK( IB+1 ), K ) + END IF +C +C Annihilate the remaining parts of B. +C + DO 190 J = I, I + IB - 1 + IF ( Q.GT.1 ) THEN + CALL DLARFG( J-I+1, B(1,J), B(2,J), 1, TAU2 ) + ALPHA2 = B(1,J) + IF ( K.GT.J ) THEN + B(1,J) = ONE + CALL DLARF( 'Left', J-I+1, K-J, B(1,J), 1, + $ TAU2, B(1,J+1), LDB, DWORK ) + END IF + B(1,J) = TAU2 + ELSE + ALPHA2 = B(1,J) + B(1,J) = ZERO + END IF +C +C Create hyperbolic rotation. +C + CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C +C Apply hyperbolic rotation. +C + IF ( K.GT.J ) THEN + CALL DSCAL( K-J, ONE/C, A1(J,J+1), LDA1 ) + CALL DAXPY( K-J, -S/C, B(1,J+1), LDB, A1(J,J+1), + $ LDA1 ) + CALL DSCAL( K-J, C, B(1,J+1), LDB ) + CALL DAXPY( K-J, -S, A1(J,J+1), LDA1, B(1,J+1), + $ LDB ) + END IF + CS(J*2-1) = C + CS(J*2) = S + 190 CONTINUE +C + 200 CONTINUE +C + ELSE + I = 1 + END IF +C +C Unblocked version for the last or only block. +C + DO 210 J = I, K + IF ( Q.GT.1 ) THEN + CALL DLARFG( Q, B(1,J), B(2,J), 1, TAU2 ) + ALPHA2 = B(1,J) + IF ( K.GT.J ) THEN + B(1,J) = ONE + CALL DLARF( 'Left', Q, K-J, B(1,J), 1, TAU2, + $ B(1,J+1), LDB, DWORK ) + END IF + B(1,J) = TAU2 + ELSE IF ( Q.GT.0 ) THEN + ALPHA2 = B(1,J) + B(1,J) = ZERO + END IF + IF ( Q.GT.0 ) THEN +C +C Create hyperbolic rotation. +C + CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C +C Apply hyperbolic rotation. +C + IF ( K.GT.J ) THEN + CALL DSCAL( K-J, ONE/C, A1(J,J+1), LDA1 ) + CALL DAXPY( K-J, -S/C, B(1,J+1), LDB, A1(J,J+1), LDA1 + $ ) + CALL DSCAL( K-J, C, B(1,J+1), LDB ) + CALL DAXPY( K-J, -S, A1(J,J+1), LDA1, B(1,J+1), LDB + $ ) + END IF + CS(J*2-1) = C + CS(J*2) = S + END IF + 210 CONTINUE +C + END IF +C +C *** Last line of MB02CU *** + END diff --git a/mex/sources/libslicot/MB02CV.f b/mex/sources/libslicot/MB02CV.f new file mode 100644 index 000000000..f049fca50 --- /dev/null +++ b/mex/sources/libslicot/MB02CV.f @@ -0,0 +1,795 @@ + SUBROUTINE MB02CV( TYPEG, STRUCG, K, N, P, Q, NB, RNK, A1, LDA1, + $ A2, LDA2, B, LDB, F1, LDF1, F2, LDF2, G, LDG, + $ CS, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply the transformations created by the SLICOT Library routine +C MB02CU on other columns / rows of the generator, contained in the +C arrays F1, F2 and G. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPEG CHARACTER*1 +C Specifies the type of the generator, as follows: +C = 'D': generator is column oriented and rank +C deficient; +C = 'C': generator is column oriented and not rank +C deficient; +C = 'R': generator is row oriented and not rank +C deficient. +C Note that this parameter must be equivalent with the +C used TYPEG in the call of MB02CU. +C +C STRUCG CHARACTER*1 +C Information about the structure of the generators, +C as follows: +C = 'T': the trailing block of the positive generator +C is upper / lower triangular, and the trailing +C block of the negative generator is zero; +C = 'N': no special structure to mention. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows in A1 to be processed. K >= 0. +C +C N (input) INTEGER +C If TYPEG = 'D' or TYPEG = 'C', the number of rows in F1; +C if TYPEG = 'R', the number of columns in F1. N >= 0. +C +C P (input) INTEGER +C The number of columns of the positive generator. P >= K. +C +C Q (input) INTEGER +C The number of columns in B. +C If TYPEG = 'D', Q >= K; +C If TYPEG = 'C' or 'R', Q >= 0. +C +C NB (input) INTEGER +C On entry, if TYPEG = 'C' or TYPEG = 'R', NB specifies +C the block size to be used in the blocked parts of the +C algorithm. NB must be equivalent with the used block size +C in the routine MB02CU. +C +C RNK (input) INTEGER +C If TYPEG = 'D', the number of linearly independent columns +C in the generator as returned by MB02CU. 0 <= RNK <= K. +C If TYPEG = 'C' or 'R', the value of this parameter is +C irrelevant. +C +C A1 (input) DOUBLE PRECISION array, dimension +C (LDA1, K) +C On entry, if TYPEG = 'D', the leading K-by-K part of this +C array must contain the matrix A1 as returned by MB02CU. +C If TYPEG = 'C' or 'R', this array is not referenced. +C +C LDA1 INTEGER +C The leading dimension of the array A1. +C If TYPEG = 'D', LDA1 >= MAX(1,K); +C if TYPEG = 'C' or TYPEG = 'R', LDA1 >= 1. +C +C A2 (input) DOUBLE PRECISION array, +C if TYPEG = 'D' or TYPEG = 'C', dimension (LDA2, P-K); +C if TYPEG = 'R', dimension (LDA2, K). +C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading +C K-by-(P-K) part of this array must contain the matrix +C A2 as returned by MB02CU. +C On entry, if TYPEG = 'R', the leading (P-K)-by-K part of +C this array must contain the matrix A2 as returned by +C MB02CU. +C +C LDA2 INTEGER +C The leading dimension of the array A2. +C If P = K, LDA2 >= 1; +C If P > K and (TYPEG = 'D' or TYPEG = 'C'), +C LDA2 >= MAX(1,K); +C if P > K and TYPEG = 'R', LDA2 >= P-K. +C +C B (input) DOUBLE PRECISION array, +C if TYPEG = 'D' or TYPEG = 'C', dimension (LDB, Q); +C if TYPEG = 'R', dimension (LDB, K). +C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading +C K-by-Q part of this array must contain the matrix B as +C returned by MB02CU. +C On entry, if TYPEG = 'R', the leading Q-by-K part of this +C array must contain the matrix B as returned by MB02CU. +C +C LDB INTEGER +C The leading dimension of the array B. +C If Q = 0, LDB >= 1; +C If Q > 0 and (TYPEG = 'D' or TYPEG = 'C'), +C LDB >= MAX(1,K); +C if Q > 0 and TYPEG = 'R', LDB >= Q. +C +C F1 (input/output) DOUBLE PRECISION array, +C if TYPEG = 'D' or TYPEG = 'C', dimension (LDF1, K); +C if TYPEG = 'R', dimension (LDF1, N). +C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading +C N-by-K part of this array must contain the first part +C of the positive generator to be processed. +C On entry, if TYPEG = 'R', the leading K-by-N part of this +C array must contain the first part of the positive +C generator to be processed. +C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading +C N-by-K part of this array contains the first part of the +C transformed positive generator. +C On exit, if TYPEG = 'R', the leading K-by-N part of this +C array contains the first part of the transformed positive +C generator. +C +C LDF1 INTEGER +C The leading dimension of the array F1. +C If TYPEG = 'D' or TYPEG = 'C', LDF1 >= MAX(1,N); +C if TYPEG = 'R', LDF1 >= MAX(1,K). +C +C F2 (input/output) DOUBLE PRECISION array, +C if TYPEG = 'D' or TYPEG = 'C', dimension (LDF2, P-K); +C if TYPEG = 'R', dimension (LDF2, N). +C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading +C N-by-(P-K) part of this array must contain the second part +C of the positive generator to be processed. +C On entry, if TYPEG = 'R', the leading (P-K)-by-N part of +C this array must contain the second part of the positive +C generator to be processed. +C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading +C N-by-(P-K) part of this array contains the second part of +C the transformed positive generator. +C On exit, if TYPEG = 'R', the leading (P-K)-by-N part of +C this array contains the second part of the transformed +C positive generator. +C +C LDF2 INTEGER +C The leading dimension of the array F2. +C If P = K, LDF2 >= 1; +C If P > K and (TYPEG = 'D' or TYPEG = 'C'), +C LDF2 >= MAX(1,N); +C if P > K and TYPEG = 'R', LDF2 >= P-K. +C +C G (input/output) DOUBLE PRECISION array, +C if TYPEG = 'D' or TYPEG = 'C', dimension (LDG, Q); +C if TYPEG = 'R', dimension (LDG, N). +C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading +C N-by-Q part of this array must contain the negative part +C of the generator to be processed. +C On entry, if TYPEG = 'R', the leading Q-by-N part of this +C array must contain the negative part of the generator to +C be processed. +C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading +C N-by-Q part of this array contains the transformed +C negative generator. +C On exit, if TYPEG = 'R', the leading Q-by-N part of this +C array contains the transformed negative generator. +C +C LDG INTEGER +C The leading dimension of the array G. +C If Q = 0, LDG >= 1; +C If Q > 0 and (TYPEG = 'D' or TYPEG = 'C'), +C LDG >= MAX(1,N); +C if Q > 0 and TYPEG = 'R', LDG >= Q. +C +C CS (input) DOUBLE PRECISION array, dimension (x) +C If TYPEG = 'D' and P = K, x = 3*K; +C If TYPEG = 'D' and P > K, x = 5*K; +C If (TYPEG = 'C' or TYPEG = 'R') and P = K, x = 4*K; +C If (TYPEG = 'C' or TYPEG = 'R') and P > K, x = 6*K. +C On entry, the first x elements of this array must contain +C Givens and modified hyperbolic rotation parameters, and +C scalar factors of the Householder transformations as +C returned by MB02CU. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = -23, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C TYPEG = 'D': LDWORK >= MAX(1,N); +C (TYPEG = 'C' or TYPEG = 'R') and NB <= 0: +C LDWORK >= MAX(1,N); +C (TYPEG = 'C' or TYPEG = 'R') and NB >= 1: +C LDWORK >= MAX(1,( N + K )*NB). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0(N*K*( P + Q )) floating point operations. +C +C METHOD +C +C The Householder transformations and modified hyperbolic rotations +C computed by SLICOT Library routine MB02CU are applied to the +C corresponding parts of the matrices F1, F2 and G. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001, +C March 2004, March 2007. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + CHARACTER STRUCG, TYPEG + INTEGER INFO, K, LDA1, LDA2, LDB, LDF1, LDF2, LDG, + $ LDWORK, N, NB, P, Q, RNK +C .. Array Arguments .. + DOUBLE PRECISION A1(LDA1,*), A2(LDA2,*), B(LDB,*), CS(*), + $ DWORK(*), F1(LDF1,*), F2(LDF2,*), G(LDG,*) +C .. Local Scalars .. + INTEGER COL2, I, IB, J, JJ, LEN, NBL, POS, PST2, + $ WRKMIN + DOUBLE PRECISION ALPHA, BETA, C, S, TAU, TEMP + LOGICAL LRDEF, LTRI, LCOL +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DLARF, DLARFB, DLARFT, DROT, DSCAL, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + COL2 = MAX( 0, P - K ) + LRDEF = LSAME( TYPEG, 'D' ) + LCOL = LSAME( TYPEG, 'C' ) + LTRI = LSAME( STRUCG, 'T' ) + IF ( LRDEF ) THEN + WRKMIN = MAX( 1, N ) + ELSE + IF ( NB.GE.1 ) THEN + WRKMIN = MAX( 1, ( N + K )*NB ) + ELSE + WRKMIN = MAX( 1, N ) + END IF + END IF +C +C Check the scalar input parameters. +C + IF ( .NOT.( LCOL .OR. LRDEF .OR. LSAME( TYPEG, 'R' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( LTRI .OR. LSAME( STRUCG, 'N' ) ) ) THEN + INFO = -2 + ELSE IF ( K.LT.0 ) THEN + INFO = -3 + ELSE IF ( N.LT.0 ) THEN + INFO = -4 + ELSE IF ( P.LT.K ) THEN + INFO = -5 + ELSE IF ( Q.LT.0 .OR. ( LRDEF .AND. Q.LT.K ) ) THEN + INFO = -6 + ELSE IF ( LRDEF .AND. ( RNK.LT.0 .OR. RNK.GT.K ) ) THEN + INFO = -8 + ELSE IF ( ( LDA1.LT.1 ) .OR. ( LRDEF .AND. LDA1.LT.K ) ) THEN + INFO = -10 + ELSE IF ( ( ( P.EQ.K ) .AND. LDA2.LT.1 ) .OR. + $ ( ( P.GT.K ) .AND. ( LRDEF .OR. LCOL ) .AND. + $ ( LDA2.LT.MAX( 1, K ) ) ) .OR. + $ ( ( P.GT.K ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. + $ ( LDA2.LT.( P-K ) ) ) ) THEN + INFO = -12 + ELSE IF ( ( ( Q.EQ.0 ) .AND. LDB.LT.1 ) .OR. + $ ( ( Q.GT.0 ) .AND. ( LRDEF .OR. LCOL ) .AND. + $ ( LDB.LT.MAX( 1, K ) ) ) .OR. + $ ( ( Q.GT.0 ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. + $ ( LDB.LT.Q ) ) ) THEN + INFO = -14 + ELSE IF ( ( LRDEF .OR. LCOL ) .AND. LDF1.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF ( (.NOT.( LRDEF .OR. LCOL ) ) .AND. LDF1.LT.MAX( 1, K ) ) + $ THEN + INFO = -16 + ELSE IF ( ( ( P.EQ.K ) .AND. LDF2.LT.1 ) .OR. + $ ( ( P.GT.K ) .AND. ( LRDEF .OR. LCOL ) .AND. + $ ( LDF2.LT.MAX( 1, N ) ) ) .OR. + $ ( ( P.GT.K ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. + $ ( LDF2.LT.( P-K ) ) ) ) THEN + INFO = -18 + ELSE IF ( ( ( Q.EQ.0 ) .AND. LDG.LT.1 ) .OR. + $ ( ( Q.GT.0 ) .AND. ( LRDEF .OR. LCOL ) .AND. + $ ( LDG.LT.MAX( 1, N ) ) ) .OR. + $ ( ( Q.GT.0 ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. + $ ( LDG.LT.Q ) ) ) THEN + INFO = -20 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = -23 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02CV', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( K, N ).EQ.0 .OR. + $ ( ( .NOT.LRDEF ) .AND. Q.EQ.0 .AND. P.EQ.K ) ) THEN + RETURN + END IF +C + IF ( LRDEF ) THEN +C +C Deficient generator. +C + IF ( COL2.EQ.0 ) THEN + PST2 = 2*K + ELSE + PST2 = 4*K + END IF +C + DO 10 I = 1, RNK +C +C Apply elementary reflectors. +C + IF ( COL2.GT.1 ) THEN + TAU = A2(I,1) + A2(I,1) = ONE + CALL DLARF( 'Right', N, COL2, A2(I,1), LDA2, TAU, F2, + $ LDF2, DWORK ) + A2(I,1) = TAU + END IF +C + IF ( K.GT.I ) THEN + ALPHA = A1(I,I) + A1(I,I) = ONE + CALL DLARF( 'Right', N, K-I+1, A1(I,I), LDA1, CS(PST2+I), + $ F1(1,I), LDF1, DWORK ) + A1(I,I) = ALPHA + END IF +C + IF ( COL2.GT.0 ) THEN + C = CS(2*K+I*2-1) + S = CS(2*K+I*2) + CALL DROT( N, F1(1,I), 1, F2, 1, C, S ) + END IF +C + IF ( Q.GT.1 ) THEN + TAU = B(I,1) + B(I,1) = ONE + CALL DLARF( 'Right', N, Q, B(I,1), LDB, TAU, + $ G, LDG, DWORK ) + B(I,1) = TAU + END IF +C +C Apply hyperbolic rotation. +C + C = CS(I*2-1) + S = CS(I*2) + CALL DSCAL( N, ONE/C, F1(1,I), 1 ) + CALL DAXPY( N, -S/C, G(1,1), 1, F1(1,I), 1 ) + CALL DSCAL( N, C, G(1,1), 1 ) + CALL DAXPY( N, -S, F1(1,I), 1, G(1,1), 1 ) + 10 CONTINUE +C + LEN = Q + POS = 1 +C + DO 20 J = RNK + 1, K +C +C Apply the reductions working on singular rows. +C + IF ( COL2.GT.1 ) THEN + TAU = A2(J,1) + A2(J,1) = ONE + CALL DLARF( 'Right', N, COL2, A2(J,1), LDA2, TAU, F2, + $ LDF2, DWORK ) + A2(J,1) = TAU + END IF + IF ( K.GT.J ) THEN + ALPHA = A1(J,J) + A1(J,J) = ONE + CALL DLARF( 'Right', N, K-J+1, A1(J,J), LDA1, CS(PST2+J), + $ F1(1,J), LDF1, DWORK ) + A1(J,J) = ALPHA + END IF + IF ( COL2.GT.0 ) THEN + C = CS(2*K+J*2-1) + S = CS(2*K+J*2) + CALL DROT( N, F1(1,J), 1, F2, 1, C, S ) + END IF + IF ( LEN.GT.1 ) THEN + BETA = B(J,POS) + B(J,POS) = ONE + CALL DLARF( 'Right', N, LEN, B(J,POS), LDB, CS(J*2-1), + $ G(1,POS), LDG, DWORK ) + B(J,POS) = BETA + END IF + LEN = LEN - 1 + POS = POS + 1 + 20 CONTINUE +C + ELSE IF ( LCOL ) THEN +C +C Column oriented and not deficient generator. +C +C Apply an LQ like hyperbolic/orthogonal blocked decomposition. +C + IF ( LTRI ) THEN + LEN = MAX( N - K, 0 ) + ELSE + LEN = N + END IF + IF ( COL2.GT.0 ) THEN +C + NBL = MIN( COL2, NB ) + IF ( NBL.GT.0 ) THEN +C +C Blocked version. +C + DO 50 I = 1, K - NBL + 1, NBL + IB = MIN( K-I+1, NBL ) + CALL DLARFT( 'Forward', 'Rowwise', COL2, IB, A2(I,1), + $ LDA2, CS(4*K+I), DWORK, N+K ) + CALL DLARFB( 'Right', 'No Transpose', 'Forward', + $ 'Rowwise', LEN, COL2, IB, A2(I,1), + $ LDA2, DWORK, N+K, F2, LDF2, + $ DWORK(IB+1), N+K ) +C + DO 40 J = I, I + IB - 1 + TAU = A2(J,1) + A2(J,1) = ONE + CALL DLARF( 'Right', LEN, MIN( COL2, J-I+1 ), + $ A2(J,1), LDA2, TAU, F2, LDF2, DWORK ) + A2(J,1) = TAU + C = CS(2*K+J*2-1) + S = CS(2*K+J*2) + CALL DROT( LEN, F1(1,J), 1, F2, 1, C, S ) + IF ( LTRI ) THEN + LEN = LEN + 1 + TEMP = F1(LEN,J) + F1(LEN,J) = C*TEMP + F2(LEN,1) = -S*TEMP +C + DO 30 JJ = 2, COL2 + F2(LEN,JJ) = ZERO + 30 CONTINUE +C + END IF + 40 CONTINUE +C + 50 CONTINUE +C + ELSE + I = 1 + END IF +C +C Unblocked version for the last or only block. +C + DO 70 J = I, K + IF ( COL2.GT.1 ) THEN + TAU = A2(J,1) + A2(J,1) = ONE + CALL DLARF( 'Right', LEN, COL2, A2(J,1), LDA2, TAU, + $ F2, LDF2, DWORK ) + A2(J,1) = TAU + END IF +C + C = CS(2*K+J*2-1) + S = CS(2*K+J*2) + CALL DROT( LEN, F1(1,J), 1, F2, 1, C, S ) + IF ( LTRI ) THEN + LEN = LEN + 1 + TEMP = F1(LEN,J) + F1(LEN,J) = C*TEMP + F2(LEN,1) = -S*TEMP +C + DO 60 JJ = 2, COL2 + F2(LEN,JJ) = ZERO + 60 CONTINUE +C + END IF + 70 CONTINUE +C + PST2 = 5*K + ELSE + PST2 = 2*K + END IF +C + IF ( LTRI ) THEN + LEN = N - K + ELSE + LEN = N + END IF +C + NBL = MIN( Q, NB ) + IF ( NBL.GT.0 ) THEN +C +C Blocked version. +C + DO 100 I = 1, K - NBL + 1, NBL + IB = MIN( K-I+1, NBL ) + CALL DLARFT( 'Forward', 'Rowwise', Q, IB, B(I,1), + $ LDB, CS(PST2+I), DWORK, N+K ) + CALL DLARFB( 'Right', 'NonTranspose', 'Forward', + $ 'Rowwise', LEN, Q, IB, B(I,1), + $ LDB, DWORK, N+K, G, LDG, + $ DWORK(IB+1), N+K ) +C + DO 90 J = I, I + IB - 1 + TAU = B(J,1) + B(J,1) = ONE + CALL DLARF( 'Right', LEN, J-I+1, B(J,1), LDB, + $ TAU, G, LDG, DWORK ) + B(J,1) = TAU +C +C Apply hyperbolic rotation. +C + C = CS(J*2-1) + S = CS(J*2) + CALL DSCAL( LEN, ONE/C, F1(1,J), 1 ) + CALL DAXPY( LEN, -S/C, G, 1, F1(1,J), 1 ) + CALL DSCAL( LEN, C, G, 1 ) + CALL DAXPY( LEN, -S, F1(1,J), 1, G, 1 ) + IF ( LTRI ) THEN + LEN = LEN + 1 + G(LEN,1) = -S/C*F1(LEN,J) + F1(LEN,J) = F1(LEN,J) / C +C + DO 80 JJ = 2, Q + G(LEN,JJ) = ZERO + 80 CONTINUE +C + END IF + 90 CONTINUE +C + 100 CONTINUE +C + ELSE + I = 1 + END IF +C +C Unblocked version for the last or only block. +C + DO 120 J = I, K + IF ( Q.GT.1 ) THEN + TAU = B(J,1) + B(J,1) = ONE + CALL DLARF( 'Right', LEN, Q, B(J,1), LDB, TAU, + $ G, LDG, DWORK ) + B(J,1) = TAU + END IF + IF ( Q.GT.0 ) THEN +C +C Apply hyperbolic rotation. +C + C = CS(J*2-1) + S = CS(J*2) + CALL DSCAL( LEN, ONE/C, F1(1,J), 1 ) + CALL DAXPY( LEN, -S/C, G, 1, F1(1,J), 1 ) + CALL DSCAL( LEN, C, G, 1 ) + CALL DAXPY( LEN, -S, F1(1,J), 1, G, 1 ) + IF ( LTRI ) THEN + LEN = LEN + 1 + G(LEN,1) = -S/C*F1(LEN,J) + F1(LEN,J) = F1(LEN,J) / C +C + DO 110 JJ = 2, Q + G(LEN,JJ) = ZERO + 110 CONTINUE +C + END IF + END IF + 120 CONTINUE +C + ELSE +C +C Row oriented and not deficient generator. +C + IF ( LTRI ) THEN + LEN = MAX( N - K, 0 ) + ELSE + LEN = N + END IF +C + IF ( COL2.GT.0 ) THEN + NBL = MIN( NB, COL2 ) + IF ( NBL.GT.0 ) THEN +C +C Blocked version. +C + DO 150 I = 1, K - NBL + 1, NBL + IB = MIN( K-I+1, NBL ) + CALL DLARFT( 'Forward', 'Columnwise', COL2, IB, + $ A2(1,I), LDA2, CS(4*K+I), DWORK, N+K ) + CALL DLARFB( 'Left', 'Transpose', 'Forward', + $ 'Columnwise', COL2, LEN, IB, A2(1,I), + $ LDA2, DWORK, N+K, F2, LDF2, + $ DWORK(IB+1), N+K ) +C + DO 140 J = I, I + IB - 1 + TAU = A2(1,J) + A2(1,J) = ONE + CALL DLARF( 'Left', MIN( COL2, J-I+1 ), LEN, + $ A2(1,J), 1, TAU, F2, LDF2, DWORK ) + A2(1,J) = TAU + C = CS(2*K+J*2-1) + S = CS(2*K+J*2) + CALL DROT( LEN, F1(J,1), LDF1, F2, LDF2, C, S ) + IF ( LTRI ) THEN + LEN = LEN + 1 + TEMP = F1(J,LEN) + F1(J,LEN) = C*TEMP + F2(1,LEN) = -S*TEMP +C + DO 130 JJ = 2, COL2 + F2(JJ,LEN) = ZERO + 130 CONTINUE +C + END IF + 140 CONTINUE +C + 150 CONTINUE +C + ELSE + I = 1 + END IF +C +C Unblocked version for the last or only block. +C + DO 170 J = I, K + IF ( COL2.GT.1 ) THEN + TAU = A2(1,J) + A2(1,J) = ONE + CALL DLARF( 'Left', COL2, LEN, A2(1,J), 1, TAU, + $ F2, LDF2, DWORK ) + A2(1,J) = TAU + END IF +C + C = CS(2*K+J*2-1) + S = CS(2*K+J*2) + CALL DROT( LEN, F1(J,1), LDF1, F2, LDF2, C, S ) + IF ( LTRI ) THEN + LEN = LEN + 1 + TEMP = F1(J,LEN) + F1(J,LEN) = C*TEMP + F2(1,LEN) = -S*TEMP +C + DO 160 JJ = 2, COL2 + F2(JJ,LEN) = ZERO + 160 CONTINUE +C + END IF + 170 CONTINUE +C + PST2 = 5*K + ELSE + PST2 = 2*K + END IF +C + IF ( LTRI ) THEN + LEN = N - K + ELSE + LEN = N + END IF +C + NBL = MIN( Q, NB ) + IF ( NBL.GT.0 ) THEN +C +C Blocked version. +C + DO 200 I = 1, K - NBL + 1, NBL + IB = MIN( K-I+1, NBL ) + CALL DLARFT( 'Forward', 'Columnwise', Q, IB, B(1,I), + $ LDB, CS(PST2+I), DWORK, N+K ) + CALL DLARFB( 'Left', 'Transpose', 'Forward', + $ 'Columnwise', Q, LEN, IB, B(1,I), + $ LDB, DWORK, N+K, G, LDG, + $ DWORK(IB+1), N+K ) +C + DO 190 J = I, I + IB - 1 + TAU = B(1,J) + B(1,J) = ONE + CALL DLARF( 'Left', J-I+1, LEN, B(1,J), 1, + $ TAU, G, LDG, DWORK ) + B(1,J) = TAU +C +C Apply hyperbolic rotation. +C + C = CS(J*2-1) + S = CS(J*2) + CALL DSCAL( LEN, ONE/C, F1(J,1), LDF1 ) + CALL DAXPY( LEN, -S/C, G, LDG, F1(J,1), LDF1 ) + CALL DSCAL( LEN, C, G, LDG ) + CALL DAXPY( LEN, -S, F1(J,1), LDF1, G, LDG ) + IF ( LTRI ) THEN + LEN = LEN + 1 + G(1,LEN) = -S/C*F1(J,LEN) + F1(J,LEN) = F1(J,LEN) / C +C + DO 180 JJ = 2, Q + G(JJ,LEN) = ZERO + 180 CONTINUE +C + END IF + 190 CONTINUE +C + 200 CONTINUE +C + ELSE + I = 1 + END IF +C +C Unblocked version for the last or only block. +C + DO 220 J = I, K + IF ( Q.GT.1 ) THEN + TAU = B(1,J) + B(1,J) = ONE + CALL DLARF( 'Left', Q, LEN, B(1,J), 1, TAU, + $ G, LDG, DWORK ) + B(1,J) = TAU + END IF + IF ( Q.GT.0 ) THEN +C +C Apply hyperbolic rotation. +C + C = CS(J*2-1) + S = CS(J*2) + CALL DSCAL( LEN, ONE/C, F1(J,1), LDF1 ) + CALL DAXPY( LEN, -S/C, G, LDG, F1(J,1), LDF1 ) + CALL DSCAL( LEN, C, G, LDG ) + CALL DAXPY( LEN, -S, F1(J,1), LDF1, G, LDG ) + IF ( LTRI ) THEN + LEN = LEN + 1 + G(1,LEN) = -S/C*F1(J,LEN) + F1(J,LEN) = F1(J,LEN) / C +C + DO 210 JJ = 2, Q + G(JJ,LEN) = ZERO + 210 CONTINUE +C + END IF + END IF + 220 CONTINUE +C + END IF +C +C *** Last line of MB02CV *** + END diff --git a/mex/sources/libslicot/MB02CX.f b/mex/sources/libslicot/MB02CX.f new file mode 100644 index 000000000..be4989cbf --- /dev/null +++ b/mex/sources/libslicot/MB02CX.f @@ -0,0 +1,318 @@ + SUBROUTINE MB02CX( TYPET, P, Q, K, A, LDA, B, LDB, CS, LCS, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To bring the first blocks of a generator in proper form. +C The columns / rows of the positive and negative generators +C are contained in the arrays A and B, respectively. +C Transformation information will be stored and can be applied +C via SLICOT Library routine MB02CY. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPET CHARACTER*1 +C Specifies the type of the generator, as follows: +C = 'R': A and B are the first blocks of the rows of the +C positive and negative generators; +C = 'C': A and B are the first blocks of the columns of the +C positive and negative generators. +C Note: in the sequel, the notation x / y means that +C x corresponds to TYPET = 'R' and y corresponds to +C TYPET = 'C'. +C +C Input/Output Parameters +C +C P (input) INTEGER +C The number of rows / columns in A containing the positive +C generators. P >= 0. +C +C Q (input) INTEGER +C The number of rows / columns in B containing the negative +C generators. Q >= 0. +C +C K (input) INTEGER +C The number of columns / rows in A and B to be processed. +C Normally, the size of the first block. P >= K >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA, K) / (LDA, P) +C On entry, the leading P-by-K upper / K-by-P lower +C triangular part of this array must contain the rows / +C columns of the positive part in the first block of the +C generator. +C On exit, the leading P-by-K upper / K-by-P lower +C triangular part of this array contains the rows / columns +C of the positive part in the first block of the proper +C generator. +C The lower / upper trapezoidal part is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,P), if TYPET = 'R'; +C LDA >= MAX(1,K), if TYPET = 'C'. +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB, K) / (LDB, Q) +C On entry, the leading Q-by-K / K-by-Q part of this array +C must contain the rows / columns of the negative part in +C the first block of the generator. +C On exit, the leading Q-by-K / K-by-Q part of this array +C contains part of the necessary information for the +C Householder transformations. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,Q), if TYPET = 'R'; +C LDB >= MAX(1,K), if TYPET = 'C'. +C +C CS (output) DOUBLE PRECISION array, dimension (LCS) +C On exit, the leading 2*K + MIN(K,Q) part of this array +C contains necessary information for the SLICOT Library +C routine MB02CY (modified hyperbolic rotation parameters +C and scalar factors of the Householder transformations). +C +C LCS INTEGER +C The length of the array CS. LCS >= 2*K + MIN(K,Q). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -12, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,K). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: succesful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction algorithm failed. The matrix +C associated with the generator is not (numerically) +C positive definite. +C +C METHOD +C +C If TYPET = 'R', a QR decomposition of B is first computed. +C Then, the elements below the first row of each column i of B +C are annihilated by a Householder transformation modifying the +C first element in that column. This first element, in turn, is +C then annihilated by a modified hyperbolic rotation, acting also +C on the i-th row of A. +C +C If TYPET = 'C', an LQ decomposition of B is first computed. +C Then, the elements on the right of the first column of each row i +C of B are annihilated by a Householder transformation modifying the +C first element in that row. This first element, in turn, is +C then annihilated by a modified hyperbolic rotation, acting also +C on the i-th column of A. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 2000, +C February 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TYPET + INTEGER INFO, K, LDA, LDB, LCS, LDWORK, P, Q +C .. Array Arguments .. + DOUBLE PRECISION A(LDA, *), B(LDB, *), CS(*), DWORK(*) +C .. Local Scalars .. + LOGICAL ISROW + INTEGER I, IERR + DOUBLE PRECISION ALPHA, BETA, C, MAXWRK, S, TAU +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DGELQF, DGEQRF, DLARF, DLARFG, DSCAL, + $ MA02FD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + ISROW = LSAME( TYPET, 'R' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN + INFO = -1 + ELSE IF ( P.LT.0 ) THEN + INFO = -2 + ELSE IF ( Q.LT.0 ) THEN + INFO = -3 + ELSE IF ( K.LT.0 .OR. K.GT.P ) THEN + INFO = -4 + ELSE IF ( LDA.LT.1 .OR. ( ISROW .AND. LDA.LT.P ) .OR. + $ ( .NOT.ISROW .AND. LDA.LT.K ) ) THEN + INFO = -6 + ELSE IF ( LDB.LT.1 .OR. ( ISROW .AND. LDB.LT.Q ) .OR. + $ ( .NOT.ISROW .AND. LDB.LT.K ) ) THEN + INFO = -8 + ELSE IF ( LCS.LT.2*K + MIN( K, Q ) ) THEN + INFO = -10 + ELSE IF ( LDWORK.LT.MAX( 1, K ) ) THEN + DWORK(1) = MAX( 1, K ) + INFO = -12 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02CX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( Q, K ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + IF ( ISROW ) THEN +C +C The generator is row wise stored. +C +C Step 0: Do QR decomposition of B. +C + CALL DGEQRF ( Q, K, B, LDB, CS(2*K+1), DWORK(1), LDWORK, IERR ) + MAXWRK = DWORK(1) +C + DO 10 I = 1, K +C +C Step 1: annihilate the i-th column of B. +C + IF ( Q.GT.1 ) THEN + CALL DLARFG( MIN( I, Q ), B(1,I), B(2,I), 1, TAU ) + ALPHA = B(1,I) + B(1,I) = ONE + IF ( K.GT.I ) + $ CALL DLARF( 'Left', MIN( I, Q ), K-I, B(1,I), 1, TAU, + $ B(1,I+1), LDB, DWORK ) + B(1,I) = ALPHA + ELSE + ALPHA = B(1,I) + TAU = ZERO + END IF +C +C Step 2: annihilate the top entry of the column. +C + BETA = A(I,I) + CALL MA02FD( BETA, ALPHA, C, S, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + CS(I*2-1) = C + CS(I*2) = S + CALL DSCAL( K-I+1, ONE/C, A(I,I), LDA ) + CALL DAXPY( K-I+1, -S/C, B(1,I), LDB, A(I,I), LDA ) + CALL DSCAL( K-I+1, C, B(1,I), LDB ) + CALL DAXPY( K-I+1, -S, A(I,I), LDA, B(1,I), LDB ) + B(1,I) = TAU + 10 CONTINUE +C + ELSE +C +C The generator is column wise stored. +C +C Step 0: Do LQ decomposition of B. +C + CALL DGELQF ( K, Q, B, LDB, CS(2*K+1), DWORK(1), LDWORK, IERR ) + MAXWRK = DWORK(1) +C + DO 20 I = 1, K +C +C Step 1: annihilate the i-th row of B. +C + IF ( Q.GT.1 ) THEN + CALL DLARFG( MIN( I, Q ), B(I,1), B(I,2), LDB, TAU ) + ALPHA = B(I,1) + B(I,1) = ONE + IF ( K.GT.I ) + $ CALL DLARF( 'Right', K-I, MIN( I, Q ), B(I,1), LDB, + $ TAU, B(I+1,1), LDB, DWORK ) + B(I,1) = ALPHA + ELSE + ALPHA = B(I,1) + TAU = ZERO + END IF +C +C Step 2: annihilate the left entry of the row. +C + BETA = A(I,I) + CALL MA02FD( BETA, ALPHA, C, S, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + CS(I*2-1) = C + CS(I*2) = S + CALL DSCAL( K-I+1, ONE/C, A(I,I), 1 ) + CALL DAXPY( K-I+1, -S/C, B(I,1), 1, A(I,I), 1 ) + CALL DSCAL( K-I+1, C, B(I,1), 1 ) + CALL DAXPY( K-I+1, -S, A(I,I), 1, B(I,1), 1 ) + B(I,1) = TAU + 20 CONTINUE +C + END IF +C + DWORK(1) = MAXWRK +C + RETURN +C +C *** Last line of MB02CX *** + END diff --git a/mex/sources/libslicot/MB02CY.f b/mex/sources/libslicot/MB02CY.f new file mode 100644 index 000000000..7d977dee9 --- /dev/null +++ b/mex/sources/libslicot/MB02CY.f @@ -0,0 +1,372 @@ + SUBROUTINE MB02CY( TYPET, STRUCG, P, Q, N, K, A, LDA, B, LDB, H, + $ LDH, CS, LCS, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply the transformations created by the SLICOT Library +C routine MB02CX on other columns / rows of the generator, +C contained in the arrays A and B of positive and negative +C generators, respectively. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPET CHARACTER*1 +C Specifies the type of the generator, as follows: +C = 'R': A and B are additional columns of the generator; +C = 'C': A and B are additional rows of the generator. +C Note: in the sequel, the notation x / y means that +C x corresponds to TYPET = 'R' and y corresponds to +C TYPET = 'C'. +C +C STRUCG CHARACTER*1 +C Information about the structure of the two generators, +C as follows: +C = 'T': the trailing block of the positive generator +C is lower / upper triangular, and the trailing +C block of the negative generator is zero; +C = 'N': no special structure to mention. +C +C Input/Output Parameters +C +C P (input) INTEGER +C The number of rows / columns in A containing the positive +C generators. P >= 0. +C +C Q (input) INTEGER +C The number of rows / columns in B containing the negative +C generators. Q >= 0. +C +C N (input) INTEGER +C The number of columns / rows in A and B to be processed. +C N >= 0. +C +C K (input) INTEGER +C The number of columns / rows in H. P >= K >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA, N) / (LDA, P) +C On entry, the leading P-by-N / N-by-P part of this array +C must contain the positive part of the generator. +C On exit, the leading P-by-N / N-by-P part of this array +C contains the transformed positive part of the generator. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,P), if TYPET = 'R'; +C LDA >= MAX(1,N), if TYPET = 'C'. +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB, N) / (LDB, Q) +C On entry, the leading Q-by-N / N-by-Q part of this array +C must contain the negative part of the generator. +C On exit, the leading Q-by-N / N-by-Q part of this array +C contains the transformed negative part of the generator. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,Q), if TYPET = 'R'; +C LDB >= MAX(1,N), if TYPET = 'C'. +C +C H (input) DOUBLE PRECISION array, dimension +C (LDH, K) / (LDH, Q) +C The leading Q-by-K / K-by-Q part of this array must +C contain part of the necessary information for the +C Householder transformations computed by SLICOT Library +C routine MB02CX. +C +C LDH INTEGER +C The leading dimension of the array H. +C LDH >= MAX(1,Q), if TYPET = 'R'; +C LDH >= MAX(1,K), if TYPET = 'C'. +C +C CS (input) DOUBLE PRECISION array, dimension (LCS) +C The leading 2*K + MIN(K,Q) part of this array must +C contain the necessary information for modified hyperbolic +C rotations and the scalar factors of the Householder +C transformations computed by SLICOT Library routine MB02CX. +C +C LCS INTEGER +C The length of the array CS. LCS >= 2*K + MIN(K,Q). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -16, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: succesful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The Householder transformations and modified hyperbolic rotations +C computed by SLICOT Library routine MB02CX are applied to the +C corresponding parts of the matrices A and B. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 2000, +C February 2004, March 2007. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, K, LDA, LDB, LCS, LDH, LDWORK, N, P, Q + CHARACTER STRUCG, TYPET +C .. Array Arguments .. + DOUBLE PRECISION A(LDA, *), B(LDB, *), CS(*), DWORK(*), H(LDH,*) +C .. Local Scalars .. + LOGICAL ISLWR, ISROW + INTEGER I, IERR, CI, MAXWRK + DOUBLE PRECISION C, S, TAU +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DLARF, DLASET, DORMLQ, DORMQR, DSCAL, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + ISROW = LSAME( TYPET, 'R' ) + ISLWR = LSAME( STRUCG, 'T' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( ISLWR .OR. LSAME( STRUCG, 'N' ) ) ) THEN + INFO = -2 + ELSE IF ( P.LT.0 ) THEN + INFO = -3 + ELSE IF ( Q.LT.0 ) THEN + INFO = -4 + ELSE IF ( N.LT.0 ) THEN + INFO = -5 + ELSE IF ( K.LT.0 .OR. K.GT.P ) THEN + INFO = -6 + ELSE IF ( LDA.LT.1 .OR. ( ISROW .AND. LDA.LT.P ) .OR. + $ ( .NOT.ISROW .AND. LDA.LT.N ) ) THEN + INFO = -8 + ELSE IF ( LDB.LT.1 .OR. ( ISROW .AND. LDB.LT.Q ) .OR. + $ ( .NOT.ISROW .AND. LDB.LT.N ) ) THEN + INFO = -10 + ELSE IF ( LDH.LT.1 .OR. ( ISROW .AND. LDH.LT.Q ) .OR. + $ ( .NOT.ISROW .AND. LDH.LT.K ) ) THEN + INFO = -12 + ELSE IF ( LCS.LT.2*K + MIN( K, Q ) ) THEN + INFO = -14 + ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN + DWORK(1) = MAX( 1, N ) + INFO = -16 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02CY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( N, K, Q ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Applying the transformations. +C + IF ( ISROW ) THEN +C +C The generator is row wise stored. +C + IF ( ISLWR ) THEN +C + DO 10 I = 1, K +C +C Apply Householder transformation avoiding touching of +C zero blocks. +C + CI = N - K + I - 1 + TAU = H(1,I) + H(1,I) = ONE + CALL DLARF( 'Left', MIN( I, Q ), CI, H(1,I), 1, TAU, B, + $ LDB, DWORK ) + H(1,I) = TAU +C +C Now apply the hyperbolic rotation under the assumption +C that A(I, N-K+I+1:N) and B(1, N-K+I:N) are zero. +C + C = CS(I*2-1) + S = CS(I*2) +C + CALL DSCAL( CI, ONE/C, A(I,1), LDA ) + CALL DAXPY( CI, -S/C, B(1,1), LDB, A(I,1), LDA ) + CALL DSCAL( CI, C, B(1,1), LDB ) + CALL DAXPY( CI, -S, A(I,1), LDA, B(1,1), LDB ) +C + B(1,N-K+I) = -S/C * A(I,N-K+I) + A(I,N-K+I) = ONE/C * A(I,N-K+I) +C +C All below B(1,N-K+I) should be zero. +C + IF( Q.GT.1 ) + $ CALL DLASET( 'All', Q-1, 1, ZERO, ZERO, B(2,N-K+I), + $ 1 ) + 10 CONTINUE +C + ELSE +C +C Apply the QR reduction on B. +C + CALL DORMQR( 'Left', 'Transpose', Q, N, MIN( K, Q ), H, + $ LDH, CS(2*K+1), B, LDB, DWORK, LDWORK, IERR ) + MAXWRK = DWORK(1) +C + DO 20 I = 1, K +C +C Apply Householder transformation. +C + TAU = H(1,I) + H(1,I) = ONE + CALL DLARF( 'Left', MIN( I, Q ), N, H(1,I), 1, TAU, B, + $ LDB, DWORK ) + H(1,I) = TAU +C +C Apply Hyperbolic Rotation. +C + C = CS(I*2-1) + S = CS(I*2) +C + CALL DSCAL( N, ONE/C, A(I,1), LDA ) + CALL DAXPY( N, -S/C, B(1,1), LDB, A(I,1), LDA ) + CALL DSCAL( N, C, B(1,1), LDB ) + CALL DAXPY( N, -S, A(I,1), LDA, B(1,1), LDB ) + 20 CONTINUE +C + END IF +C + ELSE +C +C The generator is column wise stored. +C + IF ( ISLWR ) THEN +C + DO 30 I = 1, K +C +C Apply Householder transformation avoiding touching zeros. +C + CI = N - K + I - 1 + TAU = H(I,1) + H(I,1) = ONE + CALL DLARF( 'Right', CI, MIN( I, Q ), H(I,1), LDH, TAU, + $ B, LDB, DWORK ) + H(I,1) = TAU +C +C Apply Hyperbolic Rotation. +C + C = CS(I*2-1) + S = CS(I*2) +C + CALL DSCAL( CI, ONE/C, A(1,I), 1 ) + CALL DAXPY( CI, -S/C, B(1,1), 1, A(1,I), 1 ) + CALL DSCAL( CI, C, B(1,1), 1 ) + CALL DAXPY( CI, -S, A(1,I), 1, B(1,1), 1 ) +C + B(N-K+I,1) = -S/C * A(N-K+I,I) + A(N-K+I,I) = ONE/C * A(N-K+I,I) +C +C All elements right behind B(N-K+I,1) should be zero. +C + IF( Q.GT.1 ) + $ CALL DLASET( 'All', 1, Q-1, ZERO, ZERO, B(N-K+I,2), + $ LDB ) + 30 CONTINUE +C + ELSE +C +C Apply the LQ reduction on B. +C + CALL DORMLQ( 'Right', 'Transpose', N, Q, MIN( K, Q ), H, + $ LDH, CS(2*K+1), B, LDB, DWORK, LDWORK, IERR ) + MAXWRK = DWORK(1) +C + DO 40 I = 1, K +C +C Apply Householder transformation. +C + TAU = H(I,1) + H(I,1) = ONE + CALL DLARF( 'Right', N, MIN( I, Q ), H(I,1), LDH, TAU, B, + $ LDB, DWORK ) + H(I,1) = TAU +C +C Apply Hyperbolic Rotation. +C + C = CS(I*2-1) + S = CS(I*2) +C + CALL DSCAL( N, ONE/C, A(1,I), 1 ) + CALL DAXPY( N, -S/C, B(1,1), 1, A(1,I), 1 ) + CALL DSCAL( N, C, B(1,1), 1 ) + CALL DAXPY( N, -S, A(1,I), 1, B(1,1), 1 ) + 40 CONTINUE +C + END IF +C + END IF +C + DWORK(1) = MAX( MAXWRK, N ) +C + RETURN +C +C *** Last line of MB02CY *** + END diff --git a/mex/sources/libslicot/MB02DD.f b/mex/sources/libslicot/MB02DD.f new file mode 100644 index 000000000..fadd6b442 --- /dev/null +++ b/mex/sources/libslicot/MB02DD.f @@ -0,0 +1,564 @@ + SUBROUTINE MB02DD( JOB, TYPET, K, M, N, TA, LDTA, T, LDT, G, + $ LDG, R, LDR, L, LDL, CS, LCS, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To update the Cholesky factor and the generator and/or the +C Cholesky factor of the inverse of a symmetric positive definite +C (s.p.d.) block Toeplitz matrix T, given the information from +C a previous factorization and additional blocks in TA of its first +C block row, or its first block column, depending on the routine +C parameter TYPET. Transformation information is stored. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the output of the routine, as follows: +C = 'R': updates the generator G of the inverse and +C computes the new columns / rows for the Cholesky +C factor R of T; +C = 'A': updates the generator G, computes the new +C columns / rows for the Cholesky factor R of T and +C the new rows / columns for the Cholesky factor L +C of the inverse; +C = 'O': only computes the new columns / rows for the +C Cholesky factor R of T. +C +C TYPET CHARACTER*1 +C Specifies the type of T, as follows: +C = 'R': the first block row of an s.p.d. block Toeplitz +C matrix was/is defined; if demanded, the Cholesky +C factors R and L are upper and lower triangular, +C respectively, and G contains the transposed +C generator of the inverse; +C = 'C': the first block column of an s.p.d. block Toeplitz +C matrix was/is defined; if demanded, the Cholesky +C factors R and L are lower and upper triangular, +C respectively, and G contains the generator of the +C inverse. This choice results in a column oriented +C algorithm which is usually faster. +C Note: in this routine, the notation x / y means that +C x corresponds to TYPET = 'R' and y corresponds to +C TYPET = 'C'. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows / columns in T, which should be equal +C to the blocksize. K >= 0. +C +C M (input) INTEGER +C The number of blocks in TA. M >= 0. +C +C N (input) INTEGER +C The number of blocks in T. N >= 0. +C +C TA (input/output) DOUBLE PRECISION array, dimension +C (LDTA,M*K) / (LDTA,K) +C On entry, the leading K-by-M*K / M*K-by-K part of this +C array must contain the (N+1)-th to (N+M)-th blocks in the +C first block row / column of an s.p.d. block Toeplitz +C matrix. +C On exit, if INFO = 0, the leading K-by-M*K / M*K-by-K part +C of this array contains information on the Householder +C transformations used, such that the array +C +C [ T TA ] / [ T ] +C [ TA ] +C +C serves as the new transformation matrix T for further +C applications of this routine. +C +C LDTA INTEGER +C The leading dimension of the array TA. +C LDTA >= MAX(1,K), if TYPET = 'R'; +C LDTA >= MAX(1,M*K), if TYPET = 'C'. +C +C T (input) DOUBLE PRECISION array, dimension (LDT,N*K) / +C (LDT,K) +C The leading K-by-N*K / N*K-by-K part of this array must +C contain transformation information generated by the SLICOT +C Library routine MB02CD, i.e., in the first K-by-K block, +C the upper / lower Cholesky factor of T(1:K,1:K), and in +C the remaining part, the Householder transformations +C applied during the initial factorization process. +C +C LDT INTEGER +C The leading dimension of the array T. +C LDT >= MAX(1,K), if TYPET = 'R'; +C LDT >= MAX(1,N*K), if TYPET = 'C'. +C +C G (input/output) DOUBLE PRECISION array, dimension +C (LDG,( N + M )*K) / (LDG,2*K) +C On entry, if JOB = 'R', or 'A', then the leading +C 2*K-by-N*K / N*K-by-2*K part of this array must contain, +C in the first K-by-K block of the second block row / +C column, the lower right block of the Cholesky factor of +C the inverse of T, and in the remaining part, the generator +C of the inverse of T. +C On exit, if INFO = 0 and JOB = 'R', or 'A', then the +C leading 2*K-by-( N + M )*K / ( N + M )*K-by-2*K part of +C this array contains the same information as on entry, now +C for the updated Toeplitz matrix. Actually, to obtain a +C generator of the inverse one has to set +C G(K+1:2*K, 1:K) = 0, if TYPET = 'R'; +C G(1:K, K+1:2*K) = 0, if TYPET = 'C'. +C +C LDG INTEGER +C The leading dimension of the array G. +C LDG >= MAX(1,2*K), if TYPET = 'R' and JOB = 'R', or 'A'; +C LDG >= MAX(1,( N + M )*K), +C if TYPET = 'C' and JOB = 'R', or 'A'; +C LDG >= 1, if JOB = 'O'. +C +C R (input/output) DOUBLE PRECISION array, dimension +C (LDR,M*K) / (LDR,( N + M )*K) +C On input, the leading N*K-by-K part of R(K+1,1) / +C K-by-N*K part of R(1,K+1) contains the last block column / +C row of the previous Cholesky factor R. +C On exit, if INFO = 0, then the leading +C ( N + M )*K-by-M*K / M*K-by-( N + M )*K part of this +C array contains the last M*K columns / rows of the upper / +C lower Cholesky factor of T. The elements in the strictly +C lower / upper triangular part are not referenced. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= MAX(1, ( N + M )*K), if TYPET = 'R'; +C LDR >= MAX(1, M*K), if TYPET = 'C'. +C +C L (output) DOUBLE PRECISION array, dimension +C (LDL,( N + M )*K) / (LDL,M*K) +C If INFO = 0 and JOB = 'A', then the leading +C M*K-by-( N + M )*K / ( N + M )*K-by-M*K part of this +C array contains the last M*K rows / columns of the lower / +C upper Cholesky factor of the inverse of T. The elements +C in the strictly upper / lower triangular part are not +C referenced. +C +C LDL INTEGER +C The leading dimension of the array L. +C LDL >= MAX(1, M*K), if TYPET = 'R' and JOB = 'A'; +C LDL >= MAX(1, ( N + M )*K), if TYPET = 'C' and JOB = 'A'; +C LDL >= 1, if JOB = 'R', or 'O'. +C +C CS (input/output) DOUBLE PRECISION array, dimension (LCS) +C On input, the leading 3*(N-1)*K part of this array must +C contain the necessary information about the hyperbolic +C rotations and Householder transformations applied +C previously by SLICOT Library routine MB02CD. +C On exit, if INFO = 0, then the leading 3*(N+M-1)*K part of +C this array contains information about all the hyperbolic +C rotations and Householder transformations applied during +C the whole process. +C +C LCS INTEGER +C The length of the array CS. LCS >= 3*(N+M-1)*K. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -19, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,(N+M-1)*K). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction algorithm failed. The block Toeplitz +C matrix associated with [ T TA ] / [ T' TA' ]' is +C not (numerically) positive definite. +C +C METHOD +C +C Householder transformations and modified hyperbolic rotations +C are used in the Schur algorithm [1], [2]. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C 3 2 +C The algorithm requires 0(K ( N M + M ) ) floating point +C operations. +C +C FURTHER COMMENTS +C +C For min(K,N,M) = 0, the routine sets DWORK(1) = 1 and returns. +C Although the calculations could still be performed when N = 0, +C but min(K,M) > 0, this case is not considered as an "update". +C SLICOT Library routine MB02CD should be called with the argument +C M instead of N. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Chemnitz, Germany, December 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, +C Feb. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB, TYPET + INTEGER INFO, K, LCS, LDG, LDL, LDR, LDT, LDTA, LDWORK, + $ M, N +C .. Array Arguments .. + DOUBLE PRECISION CS(*), DWORK(*), G(LDG, *), L(LDL,*), R(LDR,*), + $ T(LDT,*), TA(LDTA,*) +C .. Local Scalars .. + INTEGER I, IERR, J, MAXWRK, STARTI, STARTR, STARTT + LOGICAL COMPG, COMPL, ISROW +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DLASET, DTRSM, MB02CX, MB02CY, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + COMPL = LSAME( JOB, 'A' ) + COMPG = LSAME( JOB, 'R' ) .OR. COMPL + ISROW = LSAME( TYPET, 'R' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( COMPG .OR. LSAME( JOB, 'O' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN + INFO = -2 + ELSE IF ( K.LT.0 ) THEN + INFO = -3 + ELSE IF ( M.LT.0 ) THEN + INFO = -4 + ELSE IF ( N.LT.0 ) THEN + INFO = -5 + ELSE IF ( LDTA.LT.1 .OR. ( ISROW .AND. LDTA.LT.K ) .OR. + $ ( .NOT.ISROW .AND. LDTA.LT.M*K ) ) THEN + INFO = -7 + ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. + $ ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN + INFO = -9 + ELSE IF ( ( COMPG .AND. ( ( ISROW .AND. LDG.LT.2*K ) + $ .OR. ( .NOT.ISROW .AND. LDG.LT.( N + M )*K ) ) ) + $ .OR. LDG.LT.1 ) THEN + INFO = -11 + ELSE IF ( ( ( ISROW .AND. LDR.LT.( N + M )*K ) .OR. + $ ( .NOT.ISROW .AND. LDR.LT.M*K ) ) .OR. + $ LDR.LT.1 ) THEN + INFO = -13 + ELSE IF ( ( COMPL .AND. ( ( ISROW .AND. LDL.LT.M*K ) + $ .OR. ( .NOT.ISROW .AND. LDL.LT.( N + M )*K ) ) ) + $ .OR. LDL.LT.1 ) THEN + INFO = -15 + ELSE IF ( LCS.LT.3*( N + M - 1 )*K ) THEN + INFO = -17 + ELSE IF ( LDWORK.LT.MAX( 1, ( N + M - 1 )*K ) ) THEN + DWORK(1) = MAX( 1, ( N + M - 1 )*K ) + INFO = -19 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02DD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( K, N, M ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + MAXWRK = 1 + IF ( ISROW ) THEN +C +C Apply Cholesky factor of T(1:K, 1:K) on TA. +C + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, M*K, + $ ONE, T, LDT, TA, LDTA ) +C +C Initialize the output matrices. +C + IF ( COMPG ) THEN + CALL DLASET( 'All', K, M*K, ZERO, ZERO, G(1,N*K+1), LDG ) + IF ( M.GE.N-1 .AND. N.GT.1 ) THEN + CALL DLACPY( 'All', K, (N-1)*K, G(K+1,K+1), LDG, + $ G(K+1,K*(M+1)+1), LDG ) + ELSE + DO 10 I = N*K, K + 1, -1 + CALL DCOPY( K, G(K+1,I), 1, G(K+1,M*K+I), 1 ) + 10 CONTINUE + END IF + CALL DLASET( 'All', K, M*K, ZERO, ZERO, G(K+1,K+1), LDG ) + END IF +C + CALL DLACPY( 'All', K, M*K, TA, LDTA, R, LDR ) +C +C Apply the stored transformations on the new columns. +C + DO 20 I = 2, N +C +C Copy the last M-1 blocks of the positive generator together; +C the last M blocks of the negative generator are contained +C in TA. +C + STARTR = ( I - 1 )*K + 1 + STARTT = 3*( I - 2 )*K + 1 + CALL DLACPY( 'All', K, (M-1)*K, R(STARTR-K,1), LDR, + $ R(STARTR,K+1), LDR ) +C +C Apply the transformations stored in T on the generator. +C + CALL MB02CY( 'Row', 'NoStructure', K, K, M*K, K, + $ R(STARTR,1), LDR, TA, LDTA, T(1,STARTR), LDT, + $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + 20 CONTINUE +C +C Now, we have "normality" and can apply further M Schur steps. +C + DO 30 I = 1, M +C +C Copy the first M-I+1 blocks of the positive generator +C together; the first M-I+1 blocks of the negative generator +C are contained in TA. +C + STARTT = 3*( N + I - 2 )*K + 1 + STARTI = ( M - I + 1 )*K + 1 + STARTR = ( N + I - 1 )*K + 1 + IF ( I.EQ.1 ) THEN + CALL DLACPY( 'All', K, (M-1)*K, R(STARTR-K,1), LDR, + $ R(STARTR,K+1), LDR ) + ELSE + CALL DLACPY( 'Upper', K, (M-I+1)*K, + $ R(STARTR-K,(I-2)*K+1), LDR, + $ R(STARTR,(I-1)*K+1), LDR ) + END IF +C +C Reduce the generator to proper form. +C + CALL MB02CX( 'Row', K, K, K, R(STARTR,(I-1)*K+1), LDR, + $ TA(1,(I-1)*K+1), LDTA, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + IF ( M.GT.I ) THEN + CALL MB02CY( 'Row', 'NoStructure', K, K, (M-I)*K, K, + $ R(STARTR,I*K+1), LDR, TA(1,I*K+1), LDTA, + $ TA(1,(I-1)*K+1), LDTA, CS(STARTT), 3*K, + $ DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + END IF +C + IF ( COMPG ) THEN +C +C Transformations acting on the inverse generator: +C + CALL MB02CY( 'Row', 'Triangular', K, K, K, K, G(K+1,1), + $ LDG, G(1,STARTR), LDG, TA(1,(I-1)*K+1), + $ LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + CALL MB02CY( 'Row', 'NoStructure', K, K, (N+I-1)*K, K, + $ G(K+1,STARTI), LDG, G, LDG, TA(1,(I-1)*K+1), + $ LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + IF ( COMPL ) THEN + CALL DLACPY( 'All', K, (N+I-1)*K, G(K+1,STARTI), LDG, + $ L((I-1)*K+1,1), LDL ) + CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, + $ L((I-1)*K+1,STARTR), LDL ) + END IF +C + END IF + 30 CONTINUE +C + ELSE +C +C Apply Cholesky factor of T(1:K, 1:K) on TA. +C + CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', M*K, K, + $ ONE, T, LDT, TA, LDTA ) +C +C Initialize the output matrices. +C + IF ( COMPG ) THEN + CALL DLASET( 'All', M*K, K, ZERO, ZERO, G(N*K+1,1), LDG ) + IF ( M.GE.N-1 .AND. N.GT.1 ) THEN + CALL DLACPY( 'All', (N-1)*K, K, G(K+1,K+1), LDG, + $ G(K*(M+1)+1,K+1), LDG ) + ELSE + DO 40 I = 1, K + DO 35 J = N*K, K + 1, -1 + G(J+M*K,K+I) = G(J,K+I) + 35 CONTINUE + 40 CONTINUE + END IF + CALL DLASET( 'All', M*K, K, ZERO, ZERO, G(K+1,K+1), LDG ) + END IF +C + CALL DLACPY( 'All', M*K, K, TA, LDTA, R, LDR ) +C +C Apply the stored transformations on the new rows. +C + DO 50 I = 2, N +C +C Copy the last M-1 blocks of the positive generator together; +C the last M blocks of the negative generator are contained +C in TA. +C + STARTR = ( I - 1 )*K + 1 + STARTT = 3*( I - 2 )*K + 1 + CALL DLACPY( 'All', (M-1)*K, K, R(1,STARTR-K), LDR, + $ R(K+1,STARTR), LDR ) +C +C Apply the transformations stored in T on the generator. +C + CALL MB02CY( 'Column', 'NoStructure', K, K, M*K, K, + $ R(1,STARTR), LDR, TA, LDTA, T(STARTR,1), LDT, + $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + 50 CONTINUE +C +C Now, we have "normality" and can apply further M Schur steps. +C + DO 60 I = 1, M +C +C Copy the first M-I+1 blocks of the positive generator +C together; the first M-I+1 blocks of the negative generator +C are contained in TA. +C + STARTT = 3*( N + I - 2 )*K + 1 + STARTI = ( M - I + 1 )*K + 1 + STARTR = ( N + I - 1 )*K + 1 + IF ( I.EQ.1 ) THEN + CALL DLACPY( 'All', (M-1)*K, K, R(1,STARTR-K), LDR, + $ R(K+1,STARTR), LDR ) + ELSE + CALL DLACPY( 'Lower', (M-I+1)*K, K, + $ R((I-2)*K+1,STARTR-K), LDR, + $ R((I-1)*K+1,STARTR), LDR ) + END IF +C +C Reduce the generator to proper form. +C + CALL MB02CX( 'Column', K, K, K, R((I-1)*K+1,STARTR), LDR, + $ TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + IF ( M.GT.I ) THEN + CALL MB02CY( 'Column', 'NoStructure', K, K, (M-I)*K, K, + $ R(I*K+1,STARTR), LDR, TA(I*K+1,1), LDTA, + $ TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K, + $ DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + END IF +C + IF ( COMPG ) THEN +C +C Transformations acting on the inverse generator: +C + CALL MB02CY( 'Column', 'Triangular', K, K, K, K, + $ G(1,K+1), LDG, G(STARTR,1), LDG, + $ TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K, + $ DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + CALL MB02CY( 'Column', 'NoStructure', K, K, (N+I-1)*K, K, + $ G(STARTI,K+1), LDG, G, LDG, TA((I-1)*K+1,1), + $ LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + IF ( COMPL ) THEN + CALL DLACPY( 'All', (N+I-1)*K, K, G(STARTI,K+1), LDG, + $ L(1,(I-1)*K+1), LDL ) + CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, + $ L(STARTR,(I-1)*K+1), LDL ) + END IF +C + END IF + 60 CONTINUE +C + END IF +C + DWORK(1) = MAXWRK +C + RETURN +C +C *** Last line of MB02DD *** + END diff --git a/mex/sources/libslicot/MB02ED.f b/mex/sources/libslicot/MB02ED.f new file mode 100644 index 000000000..d5c366cbc --- /dev/null +++ b/mex/sources/libslicot/MB02ED.f @@ -0,0 +1,445 @@ + SUBROUTINE MB02ED( TYPET, K, N, NRHS, T, LDT, B, LDB, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a system of linear equations T*X = B or X*T = B with +C a symmetric positive definite (s.p.d.) block Toeplitz matrix T. +C T is defined either by its first block row or its first block +C column, depending on the parameter TYPET. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPET CHARACTER*1 +C Specifies the type of T, as follows: +C = 'R': T contains the first block row of an s.p.d. block +C Toeplitz matrix, and the system X*T = B is solved; +C = 'C': T contains the first block column of an s.p.d. +C block Toeplitz matrix, and the system T*X = B is +C solved. +C Note: in the sequel, the notation x / y means that +C x corresponds to TYPET = 'R' and y corresponds to +C TYPET = 'C'. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows / columns in T, which should be equal +C to the blocksize. K >= 0. +C +C N (input) INTEGER +C The number of blocks in T. N >= 0. +C +C NRHS (input) INTEGER +C The number of right hand sides. NRHS >= 0. +C +C T (input/output) DOUBLE PRECISION array, dimension +C (LDT,N*K) / (LDT,K) +C On entry, the leading K-by-N*K / N*K-by-K part of this +C array must contain the first block row / column of an +C s.p.d. block Toeplitz matrix. +C On exit, if INFO = 0 and NRHS > 0, then the leading +C K-by-N*K / N*K-by-K part of this array contains the last +C row / column of the Cholesky factor of inv(T). +C +C LDT INTEGER +C The leading dimension of the array T. +C LDT >= MAX(1,K), if TYPET = 'R'; +C LDT >= MAX(1,N*K), if TYPET = 'C'. +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,N*K) / (LDB,NRHS) +C On entry, the leading NRHS-by-N*K / N*K-by-NRHS part of +C this array must contain the right hand side matrix B. +C On exit, the leading NRHS-by-N*K / N*K-by-NRHS part of +C this array contains the solution matrix X. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,NRHS), if TYPET = 'R'; +C LDB >= MAX(1,N*K), if TYPET = 'C'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -10, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*K*K+(N+2)*K). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction algorithm failed. The Toeplitz matrix +C associated with T is not (numerically) positive +C definite. +C +C METHOD +C +C Householder transformations, modified hyperbolic rotations and +C block Gaussian eliminations are used in the Schur algorithm [1], +C [2]. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically equivalent with forming +C the Cholesky factor R and the inverse Cholesky factor of T, using +C the generalized Schur algorithm, and solving the systems of +C equations R*X = L*B or X*R = B*L by a blocked backward +C substitution algorithm. +C 3 2 2 2 +C The algorithm requires 0(K N + K N NRHS) floating point +C operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Chemnitz, Germany, December 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, +C February 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TYPET + INTEGER INFO, K, LDB, LDT, LDWORK, N, NRHS +C .. Array Arguments .. + DOUBLE PRECISION B(LDB,*), DWORK(*), T(LDT,*) +C .. Local Scalars .. + INTEGER I, IERR, MAXWRK, STARTH, STARTI, STARTN, + $ STARTR, STARTT + LOGICAL ISROW +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASET, DPOTRF, DTRMM, DTRSM, + $ MB02CX, MB02CY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + ISROW = LSAME( TYPET, 'R' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN + INFO = -1 + ELSE IF ( K.LT.0 ) THEN + INFO = -2 + ELSE IF ( N.LT.0 ) THEN + INFO = -3 + ELSE IF ( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. + $ ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN + INFO = -6 + ELSE IF ( LDB.LT.1 .OR. ( ISROW .AND. LDB.LT.NRHS ) .OR. + $ ( .NOT.ISROW .AND. LDB.LT.N*K ) ) THEN + INFO = -8 + ELSE IF ( LDWORK.LT.MAX( 1, N*K*K + ( N + 2 )*K ) ) THEN + DWORK(1) = MAX( 1, N*K*K + ( N + 2 )*K ) + INFO = -10 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02ED', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( K, N, NRHS ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + MAXWRK = 0 + STARTN = 1 + STARTT = N*K*K + 1 + STARTH = STARTT + 3*K +C + IF ( ISROW ) THEN +C +C T is the first block row of a block Toeplitz matrix. +C Bring T to proper form by triangularizing its first block. +C + CALL DPOTRF( 'Upper', K, T, LDT, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + IF ( N.GT.1 ) + $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, + $ (N-1)*K, ONE, T, LDT, T(1,K+1), LDT ) +C +C Initialize the generator, do the first Schur step and set +C B = -B. +C T contains the nonzero blocks of the positive parts in the +C generator and the inverse generator. +C DWORK(STARTN) contains the nonzero blocks of the negative parts +C in the generator and the inverse generator. +C + CALL DTRSM( 'Right', 'Upper', 'NonTranspose', 'NonUnit', NRHS, + $ K, ONE, T, LDT, B, LDB ) + IF ( N.GT.1 ) + $ CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS, (N-1)*K, + $ K, ONE, B, LDB, T(1,K+1), LDT, -ONE, B(1,K+1), + $ LDB ) +C + CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(STARTN), K ) + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, K, + $ ONE, T, LDT, DWORK(STARTN), K ) + IF ( N.GT.1 ) + $ CALL DLACPY( 'All', K, (N-1)*K, T(1,K+1), LDT, + $ DWORK(STARTN+K*K), K ) + CALL DLACPY( 'All', K, K, DWORK(STARTN), K, T(1,(N-1)*K+1), + $ LDT ) +C + CALL DTRMM ( 'Right', 'Lower', 'NonTranspose', 'NonUnit', NRHS, + $ K, ONE, T(1,(N-1)*K+1), LDT, B, LDB ) +C +C Processing the generator. +C + DO 10 I = 2, N + STARTR = ( I - 1 )*K + 1 + STARTI = ( N - I )*K + 1 +C +C Transform the generator of T to proper form. +C + CALL MB02CX( 'Row', K, K, K, T, LDT, + $ DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), 3*K, + $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) +C + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) + CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K, + $ T(1,K+1), LDT, DWORK(STARTN+I*K*K), K, + $ DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), + $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) +C +C Block Gaussian eliminates the i-th block in B. +C + CALL DTRSM( 'Right', 'Upper', 'NonTranspose', 'NonUnit', + $ NRHS, K, -ONE, T, LDT, B(1,STARTR), LDB ) + IF ( N.GT.I ) + $ CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS, + $ (N-I)*K, K, ONE, B(1,STARTR), LDB, T(1,K+1), + $ LDT, ONE, B(1,STARTR+K), LDB ) +C +C Apply hyperbolic transformations on the negative generator. +C + CALL DLASET( 'All', K, K, ZERO, ZERO, T(1,STARTI), LDT ) + CALL MB02CY( 'Row', 'NoStructure', K, K, (I-1)*K, K, + $ T(1,STARTI), LDT, DWORK(STARTN), K, + $ DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), 3*K, + $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) +C +C Note that DWORK(STARTN+(I-1)*K*K) serves simultaneously +C as the transformation container as well as the new block in +C the negative generator. +C + CALL MB02CY( 'Row', 'Triangular', K, K, K, K, + $ T(1,(N-1)*K+1), LDT, DWORK(STARTN+(I-1)*K*K), + $ K, DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), + $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) +C +C Finally the Gaussian elimination is applied on the inverse +C generator. +C + CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS, (I-1)*K, + $ K, ONE, B(1,STARTR), LDB, T(1,STARTI), LDT, ONE, + $ B, LDB ) + CALL DTRMM( 'Right', 'Lower', 'NonTranspose', 'NonUnit', + $ NRHS, K, ONE, T(1,(N-1)*K+1), LDT, B(1,STARTR), + $ LDB ) + 10 CONTINUE +C + ELSE +C +C T is the first block column of a block Toeplitz matrix. +C Bring T to proper form by triangularizing its first block. +C + CALL DPOTRF( 'Lower', K, T, LDT, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + IF ( N.GT.1 ) + $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', + $ (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT ) +C +C Initialize the generator, do the first Schur step and set +C B = -B. +C T contains the nonzero blocks of the positive parts in the +C generator and the inverse generator. +C DWORK(STARTN) contains the nonzero blocks of the negative parts +C in the generator and the inverse generator. +C + CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', K, + $ NRHS, ONE, T, LDT, B, LDB ) + IF ( N.GT.1 ) + $ CALL DGEMM( 'NonTranspose', 'NonTranspose', (N-1)*K, NRHS, + $ K, ONE, T(K+1,1), LDT, B, LDB, -ONE, B(K+1,1), + $ LDB ) +C + CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(STARTN), N*K ) + CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', K, K, + $ ONE, T, LDT, DWORK(STARTN), N*K ) + IF ( N.GT.1 ) + $ CALL DLACPY( 'All', (N-1)*K, K, T(K+1,1), LDT, + $ DWORK(STARTN+K), N*K ) + CALL DLACPY( 'All', K, K, DWORK(STARTN), N*K, T((N-1)*K+1,1), + $ LDT ) +C + CALL DTRMM ( 'Left', 'Upper', 'NonTranspose', 'NonUnit', K, + $ NRHS, ONE, T((N-1)*K+1,1), LDT, B, LDB ) +C +C Processing the generator. +C + DO 20 I = 2, N + STARTR = ( I - 1 )*K + 1 + STARTI = ( N - I )*K + 1 +C +C Transform the generator of T to proper form. +C + CALL MB02CX( 'Column', K, K, K, T, LDT, + $ DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), 3*K, + $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) +C + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) + CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K, K, + $ T(K+1,1), LDT, DWORK(STARTN+I*K), N*K, + $ DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), + $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) +C +C Block Gaussian eliminates the i-th block in B. +C + CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', K, + $ NRHS, -ONE, T, LDT, B(STARTR,1), LDB ) + IF ( N.GT.I ) + $ CALL DGEMM( 'NonTranspose', 'NonTranspose', (N-I)*K, + $ NRHS, K, ONE, T(K+1,1), LDT, B(STARTR,1), + $ LDB, ONE, B(STARTR+K,1), LDB ) +C +C Apply hyperbolic transformations on the negative generator. +C + CALL DLASET( 'All', K, K, ZERO, ZERO, T(STARTI,1), LDT ) + CALL MB02CY( 'Column', 'NoStructure', K, K, (I-1)*K, K, + $ T(STARTI,1), LDT, DWORK(STARTN), N*K, + $ DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), 3*K, + $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) +C +C Note that DWORK(STARTN+(I-1)*K) serves simultaneously +C as the transformation container as well as the new block in +C the negative generator. +C + CALL MB02CY( 'Column', 'Triangular', K, K, K, K, + $ T((N-1)*K+1,1), LDT, DWORK(STARTN+(I-1)*K), + $ N*K, DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), + $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) +C +C Finally the Gaussian elimination is applied on the inverse +C generator. +C + CALL DGEMM( 'NonTranspose', 'NonTranspose', (I-1)*K, NRHS, + $ K, ONE, T(STARTI,1), LDT, B(STARTR,1), LDB, ONE, + $ B, LDB ) + CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit', + $ K, NRHS, ONE, T((N-1)*K+1,1), LDT, B(STARTR,1), + $ LDB ) +C + 20 CONTINUE +C + END IF +C + DWORK(1) = MAX( 1, STARTH - 1 + MAXWRK ) +C + RETURN +C +C *** Last line of MB02ED *** + END diff --git a/mex/sources/libslicot/MB02FD.f b/mex/sources/libslicot/MB02FD.f new file mode 100644 index 000000000..0e608a832 --- /dev/null +++ b/mex/sources/libslicot/MB02FD.f @@ -0,0 +1,383 @@ + SUBROUTINE MB02FD( TYPET, K, N, P, S, T, LDT, R, LDR, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the incomplete Cholesky (ICC) factor of a symmetric +C positive definite (s.p.d.) block Toeplitz matrix T, defined by +C either its first block row, or its first block column, depending +C on the routine parameter TYPET. +C +C By subsequent calls of this routine, further rows / columns of +C the Cholesky factor can be added. +C Furthermore, the generator of the Schur complement of the leading +C (P+S)*K-by-(P+S)*K block in T is available, which can be used, +C e.g., for measuring the quality of the ICC factorization. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPET CHARACTER*1 +C Specifies the type of T, as follows: +C = 'R': T contains the first block row of an s.p.d. block +C Toeplitz matrix; the ICC factor R is upper +C trapezoidal; +C = 'C': T contains the first block column of an s.p.d. +C block Toeplitz matrix; the ICC factor R is lower +C trapezoidal; this choice leads to better +C localized memory references and hence a faster +C algorithm. +C Note: in the sequel, the notation x / y means that +C x corresponds to TYPET = 'R' and y corresponds to +C TYPET = 'C'. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows / columns in T, which should be equal +C to the blocksize. K >= 0. +C +C N (input) INTEGER +C The number of blocks in T. N >= 0. +C +C P (input) INTEGER +C The number of previously computed block rows / columns +C of R. 0 <= P <= N. +C +C S (input) INTEGER +C The number of block rows / columns of R to compute. +C 0 <= S <= N-P. +C +C T (input/output) DOUBLE PRECISION array, dimension +C (LDT,(N-P)*K) / (LDT,K) +C On entry, if P = 0, then the leading K-by-N*K / N*K-by-K +C part of this array must contain the first block row / +C column of an s.p.d. block Toeplitz matrix. +C If P > 0, the leading K-by-(N-P)*K / (N-P)*K-by-K must +C contain the negative generator of the Schur complement of +C the leading P*K-by-P*K part in T, computed from previous +C calls of this routine. +C On exit, if INFO = 0, then the leading K-by-(N-P)*K / +C (N-P)*K-by-K part of this array contains, in the first +C K-by-K block, the upper / lower Cholesky factor of +C T(1:K,1:K), in the following S-1 K-by-K blocks, the +C Householder transformations applied during the process, +C and in the remaining part, the negative generator of the +C Schur complement of the leading (P+S)*K-by(P+S)*K part +C in T. +C +C LDT INTEGER +C The leading dimension of the array T. +C LDT >= MAX(1,K), if TYPET = 'R'; +C LDT >= MAX(1,(N-P)*K), if TYPET = 'C'. +C +C R (input/output) DOUBLE PRECISION array, dimension +C (LDR, N*K) / (LDR, S*K ) if P = 0; +C (LDR, (N-P+1)*K) / (LDR, (S+1)*K ) if P > 0. +C On entry, if P > 0, then the leading K-by-(N-P+1)*K / +C (N-P+1)*K-by-K part of this array must contain the +C nonzero blocks of the last block row / column in the +C ICC factor from a previous call of this routine. Note that +C this part is identical with the positive generator of +C the Schur complement of the leading P*K-by-P*K part in T. +C If P = 0, then R is only an output parameter. +C On exit, if INFO = 0 and P = 0, then the leading +C S*K-by-N*K / N*K-by-S*K part of this array contains the +C upper / lower trapezoidal ICC factor. +C On exit, if INFO = 0 and P > 0, then the leading +C (S+1)*K-by-(N-P+1)*K / (N-P+1)*K-by-(S+1)*K part of this +C array contains the upper / lower trapezoidal part of the +C P-th to (P+S)-th block rows / columns of the ICC factor. +C The elements in the strictly lower / upper trapezoidal +C part are not referenced. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= MAX(1, S*K ), if TYPET = 'R' and P = 0; +C LDR >= MAX(1, (S+1)*K ), if TYPET = 'R' and P > 0; +C LDR >= MAX(1, N*K ), if TYPET = 'C' and P = 0; +C LDR >= MAX(1, (N-P+1)*K ), if TYPET = 'C' and P > 0. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -11, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,(N+1)*K,4*K), if P = 0; +C LDWORK >= MAX(1,(N-P+2)*K,4*K), if P > 0. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction algorithm failed; the Toeplitz matrix +C associated with T is not (numerically) positive +C definite in its leading (P+S)*K-by-(P+S)*K part. +C +C METHOD +C +C Householder transformations and modified hyperbolic rotations +C are used in the Schur algorithm [1], [2]. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C 3 +C The algorithm requires 0(K S (N-P)) floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, April 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001, +C Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TYPET + INTEGER INFO, K, LDR, LDT, LDWORK, N, P, S +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), R(LDR,*), T(LDT,*) +C .. Local Scalars .. + INTEGER COUNTR, I, IERR, MAXWRK, ST, STARTR + LOGICAL ISROW +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DPOTRF, DTRSM, MB02CX, MB02CY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + ISROW = LSAME( TYPET, 'R' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN + INFO = -1 + ELSE IF ( K.LT.0 ) THEN + INFO = -2 + ELSE IF ( N.LT.0 ) THEN + INFO = -3 + ELSE IF ( P.LT.0 .OR. P.GT.N ) THEN + INFO = -4 + ELSE IF ( S.LT.0 .OR. S.GT.( N-P ) ) THEN + INFO = -5 + ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. + $ ( .NOT.ISROW .AND. LDT.LT.( N-P )*K ) ) THEN + INFO = -7 + ELSE IF ( LDR.LT.1 .OR. + $ ( ISROW .AND. P.EQ.0 .AND. ( LDR.LT.S*K ) ) .OR. + $ ( ISROW .AND. P.GT.0 .AND. ( LDR.LT.( S+1 )*K ) ) .OR. + $ ( .NOT.ISROW .AND. P.EQ.0 .AND. ( LDR.LT.N*K ) ) .OR. + $ ( .NOT.ISROW .AND. P.GT.0 .AND. ( LDR.LT.( N-P+1 )*K ) ) ) THEN + INFO = -9 + ELSE + IF ( P.EQ.0 ) THEN + COUNTR = ( N + 1 )*K + ELSE + COUNTR = ( N - P + 2 )*K + END IF + COUNTR = MAX( COUNTR, 4*K ) + IF ( LDWORK.LT.MAX( 1, COUNTR ) ) THEN + DWORK(1) = MAX( 1, COUNTR ) + INFO = -11 + END IF + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02FD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( K, N, S ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + MAXWRK = 1 +C + IF ( ISROW ) THEN +C + IF ( P.EQ.0 ) THEN +C +C T is the first block row of a block Toeplitz matrix. +C Bring T to proper form by triangularizing its first block. +C + CALL DPOTRF( 'Upper', K, T, LDT, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + IF ( N.GT.1 ) + $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, + $ (N-1)*K, ONE, T, LDT, T(1,K+1), LDT ) + CALL DLACPY( 'Upper', K, N*K, T, LDT, R, LDR ) +C + IF ( S.EQ.1 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + ST = 2 + COUNTR = ( N - 1 )*K + ELSE + ST = 1 + COUNTR = ( N - P )*K + END IF +C + STARTR = 1 +C + DO 10 I = ST, S + CALL DLACPY( 'Upper', K, COUNTR, R(STARTR,STARTR), LDR, + $ R(STARTR+K,STARTR+K), LDR ) + STARTR = STARTR + K + COUNTR = COUNTR - K + CALL MB02CX( 'Row', K, K, K, R(STARTR,STARTR), LDR, + $ T(1,STARTR), LDT, DWORK, 3*K, DWORK(3*K+1), + $ LDWORK-3*K, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) + CALL MB02CY( 'Row', 'NoStructure', K, K, COUNTR, K, + $ R(STARTR,STARTR+K), LDR, T(1,STARTR+K), LDT, + $ T(1,STARTR), LDT, DWORK, 3*K, DWORK(3*K+1), + $ LDWORK-3*K, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) + 10 CONTINUE +C + ELSE +C + IF ( P.EQ.0 ) THEN +C +C T is the first block column of a block Toeplitz matrix. +C Bring T to proper form by triangularizing its first block. +C + CALL DPOTRF( 'Lower', K, T, LDT, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + IF ( N.GT.1 ) + $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', + $ (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT ) + CALL DLACPY( 'Lower', N*K, K, T, LDT, R, LDR ) +C + IF ( S.EQ.1 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + ST = 2 + COUNTR = ( N - 1 )*K + ELSE + ST = 1 + COUNTR = ( N - P )*K + END IF +C + STARTR = 1 +C + DO 20 I = ST, S + CALL DLACPY( 'Lower', COUNTR, K, R(STARTR,STARTR), LDR, + $ R(STARTR+K,STARTR+K), LDR ) + STARTR = STARTR + K + COUNTR = COUNTR - K + CALL MB02CX( 'Column', K, K, K, R(STARTR,STARTR), LDR, + $ T(STARTR,1), LDT, DWORK, 3*K, DWORK(3*K+1), + $ LDWORK-3*K, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) + CALL MB02CY( 'Column', 'NoStructure', K, K, COUNTR, K, + $ R(STARTR+K,STARTR), LDR, T(STARTR+K,1), LDT, + $ T(STARTR,1), LDT, DWORK, 3*K, DWORK(3*K+1), + $ LDWORK-3*K, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) + 20 CONTINUE +C + END IF +C + DWORK(1) = MAXWRK +C + RETURN +C +C *** Last line of MB02FD *** + END diff --git a/mex/sources/libslicot/MB02GD.f b/mex/sources/libslicot/MB02GD.f new file mode 100644 index 000000000..c227a556a --- /dev/null +++ b/mex/sources/libslicot/MB02GD.f @@ -0,0 +1,558 @@ + SUBROUTINE MB02GD( TYPET, TRIU, K, N, NL, P, S, T, LDT, RB, LDRB, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Cholesky factor of a banded symmetric positive +C definite (s.p.d.) block Toeplitz matrix, defined by either its +C first block row, or its first block column, depending on the +C routine parameter TYPET. +C +C By subsequent calls of this routine the Cholesky factor can be +C computed block column by block column. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPET CHARACTER*1 +C Specifies the type of T, as follows: +C = 'R': T contains the first block row of an s.p.d. block +C Toeplitz matrix; the Cholesky factor is upper +C triangular; +C = 'C': T contains the first block column of an s.p.d. +C block Toeplitz matrix; the Cholesky factor is +C lower triangular. This choice results in a column +C oriented algorithm which is usually faster. +C Note: in the sequel, the notation x / y means that +C x corresponds to TYPET = 'R' and y corresponds to +C TYPET = 'C'. +C +C TRIU CHARACTER*1 +C Specifies the structure of the last block in T, as +C follows: +C = 'N': the last block has no special structure; +C = 'T': the last block is lower / upper triangular. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows / columns in T, which should be equal +C to the blocksize. K >= 0. +C +C N (input) INTEGER +C The number of blocks in T. N >= 1. +C If TRIU = 'N', N >= 1; +C if TRIU = 'T', N >= 2. +C +C NL (input) INTEGER +C The lower block bandwidth, i.e., NL + 1 is the number of +C nonzero blocks in the first block column of the block +C Toeplitz matrix. +C If TRIU = 'N', 0 <= NL < N; +C if TRIU = 'T', 1 <= NL < N. +C +C P (input) INTEGER +C The number of previously computed block rows / columns of +C the Cholesky factor. 0 <= P <= N. +C +C S (input) INTEGER +C The number of block rows / columns of the Cholesky factor +C to compute. 0 <= S <= N - P. +C +C T (input/output) DOUBLE PRECISION array, dimension +C (LDT,(NL+1)*K) / (LDT,K) +C On entry, if P = 0, the leading K-by-(NL+1)*K / +C (NL+1)*K-by-K part of this array must contain the first +C block row / column of an s.p.d. block Toeplitz matrix. +C On entry, if P > 0, the leading K-by-(NL+1)*K / +C (NL+1)*K-by-K part of this array must contain the P-th +C block row / column of the Cholesky factor. +C On exit, if INFO = 0, then the leading K-by-(NL+1)*K / +C (NL+1)*K-by-K part of this array contains the (P+S)-th +C block row / column of the Cholesky factor. +C +C LDT INTEGER +C The leading dimension of the array T. +C LDT >= MAX(1,K) / MAX(1,(NL+1)*K). +C +C RB (input/output) DOUBLE PRECISION array, dimension +C (LDRB,MIN(P+NL+S,N)*K) / (LDRB,MIN(P+S,N)*K) +C On entry, if TYPET = 'R' and TRIU = 'N' and P > 0, +C the leading (NL+1)*K-by-MIN(NL,N-P)*K part of this array +C must contain the (P*K+1)-st to ((P+NL)*K)-th columns +C of the upper Cholesky factor in banded format from a +C previous call of this routine. +C On entry, if TYPET = 'R' and TRIU = 'T' and P > 0, +C the leading (NL*K+1)-by-MIN(NL,N-P)*K part of this array +C must contain the (P*K+1)-st to (MIN(P+NL,N)*K)-th columns +C of the upper Cholesky factor in banded format from a +C previous call of this routine. +C On exit, if TYPET = 'R' and TRIU = 'N', the leading +C (NL+1)*K-by-MIN(NL+S,N-P)*K part of this array contains +C the (P*K+1)-st to (MIN(P+NL+S,N)*K)-th columns of the +C upper Cholesky factor in banded format. +C On exit, if TYPET = 'R' and TRIU = 'T', the leading +C (NL*K+1)-by-MIN(NL+S,N-P)*K part of this array contains +C the (P*K+1)-st to (MIN(P+NL+S,N)*K)-th columns of the +C upper Cholesky factor in banded format. +C On exit, if TYPET = 'C' and TRIU = 'N', the leading +C (NL+1)*K-by-MIN(S,N-P)*K part of this array contains +C the (P*K+1)-st to (MIN(P+S,N)*K)-th columns of the lower +C Cholesky factor in banded format. +C On exit, if TYPET = 'C' and TRIU = 'T', the leading +C (NL*K+1)-by-MIN(S,N-P)*K part of this array contains +C the (P*K+1)-st to (MIN(P+S,N)*K)-th columns of the lower +C Cholesky factor in banded format. +C For further details regarding the band storage scheme see +C the documentation of the LAPACK routine DPBTF2. +C +C LDRB INTEGER +C The leading dimension of the array RB. +C If TRIU = 'N', LDRB >= MAX( (NL+1)*K,1 ); +C if TRIU = 'T', LDRB >= NL*K+1. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -13, DWORK(1) returns the minimum +C value of LDWORK. +C The first 1 + ( NL + 1 )*K*K elements of DWORK should be +C preserved during successive calls of the routine. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 1 + ( NL + 1 )*K*K + NL*K. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction algorithm failed. The Toeplitz matrix +C associated with T is not (numerically) positive +C definite. +C +C METHOD +C +C Householder transformations and modified hyperbolic rotations +C are used in the Schur algorithm [1], [2]. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C 3 +C The algorithm requires O( K *N*NL ) floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001, +C Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TRIU, TYPET + INTEGER INFO, K, LDRB, LDT, LDWORK, N, NL, P, S +C .. Array Arguments .. + DOUBLE PRECISION DWORK(LDWORK), RB(LDRB,*), T(LDT,*) +C .. Local Scalars .. + CHARACTER STRUCT + LOGICAL ISROW, LTRI + INTEGER HEAD, I, IERR, J, JJ, KK, LEN, LEN2, LENR, NB, + $ NBMIN, PDW, POSR, PRE, RNK, SIZR, STPS, WRKMIN, + $ WRKOPT +C .. Local Arrays .. + INTEGER IPVT(1) + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DLASET, DPOTRF, DTRSM, MB02CU, + $ MB02CV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN, MOD +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + LTRI = LSAME( TRIU, 'T' ) + LENR = ( NL + 1 )*K + IF ( LTRI ) THEN + SIZR = NL*K + 1 + ELSE + SIZR = LENR + END IF + ISROW = LSAME( TYPET, 'R' ) + WRKMIN = 1 + ( LENR + NL )*K +C +C Check the scalar input parameters. +C + IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( LTRI .OR. LSAME( TRIU, 'N' ) ) ) THEN + INFO = -2 + ELSE IF ( K.LT.0 ) THEN + INFO = -3 + ELSE IF ( ( LTRI .AND. N.LT.2 ) .OR. + $ ( .NOT.LTRI .AND. N.LT.1 ) ) THEN + INFO = -4 + ELSE IF ( NL.GE.N .OR. ( LTRI .AND. NL.LT.1 ) .OR. + $ ( .NOT.LTRI .AND. NL.LT.0 ) ) THEN + INFO = -5 + ELSE IF ( P.LT.0 .OR. P.GT.N ) THEN + INFO = -6 + ELSE IF ( S.LT.0 .OR. S.GT.N-P ) THEN + INFO = -7 + ELSE IF ( ( ISROW .AND. LDT.LT.MAX( 1, K ) ) .OR. + $ ( .NOT.ISROW .AND. LDT.LT.MAX( 1, LENR ) ) ) + $ THEN + INFO = -9 + ELSE IF ( ( LTRI .AND. LDRB.LT.SIZR ) .OR. + $ ( .NOT.LTRI .AND. LDRB.LT.MAX( 1, LENR ) ) ) + $ THEN + INFO = -11 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = -13 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02GD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( S*K.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Compute the generator if P = 0. +C + IF ( P.EQ.0 ) THEN + IF ( ISROW ) THEN + CALL DPOTRF( 'Upper', K, T, LDT, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF + IF ( NL.GT.0 ) + $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, + $ NL*K, ONE, T, LDT, T(1,K+1), LDT ) +C +C Copy the first block row to RB. +C + IF ( LTRI ) THEN +C + DO 10 I = 1, LENR - K + CALL DCOPY( MIN( I, K ), T(1,I), 1, + $ RB( MAX( SIZR-I+1, 1 ),I ), 1 ) + 10 CONTINUE +C + DO 20 I = K, 1, -1 + CALL DCOPY( I, T(K-I+1,LENR-I+1), 1, + $ RB( 1,LENR-I+1 ), 1 ) + 20 CONTINUE +C + ELSE +C + DO 30 I = 1, LENR + CALL DCOPY( MIN( I, K ), T(1,I), 1, + $ RB( MAX( SIZR-I+1, 1 ),I ), 1 ) + 30 CONTINUE +C + END IF +C +C Quick return if N = 1. +C + IF ( N.EQ.1 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + CALL DLACPY( 'All', K, NL*K, T(1,K+1), LDT, DWORK(2), K ) + CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(NL*K*K+2), K ) + POSR = K + 1 + ELSE + CALL DPOTRF( 'Lower', K, T, LDT, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF + IF ( NL.GT.0 ) + $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', + $ NL*K, K, ONE, T, LDT, T(K+1,1), LDT ) +C +C Copy the first block column to RB. +C + POSR = 1 + IF ( LTRI ) THEN +C + DO 40 I = 1, K + CALL DCOPY( SIZR, T(I,I), 1, RB(1,POSR), 1 ) + POSR = POSR + 1 + 40 CONTINUE +C + ELSE +C + DO 50 I = 1, K + CALL DCOPY( LENR-I+1, T(I,I), 1, RB(1,POSR), 1 ) + IF ( LENR.LT.N*K .AND. I.GT.1 ) THEN + CALL DLASET( 'All', I-1, 1, ZERO, ZERO, + $ RB(LENR-I+2,POSR), LDRB ) + END IF + POSR = POSR + 1 + 50 CONTINUE +C + END IF +C +C Quick return if N = 1. +C + IF ( N.EQ.1 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + CALL DLACPY( 'All', NL*K, K, T(K+1,1), LDT, DWORK(2), LENR ) + CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(NL*K+2), LENR ) + END IF + PRE = 1 + STPS = S - 1 + ELSE + PRE = P + STPS = S + POSR = 1 + END IF +C + PDW = LENR*K + 1 + HEAD = MOD( ( PRE - 1 )*K, LENR ) +C +C Determine block size for the involved block Householder +C transformations. +C + IF ( ISROW ) THEN + NB = MIN( ILAENV( 1, 'DGEQRF', ' ', K, LENR, -1, -1 ), K ) + ELSE + NB = MIN( ILAENV( 1, 'DGELQF', ' ', LENR, K, -1, -1 ), K ) + END IF + KK = PDW + 4*K + WRKOPT = KK + LENR*NB + KK = LDWORK - KK + IF ( KK.LT.LENR*NB ) NB = KK / LENR + IF ( ISROW ) THEN + NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', K, LENR, -1, -1 ) ) + ELSE + NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LENR, K, -1, -1 ) ) + END IF + IF ( NB.LT.NBMIN ) NB = 0 +C +C Generator reduction process. +C + IF ( ISROW ) THEN +C + DO 90 I = PRE, PRE + STPS - 1 + CALL MB02CU( 'Row', K, K, K, NB, T, LDT, DUM, 1, + $ DWORK(HEAD*K+2), K, RNK, IPVT, DWORK(PDW+1), + $ ZERO, DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) +C + IF ( IERR.NE.0 ) THEN +C +C Error return: The positive definiteness is (numerically) +C not satisfied. +C + INFO = 1 + RETURN + END IF +C + LEN = MAX( MIN( ( N - I )*K - K, LENR - HEAD - K ), 0 ) + LEN2 = MAX( MIN( ( N - I )*K - LEN - K, HEAD ), 0 ) + IF ( LEN.EQ.( LENR-K ) ) THEN + STRUCT = TRIU + ELSE + STRUCT = 'N' + END IF + CALL MB02CV( 'Row', STRUCT, K, LEN, K, K, NB, -1, DUM, 1, + $ DUM, 1, DWORK(HEAD*K+2), K, T(1,K+1), LDT, + $ DUM, 1, DWORK((HEAD+K)*K+2), K, DWORK(PDW+1), + $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) +C + IF ( ( N - I )*K.GE.LENR ) THEN + STRUCT = TRIU + ELSE + STRUCT = 'N' + END IF + CALL MB02CV( 'Row', STRUCT, K, LEN2, K, K, NB, -1, DUM, 1, + $ DUM, 1, DWORK(HEAD*K+2), K, T(1,K+LEN+1), LDT, + $ DUM, 1, DWORK(2), K, DWORK(PDW+1), + $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) +C + CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(HEAD*K+2), K ) +C +C Copy current block row to RB. +C + IF ( LTRI ) THEN +C + DO 60 J = 1, MIN( LEN + LEN2 + K, LENR - K ) + CALL DCOPY( MIN( J, K ), T(1,J), 1, + $ RB(MAX( SIZR-J+1, 1 ),POSR+J-1 ), 1 ) + 60 CONTINUE +C + IF ( LEN+LEN2+K.GE.LENR ) THEN +C + DO 70 JJ = K, 1, -1 + CALL DCOPY( JJ, T(K-JJ+1,LENR-JJ+1), 1, + $ RB(1,POSR+LENR-JJ), 1 ) + 70 CONTINUE +C + END IF + POSR = POSR + K +C + ELSE +C + DO 80 J = 1, LEN + LEN2 + K + CALL DCOPY( MIN( J, K ), T(1,J), 1, + $ RB(MAX( SIZR-J+1, 1 ),POSR+J-1), 1 ) + IF ( J.GT.LENR-K ) THEN + CALL DLASET( 'All', SIZR-J, 1, ZERO, ZERO, + $ RB(1,POSR+J-1), 1 ) + END IF + 80 CONTINUE +C + POSR = POSR + K + END IF + HEAD = MOD( HEAD + K, LENR ) + 90 CONTINUE +C + ELSE +C + DO 120 I = PRE, PRE + STPS - 1 +C + CALL MB02CU( 'Column', K, K, K, NB, T, LDT, DUM, 1, + $ DWORK(HEAD+2), LENR, RNK, IPVT, DWORK(PDW+1), + $ ZERO, DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) +C + IF ( IERR.NE.0 ) THEN +C +C Error return: The positive definiteness is (numerically) +C not satisfied. +C + INFO = 1 + RETURN + END IF +C + LEN = MAX( MIN( ( N - I )*K - K, LENR - HEAD - K ), 0 ) + LEN2 = MAX( MIN( ( N - I )*K - LEN - K, HEAD ), 0 ) + IF ( LEN.EQ.( LENR-K ) ) THEN + STRUCT = TRIU + ELSE + STRUCT = 'N' + END IF + CALL MB02CV( 'Column', STRUCT, K, LEN, K, K, NB, -1, DUM, + $ 1, DUM, 1, DWORK(HEAD+2), LENR, T(K+1,1), LDT, + $ DUM, 1, DWORK(HEAD+K+2), LENR, DWORK(PDW+1), + $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) +C + IF ( ( N - I )*K.GE.LENR ) THEN + STRUCT = TRIU + ELSE + STRUCT = 'N' + END IF + CALL MB02CV( 'Column', STRUCT, K, LEN2, K, K, NB, -1, DUM, + $ 1, DUM, 1, DWORK(HEAD+2), LENR, T(K+LEN+1,1), + $ LDT, DUM, 1, DWORK(2), LENR, DWORK(PDW+1), + $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) +C + CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(HEAD+2), LENR ) +C +C Copy current block column to RB. +C + IF ( LTRI ) THEN +C + DO 100 J = 1, K + CALL DCOPY( MIN( SIZR, (N-I)*K-J+1 ), T(J,J), 1, + $ RB(1,POSR), 1 ) + POSR = POSR + 1 + 100 CONTINUE +C + ELSE +C + DO 110 J = 1, K + CALL DCOPY( MIN( SIZR-J+1, (N-I)*K-J+1 ), T(J,J), 1, + $ RB(1,POSR), 1 ) + IF ( LENR.LT.(N-I)*K ) THEN + CALL DLASET( 'All', J-1, 1, ZERO, ZERO, + $ RB(MIN( SIZR-J+1, (N-I)*K-J+1 ) + 1, + $ POSR), LDRB ) + END IF + POSR = POSR + 1 + 110 CONTINUE +C + END IF + HEAD = MOD( HEAD + K, LENR ) + 120 CONTINUE +C + END IF + DWORK(1) = DBLE( WRKOPT ) + RETURN +C +C *** Last line of MB02GD *** + END diff --git a/mex/sources/libslicot/MB02HD.f b/mex/sources/libslicot/MB02HD.f new file mode 100644 index 000000000..c93d2474a --- /dev/null +++ b/mex/sources/libslicot/MB02HD.f @@ -0,0 +1,545 @@ + SUBROUTINE MB02HD( TRIU, K, L, M, ML, N, NU, P, S, TC, LDTC, TR, + $ LDTR, RB, LDRB, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute, for a banded K*M-by-L*N block Toeplitz matrix T with +C block size (K,L), specified by the nonzero blocks of its first +C block column TC and row TR, a LOWER triangular matrix R (in band +C storage scheme) such that +C T T +C T T = R R . (1) +C +C It is assumed that the first MIN(M*K, N*L) columns of T are +C linearly independent. +C +C By subsequent calls of this routine, the matrix R can be computed +C block column by block column. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRIU CHARACTER*1 +C Specifies the structure, if any, of the last blocks in TC +C and TR, as follows: +C = 'N': TC and TR have no special structure; +C = 'T': TC and TR are upper and lower triangular, +C respectively. Depending on the block sizes, two +C different shapes of the last blocks in TC and TR +C are possible, as illustrated below: +C +C 1) TC TR 2) TC TR +C +C x x x x 0 0 x x x x x 0 0 0 +C 0 x x x x 0 0 x x x x x 0 0 +C 0 0 x x x x 0 0 x x x x x 0 +C 0 0 0 x x x +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows in the blocks of T. K >= 0. +C +C L (input) INTEGER +C The number of columns in the blocks of T. L >= 0. +C +C M (input) INTEGER +C The number of blocks in the first block column of T. +C M >= 1. +C +C ML (input) INTEGER +C The lower block bandwidth, i.e., ML + 1 is the number of +C nonzero blocks in the first block column of T. +C 0 <= ML < M and (ML + 1)*K >= L and +C if ( M*K <= N*L ), ML >= M - INT( ( M*K - 1 )/L ) - 1; +C ML >= M - INT( M*K/L ) or +C MOD( M*K, L ) >= K; +C if ( M*K >= N*L ), ML*K >= N*( L - K ). +C +C N (input) INTEGER +C The number of blocks in the first block row of T. +C N >= 1. +C +C NU (input) INTEGER +C The upper block bandwidth, i.e., NU + 1 is the number of +C nonzero blocks in the first block row of T. +C If TRIU = 'N', 0 <= NU < N and +C (M + NU)*L >= MIN( M*K, N*L ); +C if TRIU = 'T', MAX(1-ML,0) <= NU < N and +C (M + NU)*L >= MIN( M*K, N*L ). +C +C P (input) INTEGER +C The number of previously computed block columns of R. +C P*L < MIN( M*K,N*L ) + L and P >= 0. +C +C S (input) INTEGER +C The number of block columns of R to compute. +C (P+S)*L < MIN( M*K,N*L ) + L and S >= 0. +C +C TC (input) DOUBLE PRECISION array, dimension (LDTC,L) +C On entry, if P = 0, the leading (ML+1)*K-by-L part of this +C array must contain the nonzero blocks in the first block +C column of T. +C +C LDTC INTEGER +C The leading dimension of the array TC. +C LDTC >= MAX(1,(ML+1)*K), if P = 0. +C +C TR (input) DOUBLE PRECISION array, dimension (LDTR,NU*L) +C On entry, if P = 0, the leading K-by-NU*L part of this +C array must contain the 2nd to the (NU+1)-st blocks of +C the first block row of T. +C +C LDTR INTEGER +C The leading dimension of the array TR. +C LDTR >= MAX(1,K), if P = 0. +C +C RB (output) DOUBLE PRECISION array, dimension +C (LDRB,MIN( S*L,MIN( M*K,N*L )-P*L )) +C On exit, if INFO = 0 and TRIU = 'N', the leading +C MIN( ML+NU+1,N )*L-by-MIN( S*L,MIN( M*K,N*L )-P*L ) part +C of this array contains the (P+1)-th to (P+S)-th block +C column of the lower R factor (1) in band storage format. +C On exit, if INFO = 0 and TRIU = 'T', the leading +C MIN( (ML+NU)*L+1,N*L )-by-MIN( S*L,MIN( M*K,N*L )-P*L ) +C part of this array contains the (P+1)-th to (P+S)-th block +C column of the lower R factor (1) in band storage format. +C For further details regarding the band storage scheme see +C the documentation of the LAPACK routine DPBTF2. +C +C LDRB INTEGER +C The leading dimension of the array RB. +C LDRB >= MAX( MIN( ML+NU+1,N )*L,1 ), if TRIU = 'N'; +C LDRB >= MAX( MIN( (ML+NU)*L+1,N*L ),1 ), if TRIU = 'T'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -17, DWORK(1) returns the minimum +C value of LDWORK. +C The first 1 + 2*MIN( ML+NU+1,N )*L*(K+L) elements of DWORK +C should be preserved during successive calls of the routine. +C +C LDWORK INTEGER +C The length of the array DWORK. +C Let x = MIN( ML+NU+1,N ), then +C LDWORK >= 1 + MAX( x*L*L + (2*NU+1)*L*K, +C 2*x*L*(K+L) + (6+x)*L ), if P = 0; +C LDWORK >= 1 + 2*x*L*(K+L) + (6+x)*L, if P > 0. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the full rank condition for the first MIN(M*K, N*L) +C columns of T is (numerically) violated. +C +C METHOD +C +C Householder transformations and modified hyperbolic rotations +C are used in the Schur algorithm [1], [2]. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The implemented method yields a factor R which has comparable +C accuracy with the Cholesky factor of T^T * T. +C The algorithm requires +C 2 2 +C O( L *K*N*( ML + NU ) + N*( ML + NU )*L *( L + K ) ) +C +C floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001. +C D. Kressner, Technical Univ. Berlin, Germany, July 2002. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TRIU + INTEGER INFO, K, L, LDRB, LDTC, LDTR, LDWORK, M, ML, N, + $ NU, P, S +C .. Array Arguments .. + DOUBLE PRECISION DWORK(LDWORK), RB(LDRB,*), TC(LDTC,*), + $ TR(LDTR,*) +C .. Local Scalars .. + CHARACTER STRUCT + INTEGER COL2, HEAD, I, IERR, J, KK, LEN, LEN2, LENC, + $ LENL, LENR, NB, NBMIN, PDC, PDR, PDW, PFR, PNR, + $ POSR, PRE, PT, RNK, SIZR, STPS, WRKMIN, WRKOPT, + $ X + LOGICAL LTRI +C .. Local Arrays .. + INTEGER IPVT(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEQRF, DLACPY, DLASET, DORGQR, + $ MA02AD, MB02CU, MB02CV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, MOD +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + LTRI = LSAME( TRIU, 'T' ) + X = MIN( ML + NU + 1, N ) + LENR = X*L + IF ( LTRI ) THEN + SIZR = MIN( ( ML + NU )*L + 1, N*L ) + ELSE + SIZR = LENR + END IF + IF ( P.EQ.0 ) THEN + WRKMIN = 1 + MAX( LENR*L + ( 2*NU + 1 )*L*K, + $ 2*LENR*( K + L ) + ( 6 + X )*L ) + ELSE + WRKMIN = 1 + 2*LENR*( K + L ) + ( 6 + X )*L + END IF + POSR = 1 +C +C Check the scalar input parameters. +C + IF ( .NOT.( LTRI .OR. LSAME( TRIU, 'N' ) ) ) THEN + INFO = -1 + ELSE IF ( K.LT.0 ) THEN + INFO = -2 + ELSE IF ( L.LT.0 ) THEN + INFO = -3 + ELSE IF ( M.LT.1 ) THEN + INFO = -4 + ELSE IF ( ML.GE.M .OR. ( ML + 1 )*K.LT.L .OR. ( M*K.LE.N*L .AND. + $ ( ( ML.LT.M - INT( ( M*K - 1 )/L ) - 1 ) .OR. + $ ( ML.LT.M - INT( M*K/L ).AND.MOD( M*K, L ).LT.K ) ) ) + $ .OR. ( M*K.GE.N*L .AND. ML*K.LT.N*( L - K ) ) ) THEN + INFO = -5 + ELSE IF ( N.LT.1 ) THEN + INFO = -6 + ELSE IF ( NU.GE.N .OR. NU.LT.0 .OR. ( LTRI .AND. NU.LT.1-ML ) .OR. + $ (M + NU)*L.LT.MIN( M*K, N*L ) ) THEN + INFO = -7 + ELSE IF ( P.LT.0 .OR. ( P*L - L ).GE.MIN( M*K, N*L ) ) THEN + INFO = -8 + ELSE IF ( S.LT.0 .OR. ( P + S - 1 )*L.GE.MIN( M*K, N*L ) ) THEN + INFO = -9 + ELSE IF ( P.EQ.0 .AND. LDTC.LT.MAX( 1, ( ML + 1 )*K ) ) THEN + INFO = -11 + ELSE IF ( P.EQ.0 .AND. LDTR.LT.MAX( 1, K ) ) THEN + INFO = -13 + ELSE IF ( LDRB.LT.MAX( SIZR, 1 ) ) THEN + INFO = 15 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = -17 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02HD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( L*K*S.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + WRKOPT = 1 +C +C Compute the generator if P = 0. +C + IF ( P.EQ.0 ) THEN +C +C 1st column of the generator. +C + LENC = ( ML + 1 )*K + LENL = MAX( ML + 1 + MIN( NU, N - M ), 0 ) + PDC = LENR*L + 1 + PDW = PDC + LENC*L +C +C QR decomposition of the nonzero blocks in TC. +C + CALL DLACPY( 'All', LENC, L, TC, LDTC, DWORK(PDC+1), LENC ) + CALL DGEQRF( LENC, L, DWORK(PDC+1), LENC, DWORK(PDW+1), + $ DWORK(PDW+L+1), LDWORK-PDW-L, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L+1) ) + PDW + L ) +C +C The R factor is the transposed of the first block in the +C generator. +C + CALL MA02AD( 'Upper part', L, L, DWORK(PDC+1), LENC, DWORK(2), + $ LENR ) +C +C Get the first block column of the Q factor. +C + CALL DORGQR( LENC, L, L, DWORK(PDC+1), LENC, DWORK(PDW+1), + $ DWORK(PDW+L+1), LDWORK-PDW-L, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L+1) ) + PDW + L ) +C +C Construct a flipped copy of TC for faster multiplication. +C + PT = LENC - 2*K + 1 +C + DO 10 I = PDW + 1, PDW + ML*K*L, K*L + CALL DLACPY( 'All', K, L, TC(PT,1), LDTC, DWORK(I), K ) + PT = PT - K + 10 CONTINUE +C +C Multiply T^T with the first block column of Q. +C + PDW = I + PDR = L + 2 + LEN = NU*L + CALL DLASET( 'All', LENR-L, L, ZERO, ZERO, DWORK(PDR), LENR ) +C + DO 20 I = 1, ML + 1 + CALL DGEMM( 'Transpose', 'NonTranspose', MIN( I-1, N-1 )*L, + $ L, K, ONE, DWORK(PDW), K, DWORK(PDC+1), LENC, + $ ONE, DWORK(PDR), LENR ) + IF ( LEN.GT.0 ) THEN + CALL DGEMM( 'Transpose', 'NonTranspose', LEN, L, K, ONE, + $ TR, LDTR, DWORK(PDC+1), LENC, ONE, + $ DWORK(PDR+(I-1)*L), LENR ) + END IF + PDW = PDW - K*L + PDC = PDC + K + IF ( I.GE.N-NU ) LEN = LEN - L + 20 CONTINUE +C +C Copy the first block column to R. +C + IF ( LTRI ) THEN +C + DO 30 I = 1, L + CALL DCOPY( MIN( SIZR, N*L - I + 1 ), + $ DWORK(( I - 1 )*LENR + I + 1), 1, RB(1,POSR), + $ 1 ) + POSR = POSR + 1 + 30 CONTINUE +C + ELSE +C + DO 40 I = 1, L + CALL DCOPY( LENR-I+1, DWORK(( I - 1 )*LENR + I + 1), 1, + $ RB(1,POSR), 1 ) + IF ( LENR.LT.N*L .AND. I.GT.1 ) THEN + CALL DLASET( 'All', I-1, 1, ZERO, ZERO, + $ RB(LENR-I+2,POSR), LDRB ) + END IF + POSR = POSR + 1 + 40 CONTINUE +C + END IF +C +C Quick return if N = 1. +C + IF ( N.EQ.1 ) THEN + DWORK(1) = DBLE( WRKOPT ) + RETURN + END IF +C +C 2nd column of the generator. +C + PDR = LENR*L + 1 + CALL MA02AD( 'All', K, NU*L, TR, LDTR, DWORK(PDR+1), LENR ) + CALL DLASET( 'All', LENR-NU*L, K, ZERO, ZERO, + $ DWORK(PDR+NU*L+1), LENR ) +C +C 3rd column of the generator. +C + PNR = PDR + LENR*K + CALL DLACPY( 'All', LENR-L, L, DWORK(L+2), LENR, DWORK(PNR+1), + $ LENR ) + CALL DLASET( 'All', L, L, ZERO, ZERO, DWORK(PNR+LENR-L+1), + $ LENR ) +C +C 4th column of the generator. +C + PFR = PNR + LENR*L +C + PDW = PFR + MOD( ( M - ML - 1 )*L, LENR ) + PT = ML*K + 1 + DO 50 I = 1, MIN( ML + 1, LENL ) + CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW+1), + $ LENR ) + PT = PT - K + PDW = PFR + MOD( PDW + L - PFR, LENR ) + 50 CONTINUE + PT = 1 + DO 60 I = ML + 2, LENL + CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW+1), + $ LENR ) + PT = PT + L + PDW = PFR + MOD( PDW + L - PFR, LENR ) + 60 CONTINUE + PRE = 1 + STPS = S - 1 + ELSE + PDR = LENR*L + 1 + PNR = PDR + LENR*K + PFR = PNR + LENR*L + PRE = P + STPS = S + END IF +C + PDW = PFR + LENR*K + HEAD = MOD( ( PRE - 1 )*L, LENR ) +C +C Determine block size for the involved block Householder +C transformations. +C + NB = MIN( ILAENV( 1, 'DGELQF', ' ', LENR, L, -1, -1 ), L ) + KK = PDW + 6*L + WRKOPT = MAX( WRKOPT, KK + LENR*NB ) + KK = LDWORK - KK + IF ( KK.LT.LENR*NB ) NB = KK / LENR + NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LENR, L, -1, -1 ) ) + IF ( NB.LT.NBMIN ) NB = 0 +C +C Generator reduction process. +C + DO 90 I = PRE, PRE + STPS - 1 +C +C The 4th generator column is not used in the first (M-ML) steps. +C + IF ( I.LT.M-ML ) THEN + COL2 = L + ELSE + COL2 = K + L + END IF +C + KK = MIN( L, M*K - I*L ) + CALL MB02CU( 'Column', KK, KK+K, COL2, NB, DWORK(2), LENR, + $ DWORK(PDR+HEAD+1), LENR, DWORK(PNR+HEAD+1), LENR, + $ RNK, IPVT, DWORK(PDW+1), ZERO, DWORK(PDW+6*L+1), + $ LDWORK-PDW-6*L, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The rank condition is (numerically) not +C satisfied. +C + INFO = 1 + RETURN + END IF +C + LEN = MAX( MIN( ( N - I )*L - KK, LENR - HEAD - KK ), 0 ) + LEN2 = MAX( MIN( ( N - I )*L - LEN - KK, HEAD ), 0 ) + IF ( LEN.EQ.( LENR - KK ) ) THEN + STRUCT = TRIU + ELSE + STRUCT = 'N' + END IF + CALL MB02CV( 'Column', STRUCT, KK, LEN, KK+K, COL2, NB, -1, + $ DWORK(2), LENR, DWORK(PDR+HEAD+1), LENR, + $ DWORK(PNR+HEAD+1), LENR, DWORK(KK+2), LENR, + $ DWORK(PDR+HEAD+KK+1), LENR, DWORK(PNR+HEAD+KK+1), + $ LENR, DWORK(PDW+1), DWORK(PDW+6*L+1), + $ LDWORK-PDW-6*L, IERR ) +C + IF ( ( N - I )*L.GE.LENR ) THEN + STRUCT = TRIU + ELSE + STRUCT = 'N' + END IF +C + CALL MB02CV( 'Column', STRUCT, KK, LEN2, KK+K, COL2, NB, -1, + $ DWORK(2), LENR, DWORK(PDR+HEAD+1), LENR, + $ DWORK(PNR+HEAD+1), LENR, DWORK(KK+LEN+2), LENR, + $ DWORK(PDR+1), LENR, DWORK(PNR+1), LENR, + $ DWORK(PDW+1), DWORK(PDW+6*L+1), + $ LDWORK-PDW-6*L, IERR ) +C + CALL DLASET( 'All', L, K+COL2, ZERO, ZERO, DWORK(PDR+HEAD+1), + $ LENR ) +C +C Copy current block column to R. +C + IF ( LTRI ) THEN +C + DO 70 J = 1, KK + CALL DCOPY( MIN( SIZR, (N-I)*L-J+1 ), + $ DWORK(( J - 1 )*LENR + J + 1), 1, + $ RB(1,POSR), 1 ) + POSR = POSR + 1 + 70 CONTINUE +C + ELSE +C + DO 80 J = 1, KK + CALL DCOPY( MIN( SIZR-J+1, (N-I)*L-J+1 ), + $ DWORK(( J - 1 )*LENR + J + 1), 1, + $ RB(1,POSR), 1 ) + IF ( LENR.LT.( N - I )*L .AND. J.GT.1 ) THEN + CALL DLASET( 'All', J-1, 1, ZERO, ZERO, + $ RB(MIN( SIZR-J+1, (N-I)*L-J+1 )+1,POSR), + $ LDRB ) + END IF + POSR = POSR + 1 + 80 CONTINUE +C + END IF +C + HEAD = MOD( HEAD + L, LENR ) + 90 CONTINUE +C + DWORK(1) = DBLE( WRKOPT ) + RETURN +C +C *** Last line of MB02HD *** + END diff --git a/mex/sources/libslicot/MB02ID.f b/mex/sources/libslicot/MB02ID.f new file mode 100644 index 000000000..a0e5e659b --- /dev/null +++ b/mex/sources/libslicot/MB02ID.f @@ -0,0 +1,508 @@ + SUBROUTINE MB02ID( JOB, K, L, M, N, RB, RC, TC, LDTC, TR, LDTR, B, + $ LDB, C, LDC, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the overdetermined or underdetermined real linear systems +C involving an M*K-by-N*L block Toeplitz matrix T that is specified +C by its first block column and row. It is assumed that T has full +C rank. +C The following options are provided: +C +C 1. If JOB = 'O' or JOB = 'A' : find the least squares solution of +C an overdetermined system, i.e., solve the least squares problem +C +C minimize || B - T*X ||. (1) +C +C 2. If JOB = 'U' or JOB = 'A' : find the minimum norm solution of +C the undetermined system +C T +C T * X = C. (2) +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the problem to be solved as follows +C = 'O': solve the overdetermined system (1); +C = 'U': solve the underdetermined system (2); +C = 'A': solve (1) and (2). +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows in the blocks of T. K >= 0. +C +C L (input) INTEGER +C The number of columns in the blocks of T. L >= 0. +C +C M (input) INTEGER +C The number of blocks in the first block column of T. +C M >= 0. +C +C N (input) INTEGER +C The number of blocks in the first block row of T. +C 0 <= N <= M*K / L. +C +C RB (input) INTEGER +C If JOB = 'O' or 'A', the number of columns in B. RB >= 0. +C +C RC (input) INTEGER +C If JOB = 'U' or 'A', the number of columns in C. RC >= 0. +C +C TC (input) DOUBLE PRECISION array, dimension (LDTC,L) +C On entry, the leading M*K-by-L part of this array must +C contain the first block column of T. +C +C LDTC INTEGER +C The leading dimension of the array TC. LDTC >= MAX(1,M*K) +C +C TR (input) DOUBLE PRECISION array, dimension (LDTR,(N-1)*L) +C On entry, the leading K-by-(N-1)*L part of this array must +C contain the 2nd to the N-th blocks of the first block row +C of T. +C +C LDTR INTEGER +C The leading dimension of the array TR. LDTR >= MAX(1,K). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,RB) +C On entry, if JOB = 'O' or JOB = 'A', the leading M*K-by-RB +C part of this array must contain the right hand side +C matrix B of the overdetermined system (1). +C On exit, if JOB = 'O' or JOB = 'A', the leading N*L-by-RB +C part of this array contains the solution of the +C overdetermined system (1). +C This array is not referenced if JOB = 'U'. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,M*K), if JOB = 'O' or JOB = 'A'; +C LDB >= 1, if JOB = 'U'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,RC) +C On entry, if JOB = 'U' or JOB = 'A', the leading N*L-by-RC +C part of this array must contain the right hand side +C matrix C of the underdetermined system (2). +C On exit, if JOB = 'U' or JOB = 'A', the leading M*K-by-RC +C part of this array contains the solution of the +C underdetermined system (2). +C This array is not referenced if JOB = 'O'. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDB >= 1, if JOB = 'O'; +C LDB >= MAX(1,M*K), if JOB = 'U' or JOB = 'A'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -17, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C Let x = MAX( 2*N*L*(L+K) + (6+N)*L,(N*L+M*K+1)*L + M*K ) +C and y = N*M*K*L + N*L, then +C if MIN( M,N ) = 1 and JOB = 'O', +C LDWORK >= MAX( y + MAX( M*K,RB ),1 ); +C if MIN( M,N ) = 1 and JOB = 'U', +C LDWORK >= MAX( y + MAX( M*K,RC ),1 ); +C if MIN( M,N ) = 1 and JOB = 'A', +C LDWORK >= MAX( y +MAX( M*K,MAX( RB,RC ),1 ); +C if MIN( M,N ) > 1 and JOB = 'O', +C LDWORK >= MAX( x,N*L*RB + 1 ); +C if MIN( M,N ) > 1 and JOB = 'U', +C LDWORK >= MAX( x,N*L*RC + 1 ); +C if MIN( M,N ) > 1 and JOB = 'A', +C LDWORK >= MAX( x,N*L*MAX( RB,RC ) + 1 ). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction algorithm failed. The Toeplitz matrix +C associated with T is (numerically) not of full rank. +C +C METHOD +C +C Householder transformations and modified hyperbolic rotations +C are used in the Schur algorithm [1], [2]. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O( L*L*K*(N+M)*log(N+M) + N*N*L*L*(L+K) ) +C and additionally +C +C if JOB = 'O' or JOB = 'A', +C O( (K*L+RB*L+K*RB)*(N+M)*log(N+M) + N*N*L*L*RB ); +C if JOB = 'U' or JOB = 'A', +C O( (K*L+RC*L+K*RC)*(N+M)*log(N+M) + N*N*L*L*RC ); +C +C floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001. +C D. Kressner, Technical Univ. Berlin, Germany, July 2002. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, K, L, LDB, LDC, LDTC, LDTR, LDWORK, M, N, + $ RB, RC +C .. Array Arguments .. + DOUBLE PRECISION B(LDB,*), C(LDC,*), DWORK(LDWORK), TC(LDTC,*), + $ TR(LDTR,*) +C .. Local Scalars .. + INTEGER I, IERR, KK, LEN, NB, NBMIN, PDI, PDW, PNI, PNR, + $ PPI, PPR, PT, RNK, WRKMIN, WRKOPT, X, Y + LOGICAL COMPO, COMPU +C .. Local Arrays .. + INTEGER IPVT(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DGELS, DGEMM, DGEQRF, DLACPY, DLASET, DORGQR, + $ DTRMM, DTRSM, DTRTRI, MA02AD, MB02CU, MB02CV, + $ MB02KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + COMPO = LSAME( JOB, 'O' ) .OR. LSAME( JOB, 'A' ) + COMPU = LSAME( JOB, 'U' ) .OR. LSAME( JOB, 'A' ) + X = MAX( 2*N*L*( L + K ) + ( 6 + N )*L, + $ ( N*L + M*K + 1 )*L + M*K ) + Y = N*M*K*L + N*L + IF ( MIN( M, N ).EQ.1 ) THEN + WRKMIN = MAX( M*K, 1 ) + IF ( COMPO ) WRKMIN = MAX( WRKMIN, RB ) + IF ( COMPU ) WRKMIN = MAX( WRKMIN, RC ) + WRKMIN = MAX( Y + WRKMIN, 1 ) + ELSE + WRKMIN = X + IF ( COMPO ) WRKMIN = MAX( WRKMIN, N*L*RB + 1 ) + IF ( COMPU ) WRKMIN = MAX( WRKMIN, N*L*RC + 1 ) + END IF + WRKOPT = 1 +C +C Check the scalar input parameters. +C + IF ( .NOT.( COMPO .OR. COMPU ) ) THEN + INFO = -1 + ELSE IF ( K.LT.0 ) THEN + INFO = -2 + ELSE IF ( L.LT.0 ) THEN + INFO = -3 + ELSE IF ( M.LT.0 ) THEN + INFO = -4 + ELSE IF ( N.LT.0 .OR. ( N*L ).GT.( M*K ) ) THEN + INFO = -5 + ELSE IF ( COMPO .AND. RB.LT.0 ) THEN + INFO = -6 + ELSE IF ( COMPU .AND. RC.LT.0 ) THEN + INFO = -7 + ELSE IF ( LDTC.LT.MAX( 1, M*K ) ) THEN + INFO = -9 + ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN + INFO = -11 + ELSE IF ( LDB.LT.1 .OR. ( COMPO .AND. LDB.LT.M*K ) ) THEN + INFO = -13 + ELSE IF ( LDC.LT.1 .OR. ( COMPU .AND. LDC.LT.M*K ) ) THEN + INFO = -15 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = -17 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02ID', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( COMPO .AND. MIN( N*L, RB ).EQ.0 ) THEN + COMPO = .FALSE. + END IF + IF( COMPU .AND. MIN( N*L, RC ).EQ.0 ) THEN + CALL DLASET( 'Full', M*K, RC, ZERO, ZERO, C, LDC ) + COMPU = .FALSE. + END IF + IF ( .NOT.( COMPO .OR. COMPU ) ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Check cases M = 1 or N = 1. +C + IF ( MIN( M, N ).EQ.1 ) THEN + PDW = K*L*M*N + IF ( COMPO ) THEN + CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) + CALL DLACPY( 'All', K, (N-1)*L, TR, LDTR, DWORK(K*L+1), + $ M*K ) + CALL DGELS( 'NonTranspose', M*K, N*L, RB, DWORK, M*K, B, + $ LDB, DWORK(PDW+1), LDWORK-PDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+1) ) + PDW ) + END IF + IF ( COMPU ) THEN + CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) + CALL DLACPY( 'All', K, (N-1)*L, TR, LDTR, DWORK(K*L+1), + $ M*K ) + CALL DGELS( 'Transpose', M*K, N*L, RC, DWORK, M*K, C, LDC, + $ DWORK(PDW+1), LDWORK-PDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+1) ) + PDW ) + END IF + DWORK(1) = DBLE( WRKOPT ) + RETURN + END IF +C +C Step 1: Compute the generator. +C + IF ( COMPO ) THEN + CALL MB02KD( 'Column', 'Transpose', K, L, M, N, RB, ONE, ZERO, + $ TC, LDTC, TR, LDTR, B, LDB, DWORK, N*L, + $ DWORK(N*L*RB+1), LDWORK-N*L*RB, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(N*L*RB+1) ) + N*L*RB ) + CALL DLACPY( 'All', N*L, RB, DWORK, N*L, B, LDB ) + END IF +C + PDW = N*L*L + 1 + CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK(PDW), M*K ) + CALL DGEQRF( M*K, L, DWORK(PDW), M*K, DWORK(PDW+M*K*L), + $ DWORK(PDW+(M*K+1)*L), LDWORK-PDW-(M*K+1)*L-1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(M*K+1)*L) ) + + $ PDW + (M*K+1)*L - 1 ) +C + DO 10 I = PDW, PDW + M*K*L - 1, M*K + 1 + IF ( DWORK(I).EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF + 10 CONTINUE +C + CALL MA02AD( 'Upper', L, L, DWORK(PDW), M*K, DWORK, N*L ) + CALL DORGQR( M*K, L, L, DWORK(PDW), M*K, DWORK(PDW+M*K*L), + $ DWORK(PDW+(M*K+1)*L), LDWORK-PDW-(M*K+1)*L-1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(M*K+1)*L) ) + + $ PDW + (M*K+1)*L - 1 ) + CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE, ZERO, + $ TC, LDTC, TR, LDTR, DWORK(PDW), M*K, DWORK(L+1), + C N*L, DWORK(PDW+M*K*L), LDWORK-PDW-M*K*L+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K*L) ) + PDW + M*K*L - 1 ) + PPR = N*L*L + 1 + PNR = N*L*( L + K ) + 1 + CALL MA02AD( 'All', K, (N-1)*L, TR, LDTR, DWORK(PPR+L), N*L ) + CALL DLACPY( 'All', (N-1)*L, L, DWORK(L+1), N*L, DWORK(PNR+L), + $ N*L ) + PT = ( M - 1 )*K + 1 + PDW = PNR + N*L*L + L +C + DO 30 I = 1, MIN( M, N-1 ) + CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW), N*L ) + PT = PT - K + PDW = PDW + L + 30 CONTINUE +C + PT = 1 +C + DO 40 I = M + 1, N - 1 + CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW), N*L ) + PT = PT + L + PDW = PDW + L + 40 CONTINUE +C + IF ( COMPO ) THEN +C +C Apply the first reduction step to T'*B. +C + CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', + $ L, RB, ONE, DWORK, N*L, B, LDB ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', (N-1)*L, RB, L, ONE, + $ DWORK(L+1), N*L, B, LDB, -ONE, B(L+1,1), LDB ) + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', L, + $ RB, ONE, DWORK, N*L, B, LDB ) + END IF +C + IF ( COMPU ) THEN +C +C Apply the first reduction step to C. +C + CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', + $ L, RC, ONE, DWORK, N*L, C, LDC ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', (N-1)*L, RC, L, ONE, + $ DWORK(L+1), N*L, C, LDC, -ONE, C(L+1,1), LDC ) + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', L, + $ RC, ONE, DWORK, N*L, C, LDC ) + END IF +C + PDI = ( N - 1 )*L + 1 + CALL DLACPY( 'Lower', L, L, DWORK, N*L, DWORK(PDI), N*L ) + CALL DTRTRI( 'Lower', 'NonUnit', L, DWORK(PDI), N*L, IERR ) + CALL MA02AD( 'Lower', L-1, L, DWORK(PDI+1), N*L, + $ DWORK((2*N-1)*L+1), N*L ) + CALL DLASET( 'Lower', L-1, L, ZERO, ZERO, DWORK(PDI+1), N*L ) + CALL DLACPY( 'Upper', L, L, DWORK(PDI), N*L, DWORK(PNR), N*L ) + CALL DLASET( 'Lower', L-1, L, ZERO, ZERO, DWORK(PNR+1), N*L ) + CALL DLASET( 'All', L, K, ZERO, ZERO, DWORK(PPR), N*L ) + CALL DLASET( 'All', L, K, ZERO, ZERO, DWORK(PNR+N*L*L), N*L ) +C + PPI = PPR + PPR = PPR + L + PNI = PNR + PNR = PNR + L + PDW = 2*N*L*( L + K ) + 1 + LEN = ( N - 1 )*L +C +C Determine block size for the involved block Householder +C transformations. +C + NB = MIN( ILAENV( 1, 'DGELQF', ' ', N*L, L, -1, -1 ), L ) + KK = PDW + 6*L - 1 + WRKOPT = MAX( WRKOPT, KK + N*L*NB ) + KK = LDWORK - KK + IF ( KK.LT.N*L*NB ) NB = KK / ( N*L ) + NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', N*L, L, -1, -1 ) ) + IF ( NB.LT.NBMIN ) NB = 0 +C + DO 50 I = L + 1, N*L, L + CALL MB02CU( 'Column', L, L+K, L+K, NB, DWORK, N*L, DWORK(PPR), + $ N*L, DWORK(PNR), N*L, RNK, IPVT, DWORK(PDW), ZERO, + $ DWORK(PDW+6*L), LDWORK-PDW-6*L+1, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The rank condition is (numerically) not +C satisfied. +C + INFO = 1 + RETURN + END IF + CALL MB02CV( 'Column', 'NoStructure', L, LEN-L, L+K, L+K, NB, + $ -1, DWORK, N*L, DWORK(PPR), N*L, DWORK(PNR), N*L, + $ DWORK(L+1), N*L, DWORK(PPR+L), N*L, DWORK(PNR+L), + $ N*L, DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, + $ IERR ) + PDI = PDI - L + IF ( COMPO ) THEN +C +C Block Gaussian elimination to B. +C + CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', + $ L, RB, -ONE, DWORK, N*L, B(I,1), LDB ) + IF ( LEN.GT.L ) THEN + CALL DGEMM( 'NonTranspose', 'NonTranspose', LEN-L, RB, L, + $ ONE, DWORK(L+1), N*L, B(I,1), LDB, ONE, + $ B(I+L,1), LDB ) + END IF + END IF + IF ( COMPU ) THEN +C +C Block Gaussian elimination to C. +C + CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', + $ L, RC, -ONE, DWORK, N*L, C(I,1), LDC ) + IF ( LEN.GT.L ) THEN + CALL DGEMM( 'NonTranspose', 'NonTranspose', LEN-L, RC, L, + $ ONE, DWORK(L+1), N*L, C(I,1), LDC, ONE, + $ C(I+L,1), LDC ) + END IF + END IF + CALL DLASET( 'All', L, L, ZERO, ZERO, DWORK(PDI), N*L ) + CALL MB02CV( 'Column', 'Triangular', L, I+L-1, L+K, L+K, NB, + $ -1, DWORK, N*L, DWORK(PPR), N*L, DWORK(PNR), N*L, + $ DWORK(PDI), N*L, DWORK(PPI), N*L, DWORK(PNI), N*L, + $ DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, + $ IERR ) + IF ( COMPO ) THEN +C +C Apply block Gaussian elimination to B. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', I-1, RB, L, ONE, + $ DWORK(PDI), N*L, B(I,1), LDB, ONE, B, LDB ) + CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit', L, + $ RB, ONE, DWORK((N-1)*L+1), N*L, B(I,1), LDB ) + END IF + IF ( COMPU ) THEN +C +C Apply block Gaussian elimination to C. +C + CALL DGEMM( 'NonTranspose', 'NonTranspose', I-1, RC, L, ONE, + $ DWORK(PDI), N*L, C(I,1), LDC, ONE, C, LDC ) + CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit', L, + $ RC, ONE, DWORK((N-1)*L+1), N*L, C(I,1), LDC ) + END IF + LEN = LEN - L + PNR = PNR + L + PPR = PPR + L + 50 CONTINUE +C + IF ( COMPU ) THEN + CALL MB02KD( 'Column', 'NonTranspose', K, L, M, N, RC, ONE, + $ ZERO, TC, LDTC, TR, LDTR, C, LDC, DWORK, M*K, + $ DWORK(M*K*RC+1), LDWORK-M*K*RC, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(M*K*RC+1) ) + M*K*RC ) + CALL DLACPY( 'All', M*K, RC, DWORK, M*K, C, LDC ) + END IF + DWORK(1) = DBLE( WRKOPT ) + RETURN +C +C *** Last line of MB02ID *** + END diff --git a/mex/sources/libslicot/MB02JD.f b/mex/sources/libslicot/MB02JD.f new file mode 100644 index 000000000..95c49b43a --- /dev/null +++ b/mex/sources/libslicot/MB02JD.f @@ -0,0 +1,486 @@ + SUBROUTINE MB02JD( JOB, K, L, M, N, P, S, TC, LDTC, TR, LDTR, Q, + $ LDQ, R, LDR, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a lower triangular matrix R and a matrix Q with +C Q^T Q = I such that +C T +C T = Q R , +C +C where T is a K*M-by-L*N block Toeplitz matrix with blocks of size +C (K,L). The first column of T will be denoted by TC and the first +C row by TR. It is assumed that the first MIN(M*K, N*L) columns of T +C have full rank. +C +C By subsequent calls of this routine the factors Q and R can be +C computed block column by block column. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the output of the routine as follows: +C = 'Q': computes Q and R; +C = 'R': only computes R. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows in one block of T. K >= 0. +C +C L (input) INTEGER +C The number of columns in one block of T. L >= 0. +C +C M (input) INTEGER +C The number of blocks in one block column of T. M >= 0. +C +C N (input) INTEGER +C The number of blocks in one block row of T. N >= 0. +C +C P (input) INTEGER +C The number of previously computed block columns of R. +C P*L < MIN( M*K,N*L ) + L and P >= 0. +C +C S (input) INTEGER +C The number of block columns of R to compute. +C (P+S)*L < MIN( M*K,N*L ) + L and S >= 0. +C +C TC (input) DOUBLE PRECISION array, dimension (LDTC, L) +C On entry, if P = 0, the leading M*K-by-L part of this +C array must contain the first block column of T. +C +C LDTC INTEGER +C The leading dimension of the array TC. +C LDTC >= MAX(1,M*K). +C +C TR (input) DOUBLE PRECISION array, dimension (LDTR,(N-1)*L) +C On entry, if P = 0, the leading K-by-(N-1)*L part of this +C array must contain the first block row of T without the +C leading K-by-L block. +C +C LDTR INTEGER +C The leading dimension of the array TR. +C LDTR >= MAX(1,K). +C +C Q (input/output) DOUBLE PRECISION array, dimension +C (LDQ,MIN( S*L, MIN( M*K,N*L )-P*L )) +C On entry, if JOB = 'Q' and P > 0, the leading M*K-by-L +C part of this array must contain the last block column of Q +C from a previous call of this routine. +C On exit, if JOB = 'Q' and INFO = 0, the leading +C M*K-by-MIN( S*L, MIN( M*K,N*L )-P*L ) part of this array +C contains the P-th to (P+S)-th block columns of the factor +C Q. +C +C LDQ INTEGER +C The leading dimension of the array Q. +C LDQ >= MAX(1,M*K), if JOB = 'Q'; +C LDQ >= 1, if JOB = 'R'. +C +C R (input/output) DOUBLE PRECISION array, dimension +C (LDR,MIN( S*L, MIN( M*K,N*L )-P*L )) +C On entry, if P > 0, the leading (N-P+1)*L-by-L +C part of this array must contain the nozero part of the +C last block column of R from a previous call of this +C routine. +C One exit, if INFO = 0, the leading +C MIN( N, N-P+1 )*L-by-MIN( S*L, MIN( M*K,N*L )-P*L ) +C part of this array contains the nonzero parts of the P-th +C to (P+S)-th block columns of the lower triangular +C factor R. +C Note that elements in the strictly upper triangular part +C will not be referenced. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= MAX( 1, MIN( N, N-P+1 )*L ) +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C On exit, if INFO = -17, DWORK(1) returns the minimum +C value of LDWORK. +C If JOB = 'Q', the first 1 + ( (N-1)*L + M*K )*( 2*K + L ) +C elements of DWORK should be preserved during successive +C calls of the routine. +C If JOB = 'R', the first 1 + (N-1)*L*( 2*K + L ) elements +C of DWORK should be preserved during successive calls of +C the routine. +C +C LDWORK INTEGER +C The length of the array DWORK. +C JOB = 'Q': +C LDWORK >= 1 + ( M*K + ( N - 1 )*L )*( L + 2*K ) + 6*L +C + MAX( M*K,( N - MAX( 1,P )*L ) ); +C JOB = 'R': +C If P = 0, +C LDWORK >= MAX( 1 + ( N - 1 )*L*( L + 2*K ) + 6*L +C + (N-1)*L, M*K*( L + 1 ) + L ); +C If P > 0, +C LDWORK >= 1 + (N-1)*L*( L + 2*K ) + 6*L + (N-P)*L. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the full rank condition for the first MIN(M*K, N*L) +C columns of T is (numerically) violated. +C +C METHOD +C +C Block Householder transformations and modified hyperbolic +C rotations are used in the Schur algorithm [1], [2]. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The implemented method yields a factor R which has comparable +C accuracy with the Cholesky factor of T^T * T. Q is implicitly +C computed from the formula Q = T * inv(R^T R) * R, i.e., for ill +C conditioned problems this factor is of very limited value. +C 2 +C The algorithm requires 0(K*L *M*N) floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001. +C D. Kressner, Technical Univ. Berlin, Germany, July 2002. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, K, L, LDQ, LDR, LDTC, LDTR, LDWORK, + $ M, N, P, S +C .. Array Arguments .. + DOUBLE PRECISION DWORK(LDWORK), Q(LDQ,*), R(LDR,*), TC(LDTC,*), + $ TR(LDTR,*) +C .. Local Scalars .. + INTEGER COLR, I, IERR, KK, LEN, NB, NBMIN, PDQ, PDW, + $ PNQ, PNR, PRE, PT, RNK, SHFR, STPS, WRKMIN, + $ WRKOPT + LOGICAL COMPQ +C .. Local Arrays .. + INTEGER IPVT(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DGEQRF, DLACPY, DLASET, DORGQR, MA02AD, MB02CU, + $ MB02CV, MB02KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + COMPQ = LSAME( JOB, 'Q' ) + IF ( COMPQ ) THEN + WRKMIN = 1 + ( M*K + ( N - 1 )*L )*( L + 2*K ) + 6*L + $ + MAX( M*K, ( N - MAX( 1, P ) )*L ) + ELSE + WRKMIN = 1 + ( N - 1 )*L*( L + 2*K ) + 6*L + $ + ( N - MAX( P, 1 ) )*L + IF ( P.EQ.0 ) THEN + WRKMIN = MAX( WRKMIN, M*K*( L + 1 ) + L ) + END IF + END IF +C +C Check the scalar input parameters. +C + IF ( .NOT.( COMPQ .OR. LSAME( JOB, 'R' ) ) ) THEN + INFO = -1 + ELSE IF ( K.LT.0 ) THEN + INFO = -2 + ELSE IF ( L.LT.0 ) THEN + INFO = -3 + ELSE IF ( M.LT.0 ) THEN + INFO = -4 + ELSE IF ( N.LT.0 ) THEN + INFO = -5 + ELSE IF ( P*L.GE.MIN( M*K, N*L ) + L .OR. P.LT.0 ) THEN + INFO = -6 + ELSE IF ( ( P + S )*L.GE.MIN( M*K, N*L ) + L .OR. S.LT.0 ) THEN + INFO = -7 + ELSE IF ( LDTC.LT.MAX( 1, M*K ) ) THEN + INFO = -9 + ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN + INFO = -11 + ELSE IF ( LDQ.LT.1 .OR. ( COMPQ .AND. LDQ.LT.M*K ) ) THEN + INFO = -13 + ELSE IF ( LDR.LT.MAX( 1, MIN( N, N - P + 1 )*L ) ) THEN + INFO = -15 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = -17 + END IF +C +C Return if there were illegal values. +C + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'MB02JD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( M, N, K*L, S ) .EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Catch M*K <= L. +C + WRKOPT = 1 + IF ( M*K.LE.L ) THEN + CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) + PDW = M*K*L + 1 + CALL DGEQRF( M*K, L, DWORK, M*K, DWORK(PDW), + $ DWORK(PDW+M*K), LDWORK-PDW-M*K+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K) ) + PDW + M*K - 1 ) + CALL MA02AD( 'Upper part', M*K, L, DWORK, M*K, R, LDR ) + CALL DORGQR( M*K, M*K, M*K, DWORK, M*K, DWORK(PDW), + $ DWORK(PDW+M*K), LDWORK-PDW-M*K+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K) ) + PDW + M*K - 1 ) + IF ( COMPQ ) THEN + CALL DLACPY( 'All', M*K, M*K, DWORK, M*K, Q, LDQ ) + END IF + PDW = M*K*M*K + 1 + IF ( N.GT.1 ) THEN + CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, M*K, ONE, + $ ZERO, TC, LDTC, TR, LDTR, DWORK, M*K, R(L+1,1), + $ LDR, DWORK(PDW), LDWORK-PDW+1, IERR ) + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) + DWORK(1) = DBLE( WRKOPT ) + RETURN + END IF +C +C Compute the generator if P = 0. +C + IF ( P.EQ.0 ) THEN +C +C 1st column of the generator. +C + IF ( COMPQ ) THEN + CALL DLACPY( 'All', M*K, L, TC, LDTC, Q, LDQ ) + CALL DGEQRF( M*K, L, Q, LDQ, DWORK, DWORK(L+1), + $ LDWORK-L, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) + CALL MA02AD( 'Upper part', L, L, Q, LDQ, R, LDR ) + CALL DORGQR( M*K, L, L, Q, LDQ, DWORK, DWORK(L+1), LDWORK-L, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) + IF ( N.GT.1 ) THEN + CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE, + $ ZERO, TC, LDTC, TR, LDTR, Q, LDQ, R(L+1,1), + $ LDR, DWORK, LDWORK, IERR ) + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + ELSE + PDW = M*K*L + 1 + CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) + CALL DGEQRF( M*K, L, DWORK, M*K, DWORK(PDW), DWORK(PDW+L), + $ LDWORK-PDW-L+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L) ) + PDW + L - 1 ) + CALL MA02AD( 'Upper part', L, L, DWORK, M*K, R, LDR ) + CALL DORGQR( M*K, L, L, DWORK, M*K, DWORK(PDW), + $ DWORK(PDW+L), LDWORK-PDW-L+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L) ) + PDW + L - 1 ) + IF ( N.GT.1 ) THEN + CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE, + $ ZERO, TC, LDTC, TR, LDTR, DWORK, M*K, + $ R(L+1,1), LDR, DWORK(PDW), LDWORK-PDW+1, + $ IERR ) + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) + END IF +C +C Quick return if N = 1. +C + IF ( N.EQ.1 ) THEN + DWORK(1) = DBLE( WRKOPT ) + RETURN + END IF +C +C 2nd column of the generator. +C + PNR = ( N - 1 )*L*K + 2 + CALL MA02AD( 'All', K, (N-1)*L, TR, LDTR, DWORK(2), (N-1)*L ) +C +C 3rd and 4th column of the generator. +C + CALL DLACPY( 'All', (N-1)*L, L, R(L+1,1), LDR, DWORK(PNR), + $ (N-1)*L ) + PT = ( M - 1 )*K + 1 + PDW = PNR + ( N - 1 )*L*L +C + DO 10 I = 1, MIN( M, N-1 ) + CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW), + $ (N-1)*L ) + PT = PT - K + PDW = PDW + L + 10 CONTINUE +C + PT = 1 +C + DO 20 I = M + 1, N - 1 + CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW), + $ (N-1)*L ) + PT = PT + L + PDW = PDW + L + 20 CONTINUE +C + IF ( COMPQ ) THEN + PDQ = ( 2*K + L )*( N - 1 )*L + 2 + PDW = ( 2*K + L )*( ( N - 1 )*L + M*K ) + 2 + PNQ = PDQ + M*K*K + CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(PDQ), M*K ) + CALL DLASET( 'All', (M-1)*K, K, ZERO, ZERO, DWORK(PDQ+K), + $ M*K ) + CALL DLACPY( 'All', M*K, L, Q, LDQ, DWORK(PNQ), M*K ) + CALL DLASET( 'All', M*K, K, ZERO, ZERO, DWORK(PNQ+M*L*K), + $ M*K ) + ELSE + PDW = ( 2*K + L )*( N - 1 )*L + 2 + END IF + PRE = 1 + STPS = S - 1 + ELSE +C +C Set workspace pointers. +C + PNR = ( N - 1 )*L*K + 2 + IF ( COMPQ ) THEN + PDQ = ( 2*K + L )*( N - 1 )*L + 2 + PDW = ( 2*K + L )*( ( N - 1 )*L + M*K ) + 2 + PNQ = PDQ + M*K*K + ELSE + PDW = ( 2*K + L )*( N - 1 )*L + 2 + END IF + PRE = P + STPS = S + END IF +C +C Determine suitable size for the block Housholder reflectors. +C + IF ( COMPQ ) THEN + LEN = MAX( L + M*K, ( N - PRE + 1 )*L ) + ELSE + LEN = ( N - PRE + 1 )*L + END IF + NB = MIN( ILAENV( 1, 'DGELQF', ' ', LEN, L, -1, -1 ), L ) + KK = PDW + 6*L - 1 + WRKOPT = MAX( WRKOPT, KK + LEN*NB ) + KK = LDWORK - KK + IF ( KK.LT.LEN*NB ) NB = KK / LEN + NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LEN, L, -1, -1 ) ) + IF ( NB.LT.NBMIN ) NB = 0 + COLR = L + 1 +C +C Generator reduction process. +C + LEN = ( N - PRE )*L + SHFR = ( PRE - 1 )*L + DO 30 I = PRE, PRE + STPS - 1 +C +C IF M*K < N*L the last block might have less than L columns. +C + KK = MIN( L, M*K - I*L ) + CALL DLACPY( 'Lower', LEN, KK, R(COLR-L,COLR-L), LDR, + $ R(COLR,COLR), LDR ) + CALL MB02CU( 'Column', KK, KK+K, L+K, NB, R(COLR,COLR), LDR, + $ DWORK(SHFR+2), (N-1)*L, DWORK(PNR+SHFR), (N-1)*L, + $ RNK, IPVT, DWORK(PDW), ZERO, DWORK(PDW+6*L), + $ LDWORK-PDW-6*L+1, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The rank condition is (numerically) not +C satisfied. +C + INFO = 1 + RETURN + END IF + IF ( LEN.GT.KK ) THEN + CALL MB02CV( 'Column', 'NoStructure', KK, LEN-KK, KK+K, L+K, + $ NB, -1, R(COLR,COLR), LDR, DWORK(SHFR+2), + $ (N-1)*L, DWORK(PNR+SHFR), (N-1)*L, + $ R(COLR+KK,COLR), LDR, DWORK(SHFR+KK+2), + $ (N-1)*L, DWORK(PNR+SHFR+KK), (N-1)*L, + $ DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, + $ IERR ) + END IF + IF ( COMPQ ) THEN + CALL DLASET( 'All', K, KK, ZERO, ZERO, Q(1,COLR), LDQ ) + IF ( M.GT.1 ) THEN + CALL DLACPY( 'All', (M-1)*K, KK, Q(1,COLR-L), LDQ, + $ Q(K+1,COLR), LDQ ) + END IF + CALL MB02CV( 'Column', 'NoStructure', KK, M*K, KK+K, L+K, + $ NB, -1, R(COLR,COLR), LDR, DWORK(SHFR+2), + $ (N-1)*L, DWORK(PNR+SHFR), (N-1)*L, Q(1,COLR), + $ LDQ, DWORK(PDQ), M*K, DWORK(PNQ), M*K, + $ DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, + $ IERR ) + END IF + LEN = LEN - L + COLR = COLR + L + SHFR = SHFR + L + 30 CONTINUE +C + DWORK(1) = DBLE( WRKOPT ) + RETURN +C +C *** Last line of MB02JD *** + END diff --git a/mex/sources/libslicot/MB02JX.f b/mex/sources/libslicot/MB02JX.f new file mode 100644 index 000000000..c941bd446 --- /dev/null +++ b/mex/sources/libslicot/MB02JX.f @@ -0,0 +1,737 @@ + SUBROUTINE MB02JX( JOB, K, L, M, N, TC, LDTC, TR, LDTR, RNK, Q, + $ LDQ, R, LDR, JPVT, TOL1, TOL2, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a low rank QR factorization with column pivoting of a +C K*M-by-L*N block Toeplitz matrix T with blocks of size (K,L); +C specifically, +C T +C T P = Q R , +C +C where R is lower trapezoidal, P is a block permutation matrix +C and Q^T Q = I. The number of columns in R is equivalent to the +C numerical rank of T with respect to the given tolerance TOL1. +C Note that the pivoting scheme is local, i.e., only columns +C belonging to the same block in T are permuted. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the output of the routine as follows: +C = 'Q': computes Q and R; +C = 'R': only computes R. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows in one block of T. K >= 0. +C +C L (input) INTEGER +C The number of columns in one block of T. L >= 0. +C +C M (input) INTEGER +C The number of blocks in one block column of T. M >= 0. +C +C N (input) INTEGER +C The number of blocks in one block row of T. N >= 0. +C +C TC (input) DOUBLE PRECISION array, dimension (LDTC, L) +C The leading M*K-by-L part of this array must contain +C the first block column of T. +C +C LDTC INTEGER +C The leading dimension of the array TC. +C LDTC >= MAX(1,M*K). +C +C TR (input) DOUBLE PRECISION array, dimension (LDTR,(N-1)*L) +C The leading K-by-(N-1)*L part of this array must contain +C the first block row of T without the leading K-by-L +C block. +C +C LDTR INTEGER +C The leading dimension of the array TR. LDTR >= MAX(1,K). +C +C RNK (output) INTEGER +C The number of columns in R, which is equivalent to the +C numerical rank of T. +C +C Q (output) DOUBLE PRECISION array, dimension (LDQ,RNK) +C If JOB = 'Q', then the leading M*K-by-RNK part of this +C array contains the factor Q. +C If JOB = 'R', then this array is not referenced. +C +C LDQ INTEGER +C The leading dimension of the array Q. +C LDQ >= MAX(1,M*K), if JOB = 'Q'; +C LDQ >= 1, if JOB = 'R'. +C +C R (output) DOUBLE PRECISION array, dimension (LDR,RNK) +C The leading N*L-by-RNK part of this array contains the +C lower trapezoidal factor R. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= MAX(1,N*L) +C +C JPVT (output) INTEGER array, dimension (MIN(M*K,N*L)) +C This array records the column pivoting performed. +C If JPVT(j) = k, then the j-th column of T*P was +C the k-th column of T. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If TOL1 >= 0.0, the user supplied diagonal tolerance; +C if TOL1 < 0.0, a default diagonal tolerance is used. +C +C TOL2 DOUBLE PRECISION +C If TOL2 >= 0.0, the user supplied offdiagonal tolerance; +C if TOL2 < 0.0, a default offdiagonal tolerance is used. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK; DWORK(2) and DWORK(3) return the used values +C for TOL1 and TOL2, respectively. +C On exit, if INFO = -19, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 3, ( M*K + ( N - 1 )*L )*( L + 2*K ) + 9*L +C + MAX(M*K,(N-1)*L) ), if JOB = 'Q'; +C LDWORK >= MAX( 3, ( N - 1 )*L*( L + 2*K + 1 ) + 9*L, +C M*K*( L + 1 ) + L ), if JOB = 'R'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: due to perturbations induced by roundoff errors, or +C removal of nearly linearly dependent columns of the +C generator, the Schur algorithm encountered a +C situation where a diagonal element in the negative +C generator is larger in magnitude than the +C corresponding diagonal element in the positive +C generator (modulo TOL1); +C = 2: due to perturbations induced by roundoff errors, or +C removal of nearly linearly dependent columns of the +C generator, the Schur algorithm encountered a +C situation where diagonal elements in the positive +C and negative generator are equal in magnitude +C (modulo TOL1), but the offdiagonal elements suggest +C that these columns are not linearly dependent +C (modulo TOL2*ABS(diagonal element)). +C +C METHOD +C +C Householder transformations and modified hyperbolic rotations +C are used in the Schur algorithm [1], [2]. +C If, during the process, the hyperbolic norm of a row in the +C leading part of the generator is found to be less than or equal +C to TOL1, then this row is not reduced. If the difference of the +C corresponding columns has a norm less than or equal to TOL2 times +C the magnitude of the leading element, then this column is removed +C from the generator, as well as from R. Otherwise, the algorithm +C breaks down. TOL1 is set to norm(TC)*sqrt(eps) and TOL2 is set +C to N*L*sqrt(eps) by default. +C If M*K > L, the columns of T are permuted so that the diagonal +C elements in one block column of R have decreasing magnitudes. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0(K*RNK*L*M*N) floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001. +C D. Kressner, Technical Univ. Berlin, Germany, July 2002. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, K, L, LDQ, LDR, LDTC, LDTR, LDWORK, M, N, + $ RNK + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + DOUBLE PRECISION DWORK(LDWORK), Q(LDQ,*), R(LDR,*), TC(LDTC,*), + $ TR(LDTR,*) + INTEGER JPVT(*) +C .. Local Scalars .. + LOGICAL COMPQ, LAST + INTEGER CPCOL, GAP, I, IERR, J, JJ, JWORK, KK, LEN, MK, + $ NZC, PDP, PDQ, PDW, PNQ, PNR, PP, PPR, PT, RDEF, + $ RRDF, RRNK, WRKMIN, WRKOPT + DOUBLE PRECISION LTOL1, LTOL2, NRM, TEMP +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL DLAMCH, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEQP3, DGEQRF, DLACPY, DLASET, + $ DORGQR, DSCAL, DSWAP, DTRMV, MA02AD, MB02CU, + $ MB02CV, MB02KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + WRKOPT = 3 + MK = M*K + COMPQ = LSAME( JOB, 'Q' ) + IF ( COMPQ ) THEN + WRKMIN = MAX( 3, ( MK + ( N - 1 )*L )*( L + 2*K ) + 9*L + + $ MAX( MK, ( N - 1 )*L ) ) + ELSE + WRKMIN = MAX( 3, MAX ( ( N - 1 )*L*( L + 2*K + 1 ) + 9*L, + $ MK*( L + 1 ) + L ) ) + END IF +C +C Check the scalar input parameters. +C + IF ( .NOT.( COMPQ .OR. LSAME( JOB, 'R' ) ) ) THEN + INFO = -1 + ELSE IF ( K.LT.0 ) THEN + INFO = -2 + ELSE IF ( L.LT.0 ) THEN + INFO = -3 + ELSE IF ( M.LT.0 ) THEN + INFO = -4 + ELSE IF ( N.LT.0 ) THEN + INFO = -5 + ELSE IF ( LDTC.LT.MAX( 1, MK ) ) THEN + INFO = -7 + ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN + INFO = -9 + ELSE IF ( LDQ.LT.1 .OR. ( COMPQ .AND. LDQ.LT.MK ) ) THEN + INFO = -12 + ELSE IF ( LDR.LT.MAX( 1, N*L ) ) THEN + INFO = -14 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = -19 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02JX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( M, N, K, L ).EQ.0 ) THEN + RNK = 0 + DWORK(1) = DBLE( WRKOPT ) + DWORK(2) = ZERO + DWORK(3) = ZERO + RETURN + END IF +C + WRKOPT = WRKMIN +C + IF ( MK.LE.L ) THEN +C +C Catch M*K <= L. +C + CALL DLACPY( 'All', MK, L, TC, LDTC, DWORK, MK ) + PDW = MK*L + 1 + JWORK = PDW + MK + CALL DGEQRF( MK, L, DWORK, MK, DWORK(PDW), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + CALL MA02AD( 'Upper part', MK, L, DWORK, MK, R, LDR ) + CALL DORGQR( MK, MK, MK, DWORK, MK, DWORK(PDW), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF ( COMPQ ) + $ CALL DLACPY( 'All', MK, MK, DWORK, MK, Q, LDQ ) + PDW = MK*MK + 1 + IF ( N.GT.1 ) THEN + CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, MK, ONE, + $ ZERO, TC, LDTC, TR, LDTR, DWORK, MK, R(L+1,1), + $ LDR, DWORK(PDW), LDWORK-PDW+1, IERR ) + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) +C + DO 10 I = 1, MK + JPVT(I) = I + 10 CONTINUE +C + RNK = MK + DWORK(1) = DBLE( WRKOPT ) + DWORK(2) = ZERO + DWORK(3) = ZERO + RETURN + END IF +C +C Compute the generator: +C +C 1st column of the generator. +C + DO 20 I = 1, L + JPVT(I) = 0 + 20 CONTINUE +C + LTOL1 = TOL1 + LTOL2 = TOL2 +C + IF ( COMPQ ) THEN + CALL DLACPY( 'All', MK, L, TC, LDTC, Q, LDQ ) + CALL DGEQP3( MK, L, Q, LDQ, JPVT, DWORK, DWORK(L+1), + $ LDWORK-L, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) +C + IF ( LTOL1.LT.ZERO ) THEN +C +C Compute default tolerance LTOL1. +C +C Estimate the 2-norm of the first block column of the +C matrix with 5 power iterations. +C + TEMP = ONE / SQRT( DBLE( L ) ) + CALL DLASET( 'All', L, 1, TEMP, TEMP, DWORK(L+1), 1 ) +C + DO 30 I = 1, 5 + CALL DTRMV( 'Upper', 'NonTranspose', 'NonUnit', L, Q, + $ LDQ, DWORK(L+1), 1 ) + CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', L, Q, LDQ, + $ DWORK(L+1), 1 ) + NRM = DNRM2( L, DWORK(L+1), 1 ) + CALL DSCAL( L, ONE/NRM, DWORK(L+1), 1 ) + 30 CONTINUE +C + LTOL1 = SQRT( NRM*DLAMCH( 'Epsilon' ) ) + END IF +C + I = L +C + 40 CONTINUE + IF ( ABS( Q(I,I) ).LE.LTOL1 ) THEN + I = I - 1 + IF ( I.GT.0 ) GO TO 40 + END IF +C + RRNK = I + RRDF = L - RRNK + CALL MA02AD( 'Upper', RRNK, L, Q, LDQ, R, LDR ) + IF ( RRNK.GT.1 ) + $ CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(1,2), LDR ) + CALL DORGQR( MK, L, RRNK, Q, LDQ, DWORK, DWORK(L+1), LDWORK-L, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) + IF ( N.GT.1 ) THEN + CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, RRNK, ONE, + $ ZERO, TC, LDTC, TR, LDTR, Q, LDQ, R(L+1,1), + $ LDR, DWORK, LDWORK, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + END IF +C + ELSE +C + PDW = MK*L + 1 + JWORK = PDW + L + CALL DLACPY( 'All', MK, L, TC, LDTC, DWORK, MK ) + CALL DGEQP3( MK, L, DWORK, MK, JPVT, DWORK(PDW), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + IF ( LTOL1.LT.ZERO ) THEN +C +C Compute default tolerance LTOL1. +C +C Estimate the 2-norm of the first block column of the +C matrix with 5 power iterations. +C + TEMP = ONE / SQRT( DBLE( L ) ) + CALL DLASET( 'All', L, 1, TEMP, TEMP, DWORK(JWORK), 1 ) +C + DO 50 I = 1, 5 + CALL DTRMV( 'Upper', 'NonTranspose', 'NonUnit', L, DWORK, + $ MK, DWORK(JWORK), 1 ) + CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', L, DWORK, + $ MK, DWORK(JWORK), 1 ) + NRM = DNRM2( L, DWORK(JWORK), 1 ) + CALL DSCAL( L, ONE/NRM, DWORK(JWORK), 1 ) + 50 CONTINUE +C + LTOL1 = SQRT( NRM*DLAMCH( 'Epsilon' ) ) + END IF +C + RRNK = L + I = ( L - 1 )*MK + L +C + 60 CONTINUE + IF ( ABS( DWORK(I) ).LE.LTOL1 ) THEN + RRNK = RRNK - 1 + I = I - MK - 1 + IF ( I.GT.0 ) GO TO 60 + END IF +C + RRDF = L - RRNK + CALL MA02AD( 'Upper part', RRNK, L, DWORK, MK, R, LDR ) + IF ( RRNK.GT.1 ) + $ CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(1,2), LDR ) + CALL DORGQR( MK, L, RRNK, DWORK, MK, DWORK(PDW), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF ( N.GT.1 ) THEN + CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, RRNK, ONE, + $ ZERO, TC, LDTC, TR, LDTR, DWORK, MK, R(L+1,1), + $ LDR, DWORK(PDW), LDWORK-PDW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) + END IF + END IF +C +C Quick return if N = 1. +C + IF ( N.EQ.1 ) THEN + RNK = RRNK + DWORK(1) = DBLE( WRKOPT ) + DWORK(2) = LTOL1 + DWORK(3) = ZERO + RETURN + END IF +C +C Compute default tolerance LTOL2. +C + IF ( LTOL2.LT.ZERO ) + $ LTOL2 = DBLE( N*L )*SQRT( DLAMCH( 'Epsilon' ) ) +C + DO 70 J = 1, L + CALL DCOPY( RRNK, R(J,1), LDR, R(L+JPVT(J),RRNK+1), LDR ) + 70 CONTINUE +C + IF ( N.GT.2 ) + $ CALL DLACPY( 'All', (N-2)*L, RRNK, R(L+1,1), LDR, + $ R(2*L+1,RRNK+1), LDR ) +C +C 2nd column of the generator. +C + IF ( RRDF.GT.0 ) + $ CALL MA02AD( 'All', MIN( RRDF, K ), (N-1)*L, TR, LDTR, + $ R(L+1,2*RRNK+1), LDR ) + IF ( K.GT.RRDF ) + $ CALL MA02AD( 'All', K-RRDF, (N-1)*L, TR(RRDF+1,1), LDTR, DWORK, + $ (N-1)*L ) +C +C 3rd column of the generator. +C + PNR = ( N - 1 )*L*MAX( 0, K-RRDF ) + 1 + CALL DLACPY( 'All', (N-1)*L, RRNK, R(L+1,1), LDR, DWORK(PNR), + $ (N-1)*L ) +C +C 4th column of the generator. +C + PDW = PNR + ( N - 1 )*L*RRNK + PT = ( M - 1 )*K + 1 +C + DO 80 I = 1, MIN( M, N-1 ) + CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW), (N-1)*L ) + PT = PT - K + PDW = PDW + L + 80 CONTINUE +C + PT = 1 +C + DO 90 I = M + 1, N - 1 + CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW), (N-1)*L ) + PT = PT + L + PDW = PDW + L + 90 CONTINUE +C + IF ( COMPQ ) THEN + PDQ = PNR + ( N - 1 )*L*( RRNK + K ) + PNQ = PDQ + MK*MAX( 0, K-RRDF ) + PDW = PNQ + MK*( RRNK + K ) + CALL DLACPY( 'All', MK, RRNK, Q, LDQ, DWORK(PNQ), MK ) + IF ( M.GT.1 ) + $ CALL DLACPY( 'All', (M-1)*K, RRNK, Q, LDQ, Q(K+1,RRNK+1), + $ LDQ ) + CALL DLASET( 'All', K, RRNK, ZERO, ZERO, Q(1,RRNK+1), LDQ ) + IF ( RRDF.GT.0 ) + $ CALL DLASET( 'All', MK, RRDF, ZERO, ONE, Q(1,2*RRNK+1), + $ LDQ ) + CALL DLASET( 'All', RRDF, MAX( 0, K-RRDF ), ZERO, ZERO, + $ DWORK(PDQ), MK ) + CALL DLASET( 'All', M*K-RRDF, MAX( 0, K-RRDF ), ZERO, ONE, + $ DWORK(PDQ+RRDF), MK ) + CALL DLASET( 'All', MK, K, ZERO, ZERO, DWORK(PNQ+MK*RRNK), MK ) + ELSE + PDW = PNR + ( N - 1 )*L*( RRNK + K ) + END IF + PPR = 1 + RNK = RRNK + RDEF = RRDF + LEN = N*L + GAP = N*L - MIN( N*L, MK ) +C +C KK is the number of columns in the leading part of the +C generator. After sufficiently many rank drops or if +C M*K < N*L it may be less than L. +C + KK = MIN( L+K-RDEF, L ) + KK = MIN( KK, MK-L ) +C +C Generator reduction process. +C + DO 190 I = L + 1, MIN( MK, N*L ), L + IF ( I+L.LE.MIN( MK, N*L ) ) THEN + LAST = .FALSE. + ELSE + LAST = .TRUE. + END IF + PP = KK + MAX( K - RDEF, 0 ) + LEN = LEN - L + CALL MB02CU( 'Deficient', KK, PP, L+K-RDEF, -1, R(I,RNK+1), + $ LDR, DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L, + $ RRNK, JPVT(I), DWORK(PDW), LTOL1, DWORK(PDW+5*L), + $ LDWORK-PDW-5*L+1, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The current generator is indefinite. +C + INFO = 1 + RETURN + END IF +C +C Apply pivoting to other columns of R. +C + PDP = PDW + 6*L - I +C + DO 100 J = I, I + KK - 1 + JPVT(J) = JPVT(J) + I - 1 + DWORK(PDP+JPVT(J)) = DBLE(J) + 100 CONTINUE +C + DO 120 J = I, I + KK - 1 + TEMP = DBLE(J) + JJ = J-1 +C + 110 CONTINUE + JJ = JJ + 1 + IF ( DWORK(PDP+JJ).NE.TEMP ) GO TO 110 +C + IF ( JJ.NE.J ) THEN + DWORK(PDP+JJ) = DWORK(PDP+J) + CALL DSWAP( RNK, R(J,1), LDR, R(JJ,1), LDR ) + END IF + 120 CONTINUE +C + DO 130 J = I + KK, I + L - 1 + JPVT(J) = J + 130 CONTINUE +C +C Apply reduction to other rows of R. +C + IF ( LEN.GT.KK ) THEN + CALL MB02CV( 'Deficient', 'NoStructure', KK, LEN-KK, PP, + $ L+K-RDEF, -1, RRNK, R(I,RNK+1), LDR, + $ DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L, + $ R(I+KK,RNK+1), LDR, DWORK(PPR+KK), (N-1)*L, + $ DWORK(PNR+KK), (N-1)*L, DWORK(PDW), + $ DWORK(PDW+5*L), LDWORK-PDW-5*L+1, IERR ) + END IF +C +C Apply reduction to Q. +C + IF ( COMPQ ) THEN + CALL MB02CV( 'Deficient', 'NoStructure', KK, MK, PP, + $ L+K-RDEF, -1, RRNK, R(I,RNK+1), LDR, + $ DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L, + $ Q(1,RNK+1), LDQ, DWORK(PDQ), MK, DWORK(PNQ), + $ MK, DWORK(PDW), DWORK(PDW+5*L), + $ LDWORK-PDW-5*L+1, IERR ) + END IF +C +C Inspection of the rank deficient columns: +C Look for small diagonal entries. +C + NZC = 0 +C + DO 140 J = KK, RRNK + 1, -1 + IF ( ABS( R(I+J-1,RNK+J) ).LE.LTOL1 ) NZC = NZC + 1 + 140 CONTINUE +C +C The last NZC columns of the generator cannot be removed. +C Now, decide whether for the other rank deficient columns +C it is safe to remove. +C + PT = PNR +C + DO 150 J = RRNK + 1, KK - NZC + TEMP = R(I+J-1,RNK+J) + CALL DSCAL( LEN-J-GAP, TEMP, R(I+J,RNK+J), 1 ) + CALL DAXPY( LEN-J-GAP, -DWORK(PT+J-1), DWORK(PT+J), 1, + $ R(I+J,RNK+J), 1 ) + IF ( DNRM2( LEN-J-GAP, R(I+J,RNK+J), 1 ) + $ .GT.LTOL2*ABS( TEMP ) ) THEN +C +C Unlucky case: +C It is neither advisable to remove the whole column nor +C possible to remove the diagonal entries by Hyperbolic +C rotations. +C + INFO = 2 + RETURN + END IF + PT = PT + ( N - 1 )*L + 150 CONTINUE +C +C Annihilate unwanted elements in the factor R. +C + RRDF = KK - RRNK + CALL DLASET( 'All', I-1, RRNK, ZERO, ZERO, R(1,RNK+1), LDR ) + CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(I,RNK+2), + $ LDR ) +C +C Construct the generator for the next step. +C + IF ( .NOT.LAST ) THEN +C +C Compute KK for the next step. +C + KK = MIN( L+K-RDEF-RRDF+NZC, L ) + KK = MIN( KK, MK-I-L+1 ) +C + IF ( KK.LE.0 ) THEN + RNK = RNK + RRNK + GO TO 200 + END IF +C + CALL DLASET( 'All', L, RRDF, ZERO, ZERO, R(I,RNK+RRNK+1), + $ LDR ) +C +C The columns with small diagonal entries form parts of the +C new positive generator. +C + IF ( ( RRDF-NZC ).GT.0 .AND. NZC.GT.0 ) THEN + CPCOL = MIN( NZC, KK ) +C + DO 160 J = RNK + RRNK + 1, RNK + RRNK + CPCOL + CALL DCOPY( LEN-L, R(I+L,J+RRDF-NZC), 1, + $ R(I+L,J), 1 ) + 160 CONTINUE +C + END IF +C +C Construct the leading parts of the positive generator. +C + CPCOL = MIN( RRNK, KK-NZC ) + IF ( CPCOL.GT.0 ) THEN +C + DO 170 J = I, I + L - 1 + CALL DCOPY( CPCOL, R(J,RNK+1), LDR, + $ R(JPVT(J)+L,RNK+RRNK+NZC+1), LDR ) + 170 CONTINUE +C + IF ( LEN.GT.2*L ) THEN + CALL DLACPY( 'All', LEN-2*L, CPCOL, R(I+L,RNK+1), LDR, + $ R(I+2*L,RNK+RRNK+NZC+1), LDR ) + END IF + END IF + PPR = PPR + L +C +C Refill the leading parts of the positive generator. +C + CPCOL = MIN( K-RDEF, KK-RRNK-NZC ) + IF ( CPCOL.GT.0 ) THEN + CALL DLACPY( 'All', LEN-L, CPCOL, DWORK(PPR), (N-1)*L, + $ R(I+L,RNK+2*RRNK+NZC+1), LDR ) + PPR = PPR + CPCOL*( N - 1 )*L + END IF + PNR = PNR + ( RRDF - NZC )*( N - 1 )*L + L +C +C Do the same things for Q. +C + IF ( COMPQ ) THEN + IF ( ( RRDF - NZC ).GT.0 .AND. NZC.GT.0 ) THEN + CPCOL = MIN( NZC, KK ) +C + DO 180 J = RNK + RRNK + 1, RNK + RRNK + CPCOL + CALL DCOPY( MK, Q(1,J+RRDF-NZC), 1, Q(1,J), 1 ) + 180 CONTINUE +C + END IF + CPCOL = MIN( RRNK, KK-NZC ) + IF ( CPCOL.GT.0 ) THEN + CALL DLASET( 'All', K, CPCOL, ZERO, ZERO, + $ Q(1,RNK+RRNK+NZC+1), LDQ ) + IF ( M.GT.1 ) + $ CALL DLACPY( 'All', (M-1)*K, CPCOL, Q(1,RNK+1), + $ LDQ, Q(K+1,RNK+RRNK+NZC+1), LDQ ) + END IF + CPCOL = MIN( K-RDEF, KK-RRNK-NZC ) + IF ( CPCOL.GT.0 ) THEN + CALL DLACPY( 'All', MK, CPCOL, DWORK(PDQ), MK, + $ Q(1,RNK+2*RRNK+NZC+1), LDQ ) + PDQ = PDQ + CPCOL*MK + END IF + PNQ = PNQ + ( RRDF - NZC )*MK + END IF + END IF + RNK = RNK + RRNK + RDEF = RDEF + RRDF - NZC + 190 CONTINUE +C + 200 CONTINUE + DWORK(1) = DBLE( WRKOPT ) + DWORK(2) = LTOL1 + DWORK(3) = LTOL2 +C +C *** Last line of MB02JX *** + END diff --git a/mex/sources/libslicot/MB02KD.f b/mex/sources/libslicot/MB02KD.f new file mode 100644 index 000000000..c45c7cd62 --- /dev/null +++ b/mex/sources/libslicot/MB02KD.f @@ -0,0 +1,842 @@ + SUBROUTINE MB02KD( LDBLK, TRANS, K, L, M, N, R, ALPHA, BETA, + $ TC, LDTC, TR, LDTR, B, LDB, C, LDC, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix product +C +C C = alpha*op( T )*B + beta*C, +C +C where alpha and beta are scalars and T is a block Toeplitz matrix +C specified by its first block column TC and first block row TR; +C B and C are general matrices of appropriate dimensions. +C +C ARGUMENTS +C +C Mode Parameters +C +C LDBLK CHARACTER*1 +C Specifies where the (1,1)-block of T is stored, as +C follows: +C = 'C': in the first block of TC; +C = 'R': in the first block of TR. +C +C TRANS CHARACTER*1 +C Specifies the form of op( T ) to be used in the matrix +C multiplication as follows: +C = 'N': op( T ) = T; +C = 'T': op( T ) = T'; +C = 'C': op( T ) = T'. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows in the blocks of T. K >= 0. +C +C L (input) INTEGER +C The number of columns in the blocks of T. L >= 0. +C +C M (input) INTEGER +C The number of blocks in the first block column of T. +C M >= 0. +C +C N (input) INTEGER +C The number of blocks in the first block row of T. N >= 0. +C +C R (input) INTEGER +C The number of columns in B and C. R >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then TC, TR and B +C are not referenced. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then C need not be set +C before entry. +C +C TC (input) DOUBLE PRECISION array, dimension (LDTC,L) +C On entry with LDBLK = 'C', the leading M*K-by-L part of +C this array must contain the first block column of T. +C On entry with LDBLK = 'R', the leading (M-1)*K-by-L part +C of this array must contain the 2nd to the M-th blocks of +C the first block column of T. +C +C LDTC INTEGER +C The leading dimension of the array TC. +C LDTC >= MAX(1,M*K), if LDBLK = 'C'; +C LDTC >= MAX(1,(M-1)*K), if LDBLK = 'R'. +C +C TR (input) DOUBLE PRECISION array, dimension (LDTR,k) +C where k is (N-1)*L when LDBLK = 'C' and is N*L when +C LDBLK = 'R'. +C On entry with LDBLK = 'C', the leading K-by-(N-1)*L part +C of this array must contain the 2nd to the N-th blocks of +C the first block row of T. +C On entry with LDBLK = 'R', the leading K-by-N*L part of +C this array must contain the first block row of T. +C +C LDTR INTEGER +C The leading dimension of the array TR. LDTR >= MAX(1,K). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,R) +C On entry with TRANS = 'N', the leading N*L-by-R part of +C this array must contain the matrix B. +C On entry with TRANS = 'T' or TRANS = 'C', the leading +C M*K-by-R part of this array must contain the matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,N*L), if TRANS = 'N'; +C LDB >= MAX(1,M*K), if TRANS = 'T' or TRANS = 'C'. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,R) +C On entry with TRANS = 'N', the leading M*K-by-R part of +C this array must contain the matrix C. +C On entry with TRANS = 'T' or TRANS = 'C', the leading +C N*L-by-R part of this array must contain the matrix C. +C On exit with TRANS = 'N', the leading M*K-by-R part of +C this array contains the updated matrix C. +C On exit with TRANS = 'T' or TRANS = 'C', the leading +C N*L-by-R part of this array contains the updated matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= MAX(1,M*K), if TRANS = 'N'; +C LDC >= MAX(1,N*L), if TRANS = 'T' or TRANS = 'C'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -19, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 1. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C For point Toeplitz matrices or sufficiently large block Toeplitz +C matrices, this algorithm uses convolution algorithms based on +C the fast Hartley transforms [1]. Otherwise, TC is copied in +C reversed order into the workspace such that C can be computed from +C barely M matrix-by-matrix multiplications. +C +C REFERENCES +C +C [1] Van Loan, Charles. +C Computational frameworks for the fast Fourier transform. +C SIAM, 1992. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O( (K*L+R*L+K*R)*(N+M)*log(N+M) + K*L*R ) +C floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001, +C March 2004. +C +C KEYWORDS +C +C Convolution, elementary matrix operations, +C fast Hartley transform, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, THOM50 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0, FOUR = 4.0D0, THOM50 = .95D3 ) +C .. Scalar Arguments .. + CHARACTER LDBLK, TRANS + INTEGER INFO, K, L, LDB, LDC, LDTC, LDTR, LDWORK, M, N, + $ R + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION B(LDB,*), C(LDC,*), DWORK(*), TC(LDTC,*), + $ TR(LDTR,*) +C .. Local Scalars .. + LOGICAL FULLC, LMULT, LTRAN + CHARACTER*1 WGHT + INTEGER DIMB, DIMC, I, ICP, ICQ, IERR, IR, J, JJ, KK, + $ LEN, LL, LN, METH, MK, NL, P, P1, P2, PB, PC, + $ PDW, PP, PT, Q1, Q2, R1, R2, S1, S2, SHFT, WPOS, + $ WRKOPT + DOUBLE PRECISION CF, COEF, PARAM, SCAL, SF, T1, T2, TH +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DG01OD, DGEMM, DLACPY, DLASET, + $ DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ATAN, COS, DBLE, MAX, MIN, SIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + FULLC = LSAME( LDBLK, 'C' ) + LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) + LMULT = ALPHA.NE.ZERO + MK = M*K + NL = N*L +C +C Check the scalar input parameters. +C + IF ( .NOT.( FULLC .OR. LSAME( LDBLK, 'R' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( LTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN + INFO = -2 + ELSE IF ( K.LT.0 ) THEN + INFO = -3 + ELSE IF ( L.LT.0 ) THEN + INFO = -4 + ELSE IF ( M.LT.0 ) THEN + INFO = -5 + ELSE IF ( N.LT.0 ) THEN + INFO = -6 + ELSE IF ( R.LT.0 ) THEN + INFO = -7 + ELSE IF ( LMULT .AND. FULLC .AND. LDTC.LT.MAX( 1, MK ) ) THEN + INFO = -11 + ELSE IF ( LMULT .AND. .NOT.FULLC .AND. + $ LDTC.LT.MAX( 1,( M - 1 )*K ) ) THEN + INFO = -11 + ELSE IF ( LMULT .AND. LDTR.LT.MAX( 1, K ) ) THEN + INFO = -13 + ELSE IF ( LMULT .AND. .NOT.LTRAN .AND. LDB.LT.MAX( 1, NL ) ) THEN + INFO = -15 + ELSE IF ( LMULT .AND. LTRAN .AND. LDB.LT.MAX( 1, MK ) ) THEN + INFO = -15 + ELSE IF ( .NOT.LTRAN .AND. LDC.LT.MAX( 1, MK ) ) THEN + INFO = -17 + ELSE IF ( LTRAN .AND. LDC.LT.MAX( 1, NL ) ) THEN + INFO = -17 + ELSE IF ( LDWORK.LT.1 ) THEN + DWORK(1) = ONE + INFO = -19 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02KD', -INFO ) + RETURN + END IF +C +C Scale C beforehand. +C + IF ( BETA.EQ.ZERO ) THEN + IF ( LTRAN ) THEN + CALL DLASET( 'All', NL, R, ZERO, ZERO, C, LDC ) + ELSE + CALL DLASET( 'All', MK, R, ZERO, ZERO, C, LDC ) + END IF + ELSE IF ( BETA.NE.ONE ) THEN + IF ( LTRAN ) THEN +C + DO 10 I = 1, R + CALL DSCAL( NL, BETA, C(1,I), 1 ) + 10 CONTINUE +C + ELSE +C + DO 20 I = 1, R + CALL DSCAL( MK, BETA, C(1,I), 1 ) + 20 CONTINUE +C + END IF + END IF +C +C Quick return if possible. +C + IF ( .NOT.LMULT .OR. MIN( MK, NL, R ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C The parameter PARAM is the watershed between conventional +C multiplication and convolution. This is of course depending +C on the used computer architecture. The lower this value is set +C the more likely the routine will use convolution to compute +C op( T )*B. Note that if there is enough workspace available, +C convolution is always used for point Toeplitz matrices. +C + PARAM = THOM50 +C +C Decide which method to choose, based on the block sizes and +C the available workspace. +C + LEN = 1 + P = 0 +C + 30 CONTINUE + IF ( LEN.LT.M+N-1 ) THEN + LEN = LEN*2 + P = P + 1 + GO TO 30 + END IF +C + COEF = THREE*DBLE( M*N )*DBLE( K*L )*DBLE( R ) / + $ DBLE( LEN*( K*L + L*R + K*R ) ) +C + IF ( FULLC ) THEN + P1 = MK*L + SHFT = 0 + ELSE + P1 = ( M - 1 )*K*L + SHFT = 1 + END IF + IF ( K*L.EQ.1 .AND. MIN( M, N ).GT.1 ) THEN + WRKOPT = LEN*( 2 + R ) - P + METH = 3 + ELSE IF ( ( LEN.LT.M*N ) .AND. ( COEF.GE.PARAM ) ) THEN + WRKOPT = LEN*( K*L + K*R + L*R + 1 ) - P + METH = 3 + ELSE + METH = 2 + WRKOPT = P1 + END IF +C + IF ( LDWORK.LT.WRKOPT ) METH = METH - 1 + IF ( LDWORK.LT.P1 ) METH = 1 +C +C Start computations. +C + IF ( METH.EQ.1 .AND. .NOT.LTRAN ) THEN +C +C Method 1 is the most unlucky way to multiply Toeplitz matrices +C with vectors. Due to the memory restrictions it is not +C possible to flip TC. +C + PC = 1 +C + DO 50 I = 1, M + PT = ( I - 1 - SHFT )*K + 1 + PB = 1 +C + DO 40 J = SHFT + 1, I + CALL DGEMM( 'No Transpose', 'No Transpose', K, R, L, + $ ALPHA, TC(PT,1), LDTC, B(PB,1), LDB, ONE, + $ C(PC,1), LDC ) + PT = PT - K + PB = PB + L + 40 CONTINUE +C + IF ( N.GT.I-SHFT ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', K, R, + $ (N-I+SHFT)*L, ALPHA, TR, LDTR, B(PB,1), LDB, + $ ONE, C(PC,1), LDC ) + END IF + PC = PC + K + 50 CONTINUE +C + ELSE IF ( METH.EQ.1 .AND. LTRAN ) THEN +C + PB = 1 +C + DO 70 I = 1, M + PT = ( I - 1 - SHFT )*K + 1 + PC = 1 +C + DO 60 J = SHFT + 1, I + CALL DGEMM( 'Transpose', 'No Transpose', L, R, K, ALPHA, + $ TC(PT,1), LDTC, B(PB,1), LDB, ONE, C(PC,1), + $ LDC ) + PT = PT - K + PC = PC + L + 60 CONTINUE +C + IF ( N.GT.I-SHFT ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', (N-I+SHFT)*L, + $ R, K, ALPHA, TR, LDTR, B(PB,1), LDB, ONE, + $ C(PC,1), LDC ) + END IF + PB = PB + K + 70 CONTINUE +C + ELSE IF ( METH.EQ.2 .AND. .NOT.LTRAN ) THEN +C +C In method 2 TC is flipped resulting in less calls to the BLAS +C routine DGEMM. Actually this seems often to be the best way to +C multiply with Toeplitz matrices except the point Toeplitz +C case. +C + PT = ( M - 1 - SHFT )*K + 1 +C + DO 80 I = 1, ( M - SHFT )*K*L, K*L + CALL DLACPY( 'All', K, L, TC(PT,1), LDTC, DWORK(I), K ) + PT = PT - K + 80 CONTINUE +C + PT = ( M - 1 )*K*L + 1 + PC = 1 +C + DO 90 I = 1, M + CALL DGEMM( 'No Transpose', 'No Transpose', K, R, + $ MIN( I-SHFT, N )*L, ALPHA, DWORK(PT), K, B, LDB, + $ ONE, C(PC,1), LDC ) + IF ( N.GT.I-SHFT ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', K, R, + $ (N-I+SHFT)*L, ALPHA, TR, LDTR, + $ B((I-SHFT)*L+1,1), LDB, ONE, C(PC,1), LDC ) + END IF + PC = PC + K + PT = PT - K*L + 90 CONTINUE +C + ELSE IF ( METH.EQ.2 .AND. LTRAN ) THEN +C + PT = ( M - 1 - SHFT )*K + 1 +C + DO 100 I = 1, ( M - SHFT )*K*L, K*L + CALL DLACPY( 'All', K, L, TC(PT,1), LDTC, DWORK(I), K ) + PT = PT - K + 100 CONTINUE +C + PT = ( M - 1 )*K*L + 1 + PB = 1 +C + DO 110 I = 1, M + CALL DGEMM( 'Tranpose', 'No Transpose', MIN( I-SHFT, N )*L, + $ R, K, ALPHA, DWORK(PT), K, B(PB,1), LDB, ONE, + $ C, LDC ) + IF ( N.GT.I-SHFT ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', (N-I+SHFT)*L, R, + $ K, ALPHA, TR, LDTR, B(PB,1), LDB, ONE, + $ C((I-SHFT)*L+1,1), LDC ) + END IF + PB = PB + K + PT = PT - K*L + 110 CONTINUE +C + ELSE IF ( METH.EQ.3 ) THEN +C +C In method 3 the matrix-vector product is computed by a suitable +C block convolution via fast Hartley transforms similar to the +C SLICOT routine DE01PD. +C +C Step 1: Copy input data into the workspace arrays. +C + PDW = 1 + IF ( LTRAN ) THEN + DIMB = K + DIMC = L + ELSE + DIMB = L + DIMC = K + END IF + PB = LEN*K*L + PC = LEN*( K*L + DIMB*R ) + IF ( LTRAN ) THEN + IF ( FULLC ) THEN + CALL DLACPY( 'All', K, L, TC, LDTC, DWORK, LEN*K ) + END IF +C + DO 120 I = 1, N - 1 + SHFT + CALL DLACPY( 'All', K, L, TR(1,(I-1)*L+1), LDTR, + $ DWORK((I-SHFT)*K+1), LEN*K ) + 120 CONTINUE +C + PDW = N*K + 1 + R1 = ( LEN - M - N + 1 )*K + CALL DLASET( 'All', R1, L, ZERO, ZERO, DWORK(PDW), LEN*K ) + PDW = PDW + R1 +C + DO 130 I = ( M - 1 - SHFT )*K + 1, K - SHFT*K + 1, -K + CALL DLACPY( 'All', K, L, TC(I,1), LDTC, + $ DWORK(PDW), LEN*K ) + PDW = PDW + K + 130 CONTINUE +C + PDW = PB + 1 + CALL DLACPY( 'All', MK, R, B, LDB, DWORK(PDW), LEN*K ) + PDW = PDW + MK + CALL DLASET( 'All', (LEN-M)*K, R, ZERO, ZERO, DWORK(PDW), + $ LEN*K ) + ELSE + IF ( .NOT.FULLC ) THEN + CALL DLACPY( 'All', K, L, TR, LDTR, DWORK, LEN*K ) + END IF + CALL DLACPY( 'All', (M-SHFT)*K, L, TC, LDTC, + $ DWORK(SHFT*K+1), LEN*K ) + PDW = MK + 1 + R1 = ( LEN - M - N + 1 )*K + CALL DLASET( 'All', R1, L, ZERO, ZERO, DWORK(PDW), LEN*K ) + PDW = PDW + R1 +C + DO 140 I = ( N - 2 + SHFT )*L + 1, SHFT*L + 1, -L + CALL DLACPY( 'All', K, L, TR(1,I), LDTR, DWORK(PDW), + $ LEN*K ) + PDW = PDW + K + 140 CONTINUE +C + PDW = PB + 1 + CALL DLACPY( 'All', NL, R, B, LDB, DWORK(PDW), LEN*L ) + PDW = PDW + NL + CALL DLASET( 'All', (LEN-N)*L, R, ZERO, ZERO, DWORK(PDW), + $ LEN*L ) + END IF +C +C Take point Toeplitz matrices into extra consideration. +C + IF ( K*L.EQ.1 ) THEN + WGHT = 'N' + CALL DG01OD( 'OutputScrambled', WGHT, LEN, DWORK, + $ DWORK(PC+1), IERR ) +C + DO 170 I = PB, PB + LEN*R - 1, LEN + CALL DG01OD( 'OutputScrambled', WGHT, LEN, DWORK(I+1), + $ DWORK(PC+1), IERR ) + SCAL = ALPHA / DBLE( LEN ) + DWORK(I+1) = SCAL*DWORK(I+1)*DWORK(1) + DWORK(I+2) = SCAL*DWORK(I+2)*DWORK(2) + SCAL = SCAL / TWO +C + LN = 1 +C + DO 160 LL = 1, P - 1 + LN = 2*LN + R1 = 2*LN +C + DO 150 P1 = LN + 1, LN + LN/2 + T1 = DWORK(P1) + DWORK(R1) + T2 = DWORK(P1) - DWORK(R1) + TH = T2*DWORK(I+P1) + DWORK(I+P1) = SCAL*( T1*DWORK(I+P1) + $ + T2*DWORK(I+R1) ) + DWORK(I+R1) = SCAL*( T1*DWORK(I+R1) - TH ) + R1 = R1 - 1 + 150 CONTINUE +C + 160 CONTINUE +C + CALL DG01OD( 'InputScrambled', WGHT, LEN, DWORK(I+1), + $ DWORK(PC+1), IERR ) + 170 CONTINUE +C + PC = PB + GOTO 420 + END IF +C +C Step 2: Compute the weights for the Hartley transforms. +C + PDW = PC + R1 = 1 + LN = 1 + TH = FOUR*ATAN( ONE ) / DBLE( LEN ) +C + DO 190 LL = 1, P - 2 + LN = 2*LN + TH = TWO*TH + CF = COS( TH ) + SF = SIN( TH ) + DWORK(PDW+R1) = CF + DWORK(PDW+R1+1) = SF + R1 = R1 + 2 +C + DO 180 I = 1, LN-2, 2 + DWORK(PDW+R1) = CF*DWORK(PDW+I) - SF*DWORK(PDW+I+1) + DWORK(PDW+R1+1) = SF*DWORK(PDW+I) + CF*DWORK(PDW+I+1) + R1 = R1 + 2 + 180 CONTINUE +C + 190 CONTINUE +C + P1 = 3 + Q1 = R1 - 2 +C + DO 210 LL = P - 2, 1, -1 +C + DO 200 I = P1, Q1, 4 + DWORK(PDW+R1) = DWORK(PDW+I) + DWORK(PDW+R1+1) = DWORK(PDW+I+1) + R1 = R1 + 2 + 200 CONTINUE +C + P1 = Q1 + 4 + Q1 = R1 - 2 + 210 CONTINUE +C +C Step 3: Compute the Hartley transforms with scrambled output. +C + J = 0 + KK = K +C +C WHILE J < (L*LEN*K + R*LEN*DIMB), +C + 220 CONTINUE +C + LN = LEN + WPOS = PDW+1 +C + DO 270 PP = P - 1, 1, -1 + LN = LN / 2 + P2 = 1 + Q2 = LN*KK + 1 + R2 = ( LN/2 )*KK + 1 + S2 = R2 + Q2 - 1 +C + DO 260 I = 0, LEN/( 2*LN ) - 1 +C + DO 230 IR = 0, KK - 1 + T1 = DWORK(Q2+IR+J) + DWORK(Q2+IR+J) = DWORK(P2+IR+J) - T1 + DWORK(P2+IR+J) = DWORK(P2+IR+J) + T1 + T1 = DWORK(S2+IR+J) + DWORK(S2+IR+J) = DWORK(R2+IR+J) - T1 + DWORK(R2+IR+J) = DWORK(R2+IR+J) + T1 + 230 CONTINUE +C + P1 = P2 + KK + Q1 = P1 + LN*KK + R1 = Q1 - 2*KK + S1 = R1 + LN*KK +C + DO 250 JJ = WPOS, WPOS + LN - 3, 2 + CF = DWORK(JJ) + SF = DWORK(JJ+1) +C + DO 240 IR = 0, KK-1 + T1 = DWORK(P1+IR+J) - DWORK(Q1+IR+J) + T2 = DWORK(R1+IR+J) - DWORK(S1+IR+J) + DWORK(P1+IR+J) = DWORK(P1+IR+J) + + $ DWORK(Q1+IR+J) + DWORK(R1+IR+J) = DWORK(R1+IR+J) + + $ DWORK(S1+IR+J) + DWORK(Q1+IR+J) = CF*T1 + SF*T2 + DWORK(S1+IR+J) = -CF*T2 + SF*T1 + 240 CONTINUE +C + P1 = P1 + KK + Q1 = Q1 + KK + R1 = R1 - KK + S1 = S1 - KK + 250 CONTINUE +C + P2 = P2 + 2*KK*LN + Q2 = Q2 + 2*KK*LN + R2 = R2 + 2*KK*LN + S2 = S2 + 2*KK*LN + 260 CONTINUE +C + WPOS = WPOS + LN - 2 + 270 CONTINUE +C + DO 290 ICP = KK + 1, LEN*KK, 2*KK + ICQ = ICP - KK +C + DO 280 IR = 0, KK - 1 + T1 = DWORK(ICP+IR+J) + DWORK(ICP+IR+J) = DWORK(ICQ+IR+J) - T1 + DWORK(ICQ+IR+J) = DWORK(ICQ+IR+J) + T1 + 280 CONTINUE +C + 290 CONTINUE +C + J = J + LEN*KK + IF ( J.EQ.L*LEN*K ) THEN + KK = DIMB + END IF + IF ( J.LT.PC ) GOTO 220 +C END WHILE 220 +C +C Step 4: Compute a Hadamard like product. +C + CALL DCOPY( LEN-P, DWORK(PDW+1), 1,DWORK(PDW+1+R*LEN*DIMC), 1 ) + PDW = PDW + R*LEN*DIMC + SCAL = ALPHA / DBLE( LEN ) + P1 = 1 + R1 = LEN*K*L + 1 + S1 = R1 + LEN*DIMB*R + IF ( LTRAN ) THEN + KK = L + LL = K + ELSE + KK = K + LL = L + END IF + CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, DWORK(P1), + $ LEN*K, DWORK(R1), LEN*DIMB, ZERO, DWORK(S1), + $ LEN*DIMC ) + P1 = P1 + K + R1 = R1 + DIMB + S1 = S1 + DIMC + CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, DWORK(P1), + $ LEN*K, DWORK(R1), LEN*DIMB, ZERO, DWORK(S1), + $ LEN*DIMC ) + SCAL = SCAL / TWO + LN = 1 +C + DO 330 PP = 1, P - 1 + LN = 2*LN + P2 = ( 2*LN - 1 )*K + 1 + R1 = PB + LN*DIMB + 1 + R2 = PB + ( 2*LN - 1 )*DIMB + 1 + S1 = PC + LN*DIMC + 1 + S2 = PC + ( 2*LN - 1 )*DIMC + 1 +C + DO 320 P1 = LN*K + 1, ( LN + LN/2 )*K, K +C + DO 310 J = 0, LEN*K*( L - 1 ), LEN*K +C + DO 300 I = P1, P1 + K - 1 + T1 = DWORK(P2) + DWORK(P2) = DWORK(J+I) - T1 + DWORK(J+I) = DWORK(J+I) + T1 + P2 = P2 + 1 + 300 CONTINUE +C + P2 = P2 + ( LEN - 1 )*K + 310 CONTINUE +C + P2 = P2 - LEN*K*L + CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, + $ DWORK(P1), LEN*K, DWORK(R1), LEN*DIMB, + $ ZERO, DWORK(S1), LEN*DIMC ) + CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, + $ DWORK(P2), LEN*K, DWORK(R2), LEN*DIMB, ONE, + $ DWORK(S1), LEN*DIMC ) + CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, + $ DWORK(P1), LEN*K, DWORK(R2), LEN*DIMB, ZERO, + $ DWORK(S2), LEN*DIMC ) + CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, -SCAL, + $ DWORK(P2), LEN*K, DWORK(R1), LEN*DIMB, ONE, + $ DWORK(S2), LEN*DIMC ) + P2 = P2 - K + R1 = R1 + DIMB + R2 = R2 - DIMB + S1 = S1 + DIMC + S2 = S2 - DIMC + 320 CONTINUE +C + 330 CONTINUE +C +C Step 5: Hartley transform with scrambled input. +C + DO 410 J = PC, PC + LEN*DIMC*R, LEN*DIMC +C + DO 350 ICP = DIMC + 1, LEN*DIMC, 2*DIMC + ICQ = ICP - DIMC +C + DO 340 IR = 0, DIMC - 1 + T1 = DWORK(ICP+IR+J) + DWORK(ICP+IR+J) = DWORK(ICQ+IR+J) - T1 + DWORK(ICQ+IR+J) = DWORK(ICQ+IR+J) + T1 + 340 CONTINUE +C + 350 CONTINUE +C + LN = 1 + WPOS = PDW + LEN - 2*P + 1 +C + DO 400 PP = 1, P - 1 + LN = 2*LN + P2 = 1 + Q2 = LN*DIMC + 1 + R2 = ( LN/2 )*DIMC + 1 + S2 = R2 + Q2 - 1 +C + DO 390 I = 0, LEN/( 2*LN ) - 1 +C + DO 360 IR = 0, DIMC - 1 + T1 = DWORK(Q2+IR +J) + DWORK(Q2+IR+J) = DWORK(P2+IR+J) - T1 + DWORK(P2+IR+J) = DWORK(P2+IR+J) + T1 + T1 = DWORK(S2+IR+J) + DWORK(S2+IR+J) = DWORK(R2+IR+J) - T1 + DWORK(R2+IR+J) = DWORK(R2+IR+J) + T1 + 360 CONTINUE +C + P1 = P2 + DIMC + Q1 = P1 + LN*DIMC + R1 = Q1 - 2*DIMC + S1 = R1 + LN*DIMC +C + DO 380 JJ = WPOS, WPOS + LN - 3, 2 + CF = DWORK(JJ) + SF = DWORK(JJ+1) +C + DO 370 IR = 0, DIMC - 1 + T1 = CF*DWORK(Q1+IR+J) + SF*DWORK(S1+IR+J) + T2 = -CF*DWORK(S1+IR+J) + SF*DWORK(Q1+IR+J) + DWORK(Q1+IR+J) = DWORK(P1+IR+J) - T1 + DWORK(P1+IR+J) = DWORK(P1+IR+J) + T1 + DWORK(S1+IR+J) = DWORK(R1+IR+J) - T2 + DWORK(R1+IR+J) = DWORK(R1+IR+J) + T2 + 370 CONTINUE +C + P1 = P1 + DIMC + Q1 = Q1 + DIMC + R1 = R1 - DIMC + S1 = S1 - DIMC + 380 CONTINUE +C + P2 = P2 + 2*DIMC*LN + Q2 = Q2 + 2*DIMC*LN + R2 = R2 + 2*DIMC*LN + S2 = S2 + 2*DIMC*LN + 390 CONTINUE +C + WPOS = WPOS - 2*LN + 2 + 400 CONTINUE +C + 410 CONTINUE +C +C Step 6: Copy data from workspace to output. +C + 420 CONTINUE +C + IF ( LTRAN ) THEN + I = NL + ELSE + I = MK + END IF +C + DO 430 J = 0, R - 1 + CALL DAXPY( I, ONE, DWORK(PC+(J*LEN*DIMC) + 1), 1, + $ C(1,J+1), 1 ) + 430 CONTINUE +C + END IF + DWORK(1) = DBLE( MAX( 1, WRKOPT ) ) + RETURN +C +C *** Last line of MB02KD *** + END diff --git a/mex/sources/libslicot/MB02MD.f b/mex/sources/libslicot/MB02MD.f new file mode 100644 index 000000000..28cbdadaa --- /dev/null +++ b/mex/sources/libslicot/MB02MD.f @@ -0,0 +1,577 @@ + SUBROUTINE MB02MD( JOB, M, N, L, RANK, C, LDC, S, X, LDX, TOL, + $ IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the Total Least Squares (TLS) problem using a Singular +C Value Decomposition (SVD) approach. +C The TLS problem assumes an overdetermined set of linear equations +C AX = B, where both the data matrix A as well as the observation +C matrix B are inaccurate. The routine also solves determined and +C underdetermined sets of equations by computing the minimum norm +C solution. +C It is assumed that all preprocessing measures (scaling, coordinate +C transformations, whitening, ... ) of the data have been performed +C in advance. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Determines whether the values of the parameters RANK and +C TOL are to be specified by the user or computed by the +C routine as follows: +C = 'R': Compute RANK only; +C = 'T': Compute TOL only; +C = 'B': Compute both RANK and TOL; +C = 'N': Compute neither RANK nor TOL. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows in the data matrix A and the +C observation matrix B. M >= 0. +C +C N (input) INTEGER +C The number of columns in the data matrix A. N >= 0. +C +C L (input) INTEGER +C The number of columns in the observation matrix B. +C L >= 0. +C +C RANK (input/output) INTEGER +C On entry, if JOB = 'T' or JOB = 'N', then RANK must +C specify r, the rank of the TLS approximation [A+DA|B+DB]. +C RANK <= min(M,N). +C Otherwise, r is computed by the routine. +C On exit, if JOB = 'R' or JOB = 'B', and INFO = 0, then +C RANK contains the computed (effective) rank of the TLS +C approximation [A+DA|B+DB]. +C Otherwise, the user-supplied value of RANK may be +C changed by the routine on exit if the RANK-th and the +C (RANK+1)-th singular values of C = [A|B] are considered +C to be equal, or if the upper triangular matrix F (as +C defined in METHOD) is (numerically) singular. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N+L) +C On entry, the leading M-by-(N+L) part of this array must +C contain the matrices A and B. Specifically, the first N +C columns must contain the data matrix A and the last L +C columns the observation matrix B (right-hand sides). +C On exit, the leading (N+L)-by-(N+L) part of this array +C contains the (transformed) right singular vectors, +C including null space vectors, if any, of C = [A|B]. +C Specifically, the leading (N+L)-by-RANK part of this array +C always contains the first RANK right singular vectors, +C corresponding to the largest singular values of C. If +C L = 0, or if RANK = 0 and IWARN <> 2, the remaining +C (N+L)-by-(N+L-RANK) top-right part of this array contains +C the remaining N+L-RANK right singular vectors. Otherwise, +C this part contains the matrix V2 transformed as described +C in Step 3 of the TLS algorithm (see METHOD). +C +C LDC INTEGER +C The leading dimension of array C. LDC >= max(1,M,N+L). +C +C S (output) DOUBLE PRECISION array, dimension (min(M,N+L)) +C If INFO = 0, the singular values of matrix C, ordered +C such that S(1) >= S(2) >= ... >= S(p-1) >= S(p) >= 0, +C where p = min(M,N+L). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,L) +C If INFO = 0, the leading N-by-L part of this array +C contains the solution X to the TLS problem specified +C by A and B. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= max(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used to determine the rank of the TLS +C approximation [A+DA|B+DB] and to check the multiplicity +C of the singular values of matrix C. Specifically, S(i) +C and S(j) (i < j) are considered to be equal if +C SQRT(S(i)**2 - S(j)**2) <= TOL, and the TLS approximation +C [A+DA|B+DB] has rank r if S(i) > TOL*S(1) (or S(i) > TOL, +C if TOL specifies sdev (see below)), for i = 1,2,...,r. +C TOL is also used to check the singularity of the upper +C triangular matrix F (as defined in METHOD). +C If JOB = 'R' or JOB = 'N', then TOL must specify the +C desired tolerance. If the user sets TOL to be less than or +C equal to 0, the tolerance is taken as EPS, where EPS is +C the machine precision (see LAPACK Library routine DLAMCH). +C Otherwise, the tolerance is computed by the routine and +C the user must supply the non-negative value sdev, i.e. the +C estimated standard deviation of the error on each element +C of the matrix C, as input value of TOL. +C +C Workspace +C +C IWORK INTEGER array, dimension (L) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2) returns the reciprocal of the +C condition number of the matrix F. +C If INFO > 0, DWORK(1:min(M,N+L)-1) contain the unconverged +C non-diagonal elements of the bidiagonal matrix whose +C diagonal is in S (see LAPACK Library routine DGESVD). +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = max(2, 3*(N+L) + M, 5*(N+L)), if M >= N+L; +C LDWORK = max(2, M*(N+L) + max( 3M+N+L, 5*M), 3*L), +C if M < N+L. +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warnings; +C = 1: if the rank of matrix C has been lowered because a +C singular value of multiplicity greater than 1 was +C found; +C = 2: if the rank of matrix C has been lowered because the +C upper triangular matrix F is (numerically) singular. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if the SVD algorithm (in LAPACK Library routine +C DBDSQR) has failed to converge. In this case, S(1), +C S(2), ..., S(INFO) may not have been found +C correctly and the remaining singular values may +C not be the smallest. This failure is not likely +C to occur. +C +C METHOD +C +C The method used is an extension (see [3,4,5]) of the classical +C TLS algorithm proposed by Golub and Van Loan [1]. +C +C Let [A|B] denote the matrix formed by adjoining the columns of B +C to the columns of A on the right. +C +C Total Least Squares (TLS) definition: +C ------------------------------------- +C +C Given matrices A and B, find a matrix X satisfying +C +C (A + DA) X = B + DB, +C +C where A and DA are M-by-N matrices, B and DB are M-by-L matrices +C and X is an N-by-L matrix. +C The solution X must be such that the Frobenius norm of [DA|DB] +C is a minimum and each column of B + DB is in the range of +C A + DA. Whenever the solution is not unique, the routine singles +C out the minimum norm solution X. +C +C Define matrix C = [A|B] and s(i) as its i-th singular value for +C i = 1,2,...,min(M,NL), where NL = N + L. If M < NL, then s(j) = 0 +C for j = M+1,...,NL. +C +C The Classical TLS algorithm proceeds as follows (see [3,4,5]): +C +C Step 1: Compute part of the singular value decomposition (SVD) +C USV' of C = [A|B], namely compute S and V'. (An initial +C QR factorization of C is used when M is larger enough +C than NL.) +C +C Step 2: If not fixed by the user, compute the rank r0 of the data +C [A|B] based on TOL as follows: if JOB = 'R' or JOB = 'N', +C +C s(1) >= ... >= s(r0) > TOL*s(1) >= ... >= s(NL). +C +C Otherwise, using [2], TOL can be computed from the +C standard deviation sdev of the errors on [A|B]: +C +C TOL = SQRT(2 * max(M,NL)) * sdev, +C +C and the rank r0 is determined (if JOB = 'R' or 'B') using +C +C s(1) >= ... >= s(r0) > TOL >= ... >= s(NL). +C +C The rank r of the approximation [A+DA|B+DB] is then equal +C to the minimum of N and r0. +C +C Step 3: Let V2 be the matrix of the columns of V corresponding to +C the (NL - r) smallest singular values of C, i.e. the last +C (NL - r) columns of V. +C Compute with Householder transformations the orthogonal +C matrix Q such that: +C +C |VH Y| +C V2 x Q = | | +C |0 F| +C +C where VH is an N-by-(N - r) matrix, Y is an N-by-L matrix +C and F is an L-by-L upper triangular matrix. +C If F is singular, then lower the rank r with the +C multiplicity of s(r) and repeat this step. +C +C Step 4: If F is nonsingular then the solution X is obtained by +C solving the following equations by forward elimination: +C +C X F = -Y. +C +C Notes : +C The TLS solution is unique if r = N, F is nonsingular and +C s(N) > s(N+1). +C If F is singular, however, then the computed solution is infinite +C and hence does not satisfy the second TLS criterion (see TLS +C definition). For these cases, Golub and Van Loan [1] claim that +C the TLS problem has no solution. The properties of these so-called +C nongeneric problems are described in [4] and the TLS computations +C are generalized in order to solve them. As proven in [4], the +C proposed generalization satisfies the TLS criteria for any +C number L of observation vectors in B provided that, in addition, +C the solution | X| is constrained to be orthogonal to all vectors +C |-I| +C of the form |w| which belong to the space generated by the columns +C |0| +C of the submatrix |Y|. +C |F| +C +C REFERENCES +C +C [1] Golub, G.H. and Van Loan, C.F. +C An Analysis of the Total Least-Squares Problem. +C SIAM J. Numer. Anal., 17, pp. 883-893, 1980. +C +C [2] Staar, J., Vandewalle, J. and Wemans, M. +C Realization of Truncated Impulse Response Sequences with +C Prescribed Uncertainty. +C Proc. 8th IFAC World Congress, Kyoto, I, pp. 7-12, 1981. +C +C [3] Van Huffel, S. +C Analysis of the Total Least Squares Problem and its Use in +C Parameter Estimation. +C Doctoral dissertation, Dept. of Electr. Eng., Katholieke +C Universiteit Leuven, Belgium, June 1987. +C +C [4] Van Huffel, S. and Vandewalle, J. +C Analysis and Solution of the Nongeneric Total Least Squares +C Problem. +C SIAM J. Matr. Anal. and Appl., 9, pp. 360-372, 1988. +C +C [5] Van Huffel, S. and Vandewalle, J. +C The Total Least Squares Problem: Computational Aspects and +C Analysis. +C Series "Frontiers in Applied Mathematics", Vol. 9, +C SIAM, Philadelphia, 1991. +C +C NUMERICAL ASPECTS +C +C The algorithm consists in (backward) stable steps. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB02AD by S. Van Huffel, Katholieke +C University, Leuven, Belgium. +C +C REVISIONS +C +C June 24, 1997, Feb. 27, 2000, Oct. 19, 2003, Feb. 21, 2004. +C +C KEYWORDS +C +C Least-squares approximation, singular subspace, singular value +C decomposition, singular values, total least-squares. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, IWARN, L, LDC, LDWORK, LDX, M, N, RANK + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION C(LDC,*), DWORK(*), S(*), X(LDX,*) +C .. Local Scalars .. + LOGICAL CRANK, CTOL, LJOBN, LJOBR, LJOBT + INTEGER ITAU, J, JWORK, LDW, K, MINMNL, N1, NL, P, R1, + $ WRKOPT + DOUBLE PRECISION FNORM, RCOND, SMAX, TOLTMP +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE, DLANTR + EXTERNAL DLAMCH, DLANGE, DLANTR, LSAME +C .. External Subroutines .. + EXTERNAL DGERQF, DGESVD, DLACPY, DLASET, DORMRQ, DSWAP, + $ DTRCON, DTRSM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + IWARN = 0 + INFO = 0 + NL = N + L + K = MAX( M, NL ) + P = MIN( M, N ) + MINMNL = MIN( M, NL ) + LDW = MAX( 3*MINMNL + K, 5*MINMNL ) + LJOBR = LSAME( JOB, 'R' ) + LJOBT = LSAME( JOB, 'T' ) + LJOBN = LSAME( JOB, 'N' ) +C +C Determine whether RANK or/and TOL is/are to be computed. +C + CRANK = .NOT.LJOBT .AND. .NOT.LJOBN + CTOL = .NOT.LJOBR .AND. .NOT.LJOBN +C +C Test the input scalar arguments. +C + IF( CTOL .AND. CRANK .AND. .NOT.LSAME( JOB, 'B' ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( L.LT.0 ) THEN + INFO = -4 + ELSE IF( .NOT.CRANK .AND. RANK.GT.P ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( CTOL .AND. TOL.LT.ZERO ) THEN + INFO = -11 + ELSE IF( ( M.GE.NL .AND. LDWORK.LT.MAX( 2, LDW ) ).OR. + $ ( M.LT.NL .AND. LDWORK.LT.MAX( 2, M*NL + LDW, 3*L ) ) ) + $ THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB02MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( CRANK ) + $ RANK = P + IF ( MIN( M, NL ).EQ.0 ) THEN + IF ( M.EQ.0 ) THEN + CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC ) + CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX ) + END IF + DWORK(1) = TWO + DWORK(2) = ONE + RETURN + END IF +C +C Subroutine MB02MD solves a set of linear equations by a Total +C Least Squares Approximation. +C +C Step 1: Compute part of the singular value decomposition (SVD) +C USV' of C = [A |B ], namely compute S and V'. +C M,N M,L +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF ( M.GE.NL ) THEN +C +C M >= N + L: Overwrite V' on C. +C Workspace: need max(3*min(M,N+L) + max(M,N+L), 5*min(M,N+L)). +C + JWORK = 1 + CALL DGESVD( 'No left vectors', 'Overwritten on C', M, NL, C, + $ LDC, S, DWORK, 1, DWORK, 1, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + ELSE +C +C M < N + L: Save C in the workspace and compute V' in C. +C Note that the previous DGESVD call cannot be used in this case. +C Workspace: need M*(N+L) + max(3*min(M,N+L) + max(M,N+L), +C 5*min(M,N+L)). +C + CALL DLACPY( 'Full', M, NL, C, LDC, DWORK, M ) + JWORK = M*NL + 1 + CALL DGESVD( 'No left vectors', 'All right vectors', M, NL, + $ DWORK, M, S, DWORK, 1, C, LDC, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + END IF +C + IF ( INFO.GT.0 ) THEN +C +C Save the unconverged non-diagonal elements of the bidiagonal +C matrix and exit. +C + DO 10 J = 1, MINMNL - 1 + DWORK(J) = DWORK(JWORK+J) + 10 CONTINUE +C + RETURN + END IF + WRKOPT = MAX( 2, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Transpose V' in-situ (in C). +C + DO 20 J = 2, NL + CALL DSWAP( J-1, C(J,1), LDC, C(1,J), 1 ) + 20 CONTINUE +C +C Step 2: Compute the rank of the approximation [A+DA|B+DB]. +C + IF ( CTOL ) THEN + TOLTMP = SQRT( TWO*DBLE( K ) )*TOL + SMAX = TOLTMP + ELSE + TOLTMP = TOL + IF ( TOLTMP.LE.ZERO ) TOLTMP = DLAMCH( 'Precision' ) + SMAX = MAX( TOLTMP*S(1), DLAMCH( 'Safe minimum' ) ) + END IF +C + IF ( CRANK ) THEN +C WHILE ( RANK .GT. 0 ) .AND. ( S(RANK) .LE. SMAX ) DO + 40 IF ( RANK.GT.0 ) THEN + IF ( S(RANK).LE.SMAX ) THEN + RANK = RANK - 1 + GO TO 40 + END IF + END IF +C END WHILE 40 + END IF +C + IF ( L.EQ.0 ) THEN + DWORK(1) = WRKOPT + DWORK(2) = ONE + RETURN + END IF +C + N1 = N + 1 + ITAU = 1 + JWORK = ITAU + L +C +C Step 3: Compute the orthogonal matrix Q and matrices F and Y +C such that F is nonsingular. +C +C REPEAT +C +C Adjust the rank if S(RANK) has multiplicity greater than 1. +C + 60 CONTINUE + R1 = RANK + 1 + IF ( RANK.LT.MINMNL ) THEN +C WHILE RANK.GT.0 .AND. S(RANK)**2 - S(R1)**2.LE.TOL**2 DO + 80 IF ( RANK.GT.0 ) THEN + IF ( ONE - ( S(R1)/S(RANK) )**2.LE.( TOLTMP/S(RANK) )**2 + $ ) THEN + RANK = RANK - 1 + IWARN = 1 + GO TO 80 + END IF + END IF +C END WHILE 80 + END IF +C + IF ( RANK.EQ.0 ) THEN +C +C Return zero solution. +C + CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX ) + DWORK(1) = WRKOPT + DWORK(2) = ONE + RETURN + END IF +C +C Compute the orthogonal matrix Q (in factorized form) and the +C matrices F and Y using RQ factorization. It is assumed that, +C generically, the last L rows of V2 matrix have full rank. +C The code could not be the most efficient one when RANK has been +C lowered, because the already created zero pattern of the last +C L rows of V2 matrix is not exploited. +C Workspace: need 2*L; prefer L + L*NB. +C + R1 = RANK + 1 + CALL DGERQF( L, NL-RANK, C(N1,R1), LDC, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Workspace: need N+L; prefer L + N*NB. +C + CALL DORMRQ( 'Right', 'Transpose', N, NL-RANK, L, C(N1,R1), + $ LDC, DWORK(ITAU), C(1,R1), LDC, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + CALL DLASET( 'Full', L, N-RANK, ZERO, ZERO, C(N1,R1), LDC ) + IF ( L.GT.1 ) + $ CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, C(N1+1,N1), + $ LDC ) +C +C Estimate the reciprocal condition number of the matrix F, +C and lower the rank if F can be considered as singular. +C Workspace: need 3*L. +C + CALL DTRCON( '1-norm', 'Upper', 'Non-unit', L, C(N1,N1), LDC, + $ RCOND, DWORK, IWORK, INFO ) + WRKOPT = MAX( WRKOPT, 3*L ) +C + FNORM = DLANTR( '1-norm', 'Upper', 'Non-unit', L, L, C(N1,N1), + $ LDC, DWORK ) + IF ( RCOND.LE.TOLTMP*FNORM ) THEN + RANK = RANK - 1 + IWARN = 2 + GO TO 60 + ELSE IF ( FNORM.LE.TOLTMP*DLANGE( '1-norm', N, L, C(1,N1), LDC, + $ DWORK ) ) THEN + RANK = RANK - L + IWARN = 2 + GO TO 60 + END IF +C UNTIL ( F nonsingular, i.e., RCOND.GT.TOL*FNORM or +C FNORM.GT.TOL*norm(Y) ) +C +C Step 4: Solve X F = -Y by forward elimination, +C (F is upper triangular). +C + CALL DLACPY( 'Full', N, L, C(1,N1), LDC, X, LDX ) + CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L, + $ -ONE, C(N1,N1), LDC, X, LDX ) +C +C Set the optimal workspace and reciprocal condition number of F. +C + DWORK(1) = WRKOPT + DWORK(2) = RCOND +C + RETURN +C *** Last line of MB02MD *** + END diff --git a/mex/sources/libslicot/MB02ND.f b/mex/sources/libslicot/MB02ND.f new file mode 100644 index 000000000..047296025 --- /dev/null +++ b/mex/sources/libslicot/MB02ND.f @@ -0,0 +1,889 @@ + SUBROUTINE MB02ND( M, N, L, RANK, THETA, C, LDC, X, LDX, Q, INUL, + $ TOL, RELTOL, IWORK, DWORK, LDWORK, BWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the Total Least Squares (TLS) problem using a Partial +C Singular Value Decomposition (PSVD) approach. +C The TLS problem assumes an overdetermined set of linear equations +C AX = B, where both the data matrix A as well as the observation +C matrix B are inaccurate. The routine also solves determined and +C underdetermined sets of equations by computing the minimum norm +C solution. +C It is assumed that all preprocessing measures (scaling, coordinate +C transformations, whitening, ... ) of the data have been performed +C in advance. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows in the data matrix A and the +C observation matrix B. M >= 0. +C +C N (input) INTEGER +C The number of columns in the data matrix A. N >= 0. +C +C L (input) INTEGER +C The number of columns in the observation matrix B. +C L >= 0. +C +C RANK (input/output) INTEGER +C On entry, if RANK < 0, then the rank of the TLS +C approximation [A+DA|B+DB] (r say) is computed by the +C routine. +C Otherwise, RANK must specify the value of r. +C RANK <= min(M,N). +C On exit, if RANK < 0 on entry and INFO = 0, then RANK +C contains the computed rank of the TLS approximation +C [A+DA|B+DB]. +C Otherwise, the user-supplied value of RANK may be +C changed by the routine on exit if the RANK-th and the +C (RANK+1)-th singular values of C = [A|B] are considered +C to be equal, or if the upper triangular matrix F (as +C defined in METHOD) is (numerically) singular. +C +C THETA (input/output) DOUBLE PRECISION +C On entry, if RANK < 0, then the rank of the TLS +C approximation [A+DA|B+DB] is computed using THETA as +C (min(M,N+L) - d), where d is the number of singular +C values of [A|B] <= THETA. THETA >= 0.0. +C Otherwise, THETA is an initial estimate (t say) for +C computing a lower bound on the RANK largest singular +C values of [A|B]. If THETA < 0.0 on entry however, then +C t is computed by the routine. +C On exit, if RANK >= 0 on entry, then THETA contains the +C computed bound such that precisely RANK singular values +C of C = [A|B] are greater than THETA + TOL. +C Otherwise, THETA is unchanged. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N+L) +C On entry, the leading M-by-(N+L) part of this array must +C contain the matrices A and B. Specifically, the first N +C columns must contain the data matrix A and the last L +C columns the observation matrix B (right-hand sides). +C On exit, if INFO = 0, the first N+L components of the +C columns of this array whose index i corresponds with +C INUL(i) = .TRUE., are the possibly transformed (N+L-RANK) +C base vectors of the right singular subspace corresponding +C to the singular values of C = [A|B] which are less than or +C equal to THETA. Specifically, if L = 0, or if RANK = 0 and +C IWARN <> 2, these vectors are indeed the base vectors +C above. Otherwise, these vectors form the matrix V2, +C transformed as described in Step 4 of the PTLS algorithm +C (see METHOD). The TLS solution is computed from these +C vectors. The other columns of array C contain no useful +C information. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= max(1,M,N+L). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,L) +C If INFO = 0, the leading N-by-L part of this array +C contains the solution X to the TLS problem specified by +C A and B. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= max(1,N). +C +C Q (output) DOUBLE PRECISION array, dimension +C (max(1,2*min(M,N+L)-1)) +C This array contains the partially diagonalized bidiagonal +C matrix J computed from C, at the moment that the desired +C singular subspace has been found. Specifically, the +C leading p = min(M,N+L) entries of Q contain the diagonal +C elements q(1),q(2),...,q(p) and the entries Q(p+1),Q(p+2), +C ...,Q(2*p-1) contain the superdiagonal elements e(1),e(2), +C ...,e(p-1) of J. +C +C INUL (output) LOGICAL array, dimension (N+L) +C The indices of the elements of this array with value +C .TRUE. indicate the columns in C containing the base +C vectors of the right singular subspace of C from which +C the TLS solution has been computed. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C This parameter defines the multiplicity of singular values +C by considering all singular values within an interval of +C length TOL as coinciding. TOL is used in checking how many +C singular values are less than or equal to THETA. Also in +C computing an appropriate upper bound THETA by a bisection +C method, TOL is used as a stopping criterion defining the +C minimum (absolute) subinterval width. TOL is also taken +C as an absolute tolerance for negligible elements in the +C QR/QL iterations. If the user sets TOL to be less than or +C equal to 0, then the tolerance is taken as specified in +C SLICOT Library routine MB04YD document. +C +C RELTOL DOUBLE PRECISION +C This parameter specifies the minimum relative width of an +C interval. When an interval is narrower than TOL, or than +C RELTOL times the larger (in magnitude) endpoint, then it +C is considered to be sufficiently small and bisection has +C converged. If the user sets RELTOL to be less than +C BASE * EPS, where BASE is machine radix and EPS is machine +C precision (see LAPACK Library routine DLAMCH), then the +C tolerance is taken as BASE * EPS. +C +C Workspace +C +C IWORK INTEGER array, dimension (N+2*L) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2) returns the reciprocal of the +C condition number of the matrix F. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = max(2, max(M,N+L) + 2*min(M,N+L), +C min(M,N+L) + LW + max(6*(N+L)-5, +C L*L+max(N+L,3*L)), +C where +C LW = (N+L)*(N+L-1)/2, if M >= N+L, +C LW = M*(N+L-(M-1)/2), if M < N+L. +C For optimum performance LDWORK should be larger. +C +C BWORK LOGICAL array, dimension (N+L) +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warnings; +C = 1: if the rank of matrix C has been lowered because a +C singular value of multiplicity greater than 1 was +C found; +C = 2: if the rank of matrix C has been lowered because the +C upper triangular matrix F is (numerically) singular. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the maximum number of QR/QL iteration steps +C (30*MIN(M,N)) has been exceeded; +C = 2: if the computed rank of the TLS approximation +C [A+DA|B+DB] exceeds MIN(M,N). Try increasing the +C value of THETA or set the value of RANK to min(M,N). +C +C METHOD +C +C The method used is the Partial Total Least Squares (PTLS) approach +C proposed by Van Huffel and Vandewalle [5]. +C +C Let C = [A|B] denote the matrix formed by adjoining the columns of +C B to the columns of A on the right. +C +C Total Least Squares (TLS) definition: +C ------------------------------------- +C +C Given matrices A and B, find a matrix X satisfying +C +C (A + DA) X = B + DB, +C +C where A and DA are M-by-N matrices, B and DB are M-by-L matrices +C and X is an N-by-L matrix. +C The solution X must be such that the Frobenius norm of [DA|DB] +C is a minimum and each column of B + DB is in the range of +C A + DA. Whenever the solution is not unique, the routine singles +C out the minimum norm solution X. +C +C Let V denote the right singular subspace of C. Since the TLS +C solution can be computed from any orthogonal basis of the subspace +C of V corresponding to the smallest singular values of C, the +C Partial Singular Value Decomposition (PSVD) can be used instead of +C the classical SVD. The dimension of this subspace of V may be +C determined by the rank of C or by an upper bound for those +C smallest singular values. +C +C The PTLS algorithm proceeds as follows (see [2 - 5]): +C +C Step 1: Bidiagonalization phase +C ----------------------- +C (a) If M is large enough than N + L, transform C into upper +C triangular form R by Householder transformations. +C (b) Transform C (or R) into upper bidiagonal form +C (p = min(M,N+L)): +C +C |q(1) e(1) 0 ... 0 | +C (0) | 0 q(2) e(2) . | +C J = | . . | +C | . e(p-1)| +C | 0 ... q(p) | +C +C if M >= N + L, or lower bidiagonal form: +C +C |q(1) 0 0 ... 0 0 | +C (0) |e(1) q(2) 0 . . | +C J = | . . . | +C | . q(p) . | +C | 0 ... e(p-1) q(p)| +C +C if M < N + L, using Householder transformations. +C In the second case, transform the matrix to the upper +C bidiagonal form by applying Givens rotations. +C (c) Initialize the right singular base matrix with the identity +C matrix. +C +C Step 2: Partial diagonalization phase +C ----------------------------- +C If the upper bound THETA is not given, then compute THETA such +C that precisely p - RANK singular values (p=min(M,N+L)) of the +C bidiagonal matrix are less than or equal to THETA, using a +C bisection method [5]. Diagonalize the given bidiagonal matrix J +C partially, using either QL iterations (if the upper left diagonal +C element of the considered bidiagonal submatrix is smaller than the +C lower right diagonal element) or QR iterations, such that J is +C split into unreduced bidiagonal submatrices whose singular values +C are either all larger than THETA or are all less than or equal +C to THETA. Accumulate the Givens rotations in V. +C +C Step 3: Back transformation phase +C ------------------------- +C Apply the Householder transformations of Step 1(b) onto the base +C vectors of V associated with the bidiagonal submatrices with all +C singular values less than or equal to THETA. +C +C Step 4: Computation of F and Y +C ---------------------- +C Let V2 be the matrix of the columns of V corresponding to the +C (N + L - RANK) smallest singular values of C. +C Compute with Householder transformations the matrices F and Y +C such that: +C +C |VH Y| +C V2 x Q = | | +C |0 F| +C +C where Q is an orthogonal matrix, VH is an N-by-(N-RANK) matrix, +C Y is an N-by-L matrix and F is an L-by-L upper triangular matrix. +C If F is singular, then reduce the value of RANK by one and repeat +C Steps 2, 3 and 4. +C +C Step 5: Computation of the TLS solution +C ------------------------------- +C If F is non-singular then the solution X is obtained by solving +C the following equations by forward elimination: +C +C X F = -Y. +C +C Notes: +C If RANK is lowered in Step 4, some additional base vectors must +C be computed in Step 2. The additional computations are kept to +C a minimum. +C If RANK is lowered in Step 4 but the multiplicity of the RANK-th +C singular value is larger than 1, then the value of RANK is further +C lowered with its multiplicity defined by the parameter TOL. This +C is done at the beginning of Step 2 by calling SLICOT Library +C routine MB03MD (from MB04YD), which estimates THETA using a +C bisection method. If F in Step 4 is singular, then the computed +C solution is infinite and hence does not satisfy the second TLS +C criterion (see TLS definition). For these cases, Golub and +C Van Loan [1] claim that the TLS problem has no solution. The +C properties of these so-called nongeneric problems are described +C in [6] and the TLS computations are generalized in order to solve +C them. As proven in [6], the proposed generalization satisfies the +C TLS criteria for any number L of observation vectors in B provided +C that, in addition, the solution | X| is constrained to be +C |-I| +C orthogonal to all vectors of the form |w| which belong to the +C |0| +C space generated by the columns of the submatrix |Y|. +C |F| +C +C REFERENCES +C +C [1] Golub, G.H. and Van Loan, C.F. +C An Analysis of the Total Least-Squares Problem. +C SIAM J. Numer. Anal., 17, pp. 883-893, 1980. +C +C [2] Van Huffel, S., Vandewalle, J. and Haegemans, A. +C An Efficient and Reliable Algorithm for Computing the +C Singular Subspace of a Matrix Associated with its Smallest +C Singular Values. +C J. Comput. and Appl. Math., 19, pp. 313-330, 1987. +C +C [3] Van Huffel, S. +C Analysis of the Total Least Squares Problem and its Use in +C Parameter Estimation. +C Doctoral dissertation, Dept. of Electr. Eng., Katholieke +C Universiteit Leuven, Belgium, June 1987. +C +C [4] Chan, T.F. +C An Improved Algorithm for Computing the Singular Value +C Decomposition. +C ACM TOMS, 8, pp. 72-83, 1982. +C +C [5] Van Huffel, S. and Vandewalle, J. +C The Partial Total Least Squares Algorithm. +C J. Comput. Appl. Math., 21, pp. 333-341, 1988. +C +C [6] Van Huffel, S. and Vandewalle, J. +C Analysis and Solution of the Nongeneric Total Least Squares +C Problem. +C SIAM J. Matr. Anal. and Appl., 9, pp. 360-372, 1988. +C +C NUMERICAL ASPECTS +C +C The computational efficiency of the PTLS algorithm compared with +C the classical TLS algorithm (see [2 - 5]) is obtained by making +C use of PSVD (see [1]) instead of performing the entire SVD. +C Depending on the gap between the RANK-th and the (RANK+1)-th +C singular values of C, the number (N + L - RANK) of base vectors to +C be computed with respect to the column dimension (N + L) of C and +C the desired accuracy RELTOL, the algorithm used by this routine is +C approximately twice as fast as the classical TLS algorithm at the +C expense of extra storage requirements, namely: +C (N + L) x (N + L - 1)/2 if M >= N + L or +C M x (N + L - (M - 1)/2) if M < N + L. +C This is because the Householder transformations performed on the +C rows of C in the bidiagonalization phase (see Step 1) must be kept +C until the end (Step 5). +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB02BD by S. Van Huffel, Katholieke +C University, Leuven, Belgium. +C +C REVISIONS +C +C June 30, 1997, Oct. 19, 2003, Feb. 15, 2004. +C +C KEYWORDS +C +C Least-squares approximation, singular subspace, singular value +C decomposition, singular values, total least-squares. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, IWARN, L, LDC, LDWORK, LDX, M, N, RANK + DOUBLE PRECISION RELTOL, THETA, TOL +C .. Array Arguments .. + LOGICAL BWORK(*), INUL(*) + INTEGER IWORK(*) + DOUBLE PRECISION C(LDC,*), DWORK(*), Q(*), X(LDX,*) +C .. Local Scalars .. + LOGICAL LFIRST, SUFWRK + INTEGER I, I1, IFAIL, IHOUSH, IJ, IOFF, ITAUP, ITAUQ, + $ IWARM, J, J1, JF, JV, JWORK, K, KF, KJ, LDF, LW, + $ MC, MJ, MNL, N1, NJ, NL, P, WRKOPT + DOUBLE PRECISION CS, EPS, FIRST, FNORM, HH, INPROD, RCOND, SN, + $ TEMP +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE, DLANTR + EXTERNAL DLAMCH, DLANGE, DLANTR, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEBRD, DGEQRF, DGERQF, DLARF, DLARFG, + $ DLARTG, DLASET, DORMBR, DORMRQ, DTRCON, DTRSM, + $ MB04YD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + IWARN = 0 + INFO = 0 + NL = N + L + K = MAX( M, NL ) + P = MIN( M, NL ) + IF ( M.GE.NL ) THEN + LW = ( NL*( NL - 1 ) )/2 + ELSE + LW = M*NL - ( M*( M - 1 ) )/2 + END IF + JV = P + LW + MAX( 6*NL - 5, L*L + MAX( NL, 3*L ) ) +C +C Test the input scalar arguments. +C + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 ) THEN + INFO = -3 + ELSE IF( RANK.GT.MIN( M, N ) ) THEN + INFO = -4 + ELSE IF( ( RANK.LT.0 ) .AND. ( THETA.LT.ZERO ) ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDWORK.LT.MAX( 2, K + 2*P, JV ) ) THEN + INFO = -16 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB02ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( M, NL ).EQ.0 ) THEN + IF ( M.EQ.0 ) THEN + CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC ) + CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX ) +C + DO 10 I = 1, NL + INUL(I) = .TRUE. + 10 CONTINUE +C + END IF + IF ( RANK.GE.0 ) + $ THETA = ZERO + RANK = 0 + DWORK(1) = TWO + DWORK(2) = ONE + RETURN + END IF +C + WRKOPT = 2 + N1 = N + 1 +C + EPS = DLAMCH( 'Precision' ) + LFIRST = .TRUE. +C +C Initializations. +C + DO 20 I = 1, P + INUL(I) = .FALSE. + BWORK(I) = .FALSE. + 20 CONTINUE +C + DO 40 I = P + 1, NL + INUL(I) = .TRUE. + BWORK(I) = .FALSE. + 40 CONTINUE +C +C Subroutine MB02ND solves a set of linear equations by a Total +C Least Squares Approximation, based on the Partial SVD. +C +C Step 1: Bidiagonalization phase +C ----------------------- +C 1.a): If M is large enough than N+L, transform C into upper +C triangular form R by Householder transformations. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF ( M.GE.MAX( NL, + $ ILAENV( 6, 'DGESVD', 'N' // 'N', M, NL, 0, 0 ) ) ) + $ THEN +C +C Workspace: need 2*(N+L), +C prefer N+L + (N+L)*NB. +C + ITAUQ = 1 + JWORK = ITAUQ + NL + CALL DGEQRF( M, NL, C, LDC, DWORK(ITAUQ), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) + IF ( NL.GT.1 ) + $ CALL DLASET( 'Lower', NL-1, NL-1, ZERO, ZERO, C(2,1), LDC ) + MNL = NL + ELSE + MNL = M + END IF +C +C 1.b): Transform C (or R) into bidiagonal form Q using Householder +C transformations. +C Workspace: need 2*min(M,N+L) + max(M,N+L), +C prefer 2*min(M,N+L) + (M+N+L)*NB. +C + ITAUP = 1 + ITAUQ = ITAUP + P + JWORK = ITAUQ + P + CALL DGEBRD( MNL, NL, C, LDC, Q, Q(P+1), DWORK(ITAUQ), + $ DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C If the matrix is lower bidiagonal, rotate to be upper bidiagonal +C by applying Givens rotations on the left. +C + IF ( M.LT.NL ) THEN + IOFF = 0 +C + DO 60 I = 1, P - 1 + CALL DLARTG( Q(I), Q(P+I), CS, SN, TEMP ) + Q(I) = TEMP + Q(P+I) = SN*Q(I+1) + Q(I+1) = CS*Q(I+1) + 60 CONTINUE +C + ELSE + IOFF = 1 + END IF +C +C Store the Householder transformations performed onto the rows of C +C in the extra storage locations DWORK(IHOUSH). +C Workspace: need LDW = min(M,N+L) + (N+L)*(N+L-1)/2, if M >= N+L, +C LDW = min(M,N+L) + M*(N+L-(M-1)/2), if M < N+L; +C prefer LDW = min(M,N+L) + (N+L)**2, if M >= N+L, +C LDW = min(M,N+L) + M*(N+L), if M < N+L. +C + IHOUSH = ITAUQ + MC = NL - IOFF + KF = IHOUSH + P*NL + SUFWRK = LDWORK.GE.( KF + MAX( 6*(N+L)-5, + $ NL**2 + MAX( NL, 3*L ) - 1 ) ) + IF ( SUFWRK ) THEN +C +C Enough workspace for a fast algorithm. +C + CALL DLACPY( 'Upper', P, NL, C, LDC, DWORK(IHOUSH), P ) + KJ = KF + WRKOPT = MAX( WRKOPT, KF - 1 ) + ELSE +C +C Not enough workspace for a fast algorithm. +C + KJ = IHOUSH +C + DO 80 NJ = 1, MIN( P, MC ) + J = MC - NJ + 1 + CALL DCOPY( J, C(NJ,NJ+IOFF), LDC, DWORK(KJ), 1 ) + KJ = KJ + J + 80 CONTINUE +C + END IF +C +C 1.c): Initialize the right singular base matrix V with the +C identity matrix (V overwrites C). +C + CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC ) + JV = KJ + IWARM = 0 +C +C REPEAT +C +C Compute the Householder matrix Q and matrices F and Y such that +C F is nonsingular. +C +C Step 2: Partial diagonalization phase. +C ----------------------------- +C Diagonalize the bidiagonal Q partially until convergence to +C the desired right singular subspace. +C Workspace: LDW + 6*(N+L)-5. +C + 100 CONTINUE + JWORK = JV + CALL MB04YD( 'No U', 'Update V', P, NL, RANK, THETA, Q, Q(P+1), + $ DUMMY, 1, C, LDC, INUL, TOL, RELTOL, DWORK(JWORK), + $ LDWORK-JWORK+1, IWARN, INFO ) + WRKOPT = MAX( WRKOPT, JWORK + 6*NL - 6 ) +C + IWARN = MAX( IWARN, IWARM ) + IF ( INFO.GT.0 ) + $ RETURN +C +C Set pointers to the selected base vectors in the right singular +C matrix of C. +C + K = 0 +C + DO 120 I = 1, NL + IF ( INUL(I) ) THEN + K = K + 1 + IWORK(K) = I + END IF + 120 CONTINUE +C + IF ( K.LT.L ) THEN +C +C Rank of the TLS approximation is larger than min(M,N). +C + INFO = 2 + RETURN + END IF +C +C Step 3: Back transformation phase. +C ------------------------- +C Apply in backward order the Householder transformations (stored +C in DWORK(IHOUSH)) performed onto the rows of C during the +C bidiagonalization phase, to the selected base vectors (specified +C by INUL(I) = .TRUE.). Already transformed vectors are those for +C which BWORK(I) = .TRUE.. +C + KF = K + IF ( SUFWRK.AND.LFIRST ) THEN +C +C Enough workspace for a fast algorithm and first pass. +C + IJ = JV +C + DO 140 J = 1, K + CALL DCOPY (NL, C(1,IWORK(J)), 1, DWORK(IJ), 1 ) + IJ = IJ + NL + 140 CONTINUE +C +C Workspace: need LDW + (N+L)*K + K, +C prefer LDW + (N+L)*K + K*NB. +C + IJ = JV + JWORK = IJ + NL*K + CALL DORMBR( 'P vectors', 'Left', 'No transpose', NL, K, + $ MNL, DWORK(IHOUSH), P, DWORK(ITAUP), DWORK(IJ), + $ NL, DWORK(JWORK), LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + DO 160 I = 1, NL + IF ( INUL(I) .AND. ( .NOT. BWORK(I) ) ) + $ BWORK(I) = .TRUE. + 160 CONTINUE +C + ELSE +C +C Not enough workspace for a fast algorithm or subsequent passes. +C + DO 180 I = 1, NL + IF ( INUL(I) .AND. ( .NOT. BWORK(I) ) ) THEN + KJ = JV +C + DO 170 NJ = MIN( P, MC ), 1, -1 + J = MC - NJ + 1 + KJ = KJ - J + FIRST = DWORK(KJ) + DWORK(KJ) = ONE + CALL DLARF( 'Left', J, 1, DWORK(KJ), 1, + $ DWORK(ITAUP+NJ-1), C(NJ+IOFF,I), LDC, + $ DWORK(JWORK) ) + DWORK(KJ) = FIRST + 170 CONTINUE +C + BWORK(I) = .TRUE. + END IF + 180 CONTINUE + END IF +C + IF ( RANK.LE.0 ) + $ RANK = 0 + IF ( MIN( RANK, L ).EQ.0 ) THEN + IF ( SUFWRK.AND.LFIRST ) + $ CALL DLACPY( 'Full', NL, K, DWORK(JV), NL, C, LDC ) + DWORK(1) = WRKOPT + DWORK(2) = ONE + RETURN + END IF +C +C Step 4: Compute matrices F and Y +C ------------------------ +C using Householder transformation Q. +C +C Compute the orthogonal matrix Q (in factorized form) and the +C matrices F and Y using RQ factorization. It is assumed that, +C generically, the last L rows of V2 matrix have full rank. +C The code could not be the most efficient when RANK has been +C lowered, because the already created zero pattern of the last +C L rows of V2 matrix is not exploited. +C + IF ( SUFWRK.AND.LFIRST ) THEN +C +C Enough workspace for a fast algorithm and first pass. +C Workspace: need LDW1 + 2*L, +C prefer LDW1 + L + L*NB, where +C LDW1 = LDW + (N+L)*K; +C + ITAUQ = JWORK + JWORK = ITAUQ + L + CALL DGERQF( L, K, DWORK(JV+N), NL, DWORK(ITAUQ), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Workspace: need LDW1 + N+L, +C prefer LDW1 + L + N*NB. +C + CALL DORMRQ( 'Right', 'Transpose', N, K, L, DWORK(JV+N), NL, + $ DWORK(ITAUQ), DWORK(JV), NL, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + JF = JV + NL*(K-L) + N + LDF = NL + JWORK = JF + LDF*L - N + CALL DLASET( 'Full', L, K-L, ZERO, ZERO, DWORK(JV+N), LDF ) + IF ( L.GT.1 ) + $ CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, DWORK(JF+1), + $ LDF ) + IJ = JV +C + DO 200 J = 1, K + CALL DCOPY( NL, DWORK(IJ), 1, C(1,IWORK(J)), 1 ) + IJ = IJ + NL + 200 CONTINUE +C + ELSE +C +C Not enough workspace for a fast algorithm or subsequent passes. +C Workspace: LDW2 + N+L, where LDW2 = LDW + L*L. +C + I = NL + JF = JV + LDF = L + JWORK = JF + LDF*L + WRKOPT = MAX( WRKOPT, JWORK+NL-1 ) +C +C WHILE ( ( K >= 1 ) .AND. ( I > N ) ) DO + 220 CONTINUE + IF ( ( K.GE.1 ) .AND. ( I.GT.N ) ) THEN +C + DO 240 J = 1, K + DWORK(JWORK+J-1) = C(I,IWORK(J)) + 240 CONTINUE +C +C Compute Householder transformation. +C + CALL DLARFG( K, DWORK(JWORK+K-1), DWORK(JWORK), 1, TEMP ) + C(I,IWORK(K)) = DWORK(JWORK+K-1) + IF ( TEMP.NE.ZERO ) THEN +C +C Apply Householder transformation onto the selected base +C vectors. +C + DO 300 I1 = 1, I - 1 + INPROD = C(I1,IWORK(K)) +C + DO 260 J = 1, K - 1 + INPROD = INPROD + DWORK(JWORK+J-1)*C(I1,IWORK(J)) + 260 CONTINUE +C + HH = INPROD*TEMP + C(I1,IWORK(K)) = C(I1,IWORK(K)) - HH +C + DO 280 J = 1, K - 1 + J1 = IWORK(J) + C(I1,J1) = C(I1,J1) - DWORK(JWORK+J-1)*HH + C(I,J1) = ZERO + 280 CONTINUE +C + 300 CONTINUE +C + END IF + CALL DCOPY( I-N, C(N1,IWORK(K)), 1, DWORK(JF+(I-N-1)*L), 1 ) + K = K - 1 + I = I - 1 + GO TO 220 + END IF +C END WHILE 220 + END IF +C +C Estimate the reciprocal condition number of the matrix F. +C If F singular, lower the rank of the TLS approximation. +C Workspace: LDW1 + 3*L or +C LDW2 + 3*L. +C + CALL DTRCON( '1-norm', 'Upper', 'Non-unit', L, DWORK(JF), LDF, + $ RCOND, DWORK(JWORK), IWORK(KF+1), INFO ) + WRKOPT = MAX( WRKOPT, JWORK + 3*L - 1 ) +C + DO 320 J = 1, L + CALL DCOPY( N, C(1,IWORK(KF-L+J)), 1, X(1,J), 1 ) + 320 CONTINUE +C + FNORM = DLANTR( '1-norm', 'Upper', 'Non-unit', L, L, DWORK(JF), + $ LDF, DWORK(JWORK) ) + IF ( RCOND.LE.EPS*FNORM ) THEN + RANK = RANK - 1 + GO TO 340 + END IF + IF ( FNORM.LE.EPS*DLANGE( '1-norm', N, L, X, LDX, + $ DWORK(JWORK) ) ) THEN + RANK = RANK - L + GO TO 340 + ELSE + GO TO 400 + END IF +C + 340 CONTINUE + IWARM = 2 + THETA = -ONE + IF ( SUFWRK.AND.LFIRST ) THEN +C +C Rearrange the stored Householder transformations for +C subsequent passes, taking care to avoid overwriting. +C + IF ( P.LT.NL ) THEN + KJ = IHOUSH + NL*(NL - 1) + MJ = IHOUSH + P*(NL - 1) +C + DO 360 NJ = 1, NL + DO 350 J = P - 1, 0, -1 + DWORK(KJ+J) = DWORK(MJ+J) + 350 CONTINUE + KJ = KJ - NL + MJ = MJ - P + 360 CONTINUE +C + END IF + KJ = IHOUSH + MJ = IHOUSH + NL*IOFF +C + DO 380 NJ = 1, MIN( P, MC ) + DO 370 J = 0, MC - NJ + DWORK(KJ) = DWORK(MJ+J*P) + KJ = KJ + 1 + 370 CONTINUE + MJ = MJ + NL + 1 + 380 CONTINUE +C + JV = KJ + LFIRST = .FALSE. + END IF + GO TO 100 +C UNTIL ( F nonsingular, i.e., RCOND.GT.EPS*FNORM or +C FNORM.GT.EPS*norm(Y) ) + 400 CONTINUE +C +C Step 5: Compute TLS solution. +C -------------------- +C Solve X F = -Y by forward elimination (F is upper triangular). +C + CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L, + $ -ONE, DWORK(JF), LDF, X, LDX ) +C +C Set the optimal workspace and reciprocal condition number of F. +C + DWORK(1) = WRKOPT + DWORK(2) = RCOND +C + RETURN +C *** Last line of MB02ND *** + END diff --git a/mex/sources/libslicot/MB02NY.f b/mex/sources/libslicot/MB02NY.f new file mode 100644 index 000000000..acf0bce5a --- /dev/null +++ b/mex/sources/libslicot/MB02NY.f @@ -0,0 +1,261 @@ + SUBROUTINE MB02NY( UPDATU, UPDATV, M, N, I, K, Q, E, U, LDU, V, + $ LDV, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To separate a zero singular value of a bidiagonal submatrix of +C order k, k <= p, of the bidiagonal matrix +C +C |Q(1) E(1) 0 ... 0 | +C | 0 Q(2) E(2) . | +C J = | . . | +C | . E(p-1)| +C | 0 ... ... ... Q(p) | +C +C with p = MIN(M,N), by annihilating one or two superdiagonal +C elements E(i-1) (if i > 1) and/or E(i) (if i < k). +C +C ARGUMENTS +C +C Mode Parameters +C +C UPDATU LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix U the left-hand Givens rotations S, as follows: +C = .FALSE.: Do not form U; +C = .TRUE. : The given matrix U is updated (postmultiplied) +C by the left-hand Givens rotations S. +C +C UPDATV LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix V the right-hand Givens rotations T, as follows: +C = .FALSE.: Do not form V; +C = .TRUE. : The given matrix V is updated (postmultiplied) +C by the right-hand Givens rotations T. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix U. M >= 0. +C +C N (input) INTEGER +C The number of rows of the matrix V. N >= 0. +C +C I (input) INTEGER +C The index of the negligible diagonal entry Q(I) of the +C bidiagonal matrix J, I <= p. +C +C K (input) INTEGER +C The index of the last diagonal entry of the considered +C bidiagonal submatrix of J, i.e., E(K-1) is considered +C negligible, K <= p. +C +C Q (input/output) DOUBLE PRECISION array, dimension (p) +C where p = MIN(M,N). +C On entry, Q must contain the diagonal entries of the +C bidiagonal matrix J. +C On exit, Q contains the diagonal entries of the +C transformed bidiagonal matrix S' J T. +C +C E (input/output) DOUBLE PRECISION array, dimension (p-1) +C On entry, E must contain the superdiagonal entries of J. +C On exit, E contains the superdiagonal entries of the +C transformed bidiagonal matrix S' J T. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,p) +C On entry, if UPDATU = .TRUE., U must contain the M-by-p +C left transformation matrix. +C On exit, if UPDATU = .TRUE., the Givens rotations S on the +C left, annihilating E(i) if i < k, have been postmultiplied +C into U. +C U is not referenced if UPDATU = .FALSE.. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= max(1,M) if UPDATU = .TRUE.; +C LDU >= 1 if UPDATU = .FALSE.. +C +C V (input/output) DOUBLE PRECISION array, dimension (LDV,p) +C On entry, if UPDATV = .TRUE., V must contain the N-by-p +C right transformation matrix. +C On exit, if UPDATV = .TRUE., the Givens rotations T on the +C right, annihilating E(i-1) if i > 1, have been +C postmultiplied into V. +C V is not referenced if UPDATV = .FALSE.. +C +C LDV INTEGER +C The leading dimension of the array V. +C LDV >= max(1,N) if UPDATV = .TRUE.; +C LDV >= 1 if UPDATV = .FALSE.. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (MAX(1,LDWORK)) +C LDWORK >= 2*MAX(K-I,I-1), if UPDATV = UPDATU = .TRUE.; +C LDWORK >= 2*(K-I), if UPDATU = .TRUE., UPDATV = .FALSE.; +C LDWORK >= 2*(I-1), if UPDATV = .TRUE., UPDATU = .FALSE.; +C LDWORK >= 1, if UPDATU = UPDATV = .FALSE.. +C +C METHOD +C +C Let the considered bidiagonal submatrix be +C +C |Q(1) E(1) 0 ... 0 | +C | 0 Q(2) E(2) . | +C | . . | +C | . Q(i-1) E(i-1) . | +C Jk = | . Q(i) E(i) . |. +C | . Q(i+1) . . | +C | . .. . | +C | . E(k-1)| +C | 0 ... ... Q(k) | +C +C A zero singular value of Jk manifests itself by a zero diagonal +C entry Q(i) or in practice, a negligible value of Q(i). +C When a negligible diagonal element Q(i) in Jk is present, the +C bidiagonal submatrix Jk is split by the routine into 2 or 3 +C unreduced bidiagonal submatrices by annihilating E(i) (if i < k) +C using Givens rotations S on the left and by annihilating E(i-1) +C (if i > 1) using Givens rotations T on the right until Jk is +C reduced to the form: +C +C |Q(1) E(1) 0 ... 0 | +C | 0 . ... . | +C | . ... . | +C | . Q(i-1) 0 . | +C S' Jk T = | . 0 0 . |. +C | . Q(i+1) . . | +C | . .. . | +C | . E(k-1)| +C | 0 ... ... Q(k) | +C +C For more details, see [1, pp.11.12-11.14]. +C +C REFERENCES +C +C [1] Dongarra, J.J., Bunch, J.R., Moler C.B. and Stewart, G.W. +C LINPACK User's Guide. +C SIAM, Philadelphia, 1979. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. +C Supersedes Release 2.0 routine MB02BZ by S. Van Huffel, Katholieke +C University, Leuven, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Bidiagonal matrix, orthogonal transformation, singular values. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + LOGICAL UPDATU, UPDATV + INTEGER I, K, LDU, LDV, M, N +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), E(*), Q(*), U(LDU,*), V(LDV,*) +C .. Local Scalars .. + INTEGER I1, IROT, L, L1, NROT + DOUBLE PRECISION C, F, G, R, S +C .. External Subroutines .. + EXTERNAL DLARTG, DLASR +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C +C For speed, no tests of the input scalar arguments are done. +C +C Quick return if possible. +C + IF ( M.LE.0 .OR. N.LE.0 ) + $ RETURN +C + IF ( I.LE.MIN( M, N ) ) Q(I) = ZERO +C +C Annihilate E(I) (if I < K). +C + IF ( I.LT.K ) THEN + C = ZERO + S = ONE + IROT = 0 + NROT = K - I +C + DO 20 L = I, K-1 + G = E(L) + E(L) = C*G + CALL DLARTG( Q(L+1), S*G, C, S, R ) + Q(L+1) = R + IF ( UPDATU ) THEN + IROT = IROT + 1 + DWORK(IROT) = C + DWORK(IROT+NROT) = S + END IF + 20 CONTINUE +C + IF ( UPDATU ) + $ CALL DLASR( 'Right', 'Top', 'Forward', M, NROT+1, DWORK(1), + $ DWORK(NROT+1), U(1,I), LDU ) + END IF +C +C Annihilate E(I-1) (if I > 1). +C + IF ( I.GT.1 ) THEN + I1 = I - 1 + F = E(I1) + E(I1) = ZERO +C + DO 40 L1 = 1, I1 - 1 + L = I - L1 + CALL DLARTG( Q(L), F, C, S, R ) + Q(L) = R + IF ( UPDATV ) THEN + DWORK(L) = C + DWORK(L+I1) = S + END IF + G = E(L-1) + F = -S*G + E(L-1) = C*G + 40 CONTINUE +C + CALL DLARTG( Q(1), F, C, S, R ) + Q(1) = R + IF ( UPDATV ) THEN + DWORK(1) = C + DWORK(I) = S + CALL DLASR( 'Right', 'Bottom', 'Backward', N, I, DWORK(1), + $ DWORK(I), V(1,1), LDV ) + END IF + END IF +C + RETURN +C *** Last line of MB02NY *** + END diff --git a/mex/sources/libslicot/MB02OD.f b/mex/sources/libslicot/MB02OD.f new file mode 100644 index 000000000..0a6929954 --- /dev/null +++ b/mex/sources/libslicot/MB02OD.f @@ -0,0 +1,267 @@ + SUBROUTINE MB02OD( SIDE, UPLO, TRANS, DIAG, NORM, M, N, ALPHA, A, + $ LDA, B, LDB, RCOND, TOL, IWORK, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve (if well-conditioned) one of the matrix equations +C +C op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C +C where alpha is a scalar, X and B are m-by-n matrices, A is a unit, +C or non-unit, upper or lower triangular matrix and op( A ) is one +C of +C +C op( A ) = A or op( A ) = A'. +C +C An estimate of the reciprocal of the condition number of the +C triangular matrix A, in either the 1-norm or the infinity-norm, is +C also computed as +C +C RCOND = 1 / ( norm(A) * norm(inv(A)) ). +C +C and the specified matrix equation is solved only if RCOND is +C larger than a given tolerance TOL. In that case, the matrix X is +C overwritten on B. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies whether op( A ) appears on the left or right +C of X as follows: +C = 'L': op( A )*X = alpha*B; +C = 'R': X*op( A ) = alpha*B. +C +C UPLO CHARACTER*1 +C Specifies whether the matrix A is an upper or lower +C triangular matrix as follows: +C = 'U': A is an upper triangular matrix; +C = 'L': A is a lower triangular matrix. +C +C TRANS CHARACTER*1 +C Specifies the form of op( A ) to be used in the matrix +C multiplication as follows: +C = 'N': op( A ) = A; +C = 'T': op( A ) = A'; +C = 'C': op( A ) = A'. +C +C DIAG CHARACTER*1 +C Specifies whether or not A is unit triangular as follows: +C = 'U': A is assumed to be unit triangular; +C = 'N': A is not assumed to be unit triangular. +C +C NORM CHARACTER*1 +C Specifies whether the 1-norm condition number or the +C infinity-norm condition number is required: +C = '1' or 'O': 1-norm; +C = 'I': Infinity-norm. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of B. M >= 0. +C +C N (input) INTEGER +C The number of columns of B. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then A is not +C referenced and B need not be set before entry. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,k), +C where k is M when SIDE = 'L' and is N when SIDE = 'R'. +C On entry with UPLO = 'U', the leading k-by-k upper +C triangular part of this array must contain the upper +C triangular matrix and the strictly lower triangular part +C of A is not referenced. +C On entry with UPLO = 'L', the leading k-by-k lower +C triangular part of this array must contain the lower +C triangular matrix and the strictly upper triangular part +C of A is not referenced. +C Note that when DIAG = 'U', the diagonal elements of A are +C not referenced either, but are assumed to be unity. +C +C LDA INTEGER +C The leading dimension of array A. +C LDA >= max(1,M) when SIDE = 'L'; +C LDA >= max(1,N) when SIDE = 'R'. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading M-by-N part of this array must +C contain the right-hand side matrix B. +C On exit, if INFO = 0, the leading M-by-N part of this +C array contains the solution matrix X. +C Otherwise, this array is not modified by the routine. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= max(1,M). +C +C RCOND (output) DOUBLE PRECISION +C The reciprocal of the condition number of the matrix A, +C computed as RCOND = 1/(norm(A) * norm(inv(A))). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the matrix A. If the user sets TOL > 0, then the given +C value of TOL is used as a lower bound for the reciprocal +C condition number of that matrix; a matrix whose estimated +C condition number is less than 1/TOL is considered to be +C nonsingular. If the user sets TOL <= 0, then an implicitly +C computed, default tolerance, defined by TOLDEF = k*k*EPS, +C is used instead, where EPS is the machine precision (see +C LAPACK Library routine DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (k) +C +C DWORK DOUBLE PRECISION array, dimension (3*k) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the matrix A is numerically singular, i.e. the +C condition number estimate of A (in the specified +C norm) exceeds 1/TOL. +C +C METHOD +C +C An estimate of the reciprocal of the condition number of the +C triangular matrix A (in the specified norm) is computed, and if +C this estimate is larger then the given (or default) tolerance, +C the specified matrix equation is solved using Level 3 BLAS +C routine DTRSM. +C +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires k N/2 operations. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C +C REVISIONS +C +C February 20, 1998. +C +C KEYWORDS +C +C Condition number, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DIAG, NORM, SIDE, TRANS, UPLO + INTEGER INFO, LDA, LDB, M, N + DOUBLE PRECISION ALPHA, RCOND, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*) +C .. Local Scalars .. + LOGICAL LSIDE, ONENRM + INTEGER NROWA + DOUBLE PRECISION TOLDEF +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DTRCON, DTRSM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C .. Executable Statements .. +C + LSIDE = LSAME( SIDE, 'L' ) + IF( LSIDE )THEN + NROWA = M + ELSE + NROWA = N + END IF + ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) +C +C Test the input scalar arguments. +C + INFO = 0 + IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN + INFO = -1 + ELSE IF( ( .NOT.LSAME( UPLO, 'U' ) ).AND. + $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN + INFO = -2 + ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN + INFO = -3 + ELSE IF( ( .NOT.LSAME( DIAG, 'U' ) ).AND. + $ ( .NOT.LSAME( DIAG, 'N' ) ) )THEN + INFO = -4 + ELSE IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN + INFO = -5 + ELSE IF( M.LT.0 )THEN + INFO = -6 + ELSE IF( N.LT.0 )THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, M ) )THEN + INFO = -12 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( NROWA.EQ.0 ) THEN + RCOND = ONE + RETURN + END IF +C + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) + $ TOLDEF = DBLE( NROWA*NROWA )*DLAMCH( 'Epsilon' ) +C + CALL DTRCON( NORM, UPLO, DIAG, NROWA, A, LDA, RCOND, DWORK, + $ IWORK, INFO ) +C + IF ( RCOND.GT.TOLDEF ) THEN + CALL DTRSM( SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, LDA, B, + $ LDB ) + ELSE + INFO = 1 + END IF +C *** Last line of MB02OD *** + END diff --git a/mex/sources/libslicot/MB02PD.f b/mex/sources/libslicot/MB02PD.f new file mode 100644 index 000000000..e8fb4a9a8 --- /dev/null +++ b/mex/sources/libslicot/MB02PD.f @@ -0,0 +1,553 @@ + SUBROUTINE MB02PD( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, + $ IWORK, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve (if well-conditioned) the matrix equations +C +C op( A )*X = B, +C +C where X and B are N-by-NRHS matrices, A is an N-by-N matrix and +C op( A ) is one of +C +C op( A ) = A or op( A ) = A'. +C +C Error bounds on the solution and a condition estimate are also +C provided. +C +C ARGUMENTS +C +C Mode Parameters +C +C FACT CHARACTER*1 +C Specifies whether or not the factored form of the matrix A +C is supplied on entry, and if not, whether the matrix A +C should be equilibrated before it is factored. +C = 'F': On entry, AF and IPIV contain the factored form +C of A. If EQUED is not 'N', the matrix A has been +C equilibrated with scaling factors given by R +C and C. A, AF, and IPIV are not modified. +C = 'N': The matrix A will be copied to AF and factored. +C = 'E': The matrix A will be equilibrated if necessary, +C then copied to AF and factored. +C +C TRANS CHARACTER*1 +C Specifies the form of the system of equations as follows: +C = 'N': A * X = B (No transpose); +C = 'T': A**T * X = B (Transpose); +C = 'C': A**H * X = B (Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of linear equations, i.e., the order of the +C matrix A. N >= 0. +C +C NRHS (input) INTEGER +C The number of right hand sides, i.e., the number of +C columns of the matrices B and X. NRHS >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. If FACT = 'F' and EQUED is not 'N', +C then A must have been equilibrated by the scaling factors +C in R and/or C. A is not modified if FACT = 'F' or 'N', +C or if FACT = 'E' and EQUED = 'N' on exit. +C On exit, if EQUED .NE. 'N', the leading N-by-N part of +C this array contains the matrix A scaled as follows: +C EQUED = 'R': A := diag(R) * A; +C EQUED = 'C': A := A * diag(C); +C EQUED = 'B': A := diag(R) * A * diag(C). +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C AF (input or output) DOUBLE PRECISION array, dimension +C (LDAF,N) +C If FACT = 'F', then AF is an input argument and on entry +C the leading N-by-N part of this array must contain the +C factors L and U from the factorization A = P*L*U as +C computed by DGETRF. If EQUED .NE. 'N', then AF is the +C factored form of the equilibrated matrix A. +C If FACT = 'N', then AF is an output argument and on exit +C the leading N-by-N part of this array contains the factors +C L and U from the factorization A = P*L*U of the original +C matrix A. +C If FACT = 'E', then AF is an output argument and on exit +C the leading N-by-N part of this array contains the factors +C L and U from the factorization A = P*L*U of the +C equilibrated matrix A (see the description of A for the +C form of the equilibrated matrix). +C +C LDAF (input) INTEGER +C The leading dimension of the array AF. LDAF >= max(1,N). +C +C IPIV (input or output) INTEGER array, dimension (N) +C If FACT = 'F', then IPIV is an input argument and on entry +C it must contain the pivot indices from the factorization +C A = P*L*U as computed by DGETRF; row i of the matrix was +C interchanged with row IPIV(i). +C If FACT = 'N', then IPIV is an output argument and on exit +C it contains the pivot indices from the factorization +C A = P*L*U of the original matrix A. +C If FACT = 'E', then IPIV is an output argument and on exit +C it contains the pivot indices from the factorization +C A = P*L*U of the equilibrated matrix A. +C +C EQUED (input or output) CHARACTER*1 +C Specifies the form of equilibration that was done as +C follows: +C = 'N': No equilibration (always true if FACT = 'N'); +C = 'R': Row equilibration, i.e., A has been premultiplied +C by diag(R); +C = 'C': Column equilibration, i.e., A has been +C postmultiplied by diag(C); +C = 'B': Both row and column equilibration, i.e., A has +C been replaced by diag(R) * A * diag(C). +C EQUED is an input argument if FACT = 'F'; otherwise, it is +C an output argument. +C +C R (input or output) DOUBLE PRECISION array, dimension (N) +C The row scale factors for A. If EQUED = 'R' or 'B', A is +C multiplied on the left by diag(R); if EQUED = 'N' or 'C', +C R is not accessed. R is an input argument if FACT = 'F'; +C otherwise, R is an output argument. If FACT = 'F' and +C EQUED = 'R' or 'B', each element of R must be positive. +C +C C (input or output) DOUBLE PRECISION array, dimension (N) +C The column scale factors for A. If EQUED = 'C' or 'B', +C A is multiplied on the right by diag(C); if EQUED = 'N' +C or 'R', C is not accessed. C is an input argument if +C FACT = 'F'; otherwise, C is an output argument. If +C FACT = 'F' and EQUED = 'C' or 'B', each element of C must +C be positive. +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,NRHS) +C On entry, the leading N-by-NRHS part of this array must +C contain the right-hand side matrix B. +C On exit, +C if EQUED = 'N', B is not modified; +C if TRANS = 'N' and EQUED = 'R' or 'B', the leading +C N-by-NRHS part of this array contains diag(R)*B; +C if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', the leading +C N-by-NRHS part of this array contains diag(C)*B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) +C If INFO = 0 or INFO = N+1, the leading N-by-NRHS part of +C this array contains the solution matrix X to the original +C system of equations. Note that A and B are modified on +C exit if EQUED .NE. 'N', and the solution to the +C equilibrated system is inv(diag(C))*X if TRANS = 'N' and +C EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or +C 'C' and EQUED = 'R' or 'B'. +C +C LDX (input) INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C RCOND (output) DOUBLE PRECISION +C The estimate of the reciprocal condition number of the +C matrix A after equilibration (if done). If RCOND is less +C than the machine precision (in particular, if RCOND = 0), +C the matrix is singular to working precision. This +C condition is indicated by a return code of INFO > 0. +C For efficiency reasons, RCOND is computed only when the +C matrix A is factored, i.e., for FACT = 'N' or 'E'. For +C FACT = 'F', RCOND is not used, but it is assumed that it +C has been computed and checked before the routine call. +C +C FERR (output) DOUBLE PRECISION array, dimension (NRHS) +C The estimated forward error bound for each solution vector +C X(j) (the j-th column of the solution matrix X). +C If XTRUE is the true solution corresponding to X(j), +C FERR(j) is an estimated upper bound for the magnitude of +C the largest element in (X(j) - XTRUE) divided by the +C magnitude of the largest element in X(j). The estimate +C is as reliable as the estimate for RCOND, and is almost +C always a slight overestimate of the true error. +C +C BERR (output) DOUBLE PRECISION array, dimension (NRHS) +C The componentwise relative backward error of each solution +C vector X(j) (i.e., the smallest relative change in +C any element of A or B that makes X(j) an exact solution). +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (4*N) +C On exit, DWORK(1) contains the reciprocal pivot growth +C factor norm(A)/norm(U). The "max absolute element" norm is +C used. If DWORK(1) is much less than 1, then the stability +C of the LU factorization of the (equilibrated) matrix A +C could be poor. This also means that the solution X, +C condition estimator RCOND, and forward error bound FERR +C could be unreliable. If factorization fails with +C 0 < INFO <= N, then DWORK(1) contains the reciprocal pivot +C growth factor for the leading INFO columns of A. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, and i is +C <= N: U(i,i) is exactly zero. The factorization +C has been completed, but the factor U is +C exactly singular, so the solution and error +C bounds could not be computed. RCOND = 0 is +C returned. +C = N+1: U is nonsingular, but RCOND is less than +C machine precision, meaning that the matrix is +C singular to working precision. Nevertheless, +C the solution and error bounds are computed +C because there are a number of situations +C where the computed solution can be more +C accurate than the value of RCOND would +C suggest. +C The positive values for INFO are set only when the +C matrix A is factored, i.e., for FACT = 'N' or 'E'. +C +C METHOD +C +C The following steps are performed: +C +C 1. If FACT = 'E', real scaling factors are computed to equilibrate +C the system: +C +C TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B +C TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B +C TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B +C +C Whether or not the system will be equilibrated depends on the +C scaling of the matrix A, but if equilibration is used, A is +C overwritten by diag(R)*A*diag(C) and B by diag(R)*B +C (if TRANS='N') or diag(C)*B (if TRANS = 'T' or 'C'). +C +C 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +C the matrix A (after equilibration if FACT = 'E') as +C A = P * L * U, +C where P is a permutation matrix, L is a unit lower triangular +C matrix, and U is upper triangular. +C +C 3. If some U(i,i)=0, so that U is exactly singular, then the +C routine returns with INFO = i. Otherwise, the factored form +C of A is used to estimate the condition number of the matrix A. +C If the reciprocal of the condition number is less than machine +C precision, INFO = N+1 is returned as a warning, but the routine +C still goes on to solve for X and compute error bounds as +C described below. +C +C 4. The system of equations is solved for X using the factored form +C of A. +C +C 5. Iterative refinement is applied to improve the computed +C solution matrix and calculate error bounds and backward error +C estimates for it. +C +C 6. If equilibration was used, the matrix X is premultiplied by +C diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so +C that it solves the original system before equilibration. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., Sorensen, D. +C LAPACK Users' Guide: Second Edition, SIAM, Philadelphia, 1995. +C +C FURTHER COMMENTS +C +C This is a simplified version of the LAPACK Library routine DGESVX, +C useful when several sets of matrix equations with the same +C coefficient matrix A and/or A' should be solved. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Condition number, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUED, FACT, TRANS + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS + DOUBLE PRECISION RCOND +C .. +C .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ BERR( * ), C( * ), DWORK( * ), FERR( * ), + $ R( * ), X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU + CHARACTER NORM + INTEGER I, INFEQU, J + DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN, + $ ROWCND, RPVGRW, SMLNUM +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE, DLANTR + EXTERNAL LSAME, DLAMCH, DLANGE, DLANTR +C .. +C .. External Subroutines .. + EXTERNAL DGECON, DGEEQU, DGERFS, DGETRF, DGETRS, DLACPY, + $ DLAQGE, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Save Statement .. + SAVE RPVGRW +C .. +C .. Executable Statements .. +C + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + NOTRAN = LSAME( TRANS, 'N' ) + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + ROWEQU = .FALSE. + COLEQU = .FALSE. + ELSE + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + END IF +C +C Test the input parameters. +C + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) ) + $ THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -10 + ELSE + IF( ROWEQU ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 10 J = 1, N + RCMIN = MIN( RCMIN, R( J ) ) + RCMAX = MAX( RCMAX, R( J ) ) + 10 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -11 + ELSE IF( N.GT.0 ) THEN + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + ROWCND = ONE + END IF + END IF + IF( COLEQU .AND. INFO.EQ.0 ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 20 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 20 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -12 + ELSE IF( N.GT.0 ) THEN + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + COLCND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -16 + END IF + END IF + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02PD', -INFO ) + RETURN + END IF +C + IF( EQUIL ) THEN +C +C Compute row and column scalings to equilibrate the matrix A. +C + CALL DGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +C +C Equilibrate the matrix. +C + CALL DLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ EQUED ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF + END IF +C +C Scale the right hand side. +C + IF( NOTRAN ) THEN + IF( ROWEQU ) THEN + DO 40 J = 1, NRHS + DO 30 I = 1, N + B( I, J ) = R( I )*B( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE IF( COLEQU ) THEN + DO 60 J = 1, NRHS + DO 50 I = 1, N + B( I, J ) = C( I )*B( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +C + IF( NOFACT .OR. EQUIL ) THEN +C +C Compute the LU factorization of A. +C + CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF ) + CALL DGETRF( N, N, AF, LDAF, IPIV, INFO ) +C +C Return if INFO is non-zero. +C + IF( INFO.NE.0 ) THEN + IF( INFO.GT.0 ) THEN +C +C Compute the reciprocal pivot growth factor of the +C leading rank-deficient INFO columns of A. +C + RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF, + $ DWORK ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = DLANGE( 'M', N, INFO, A, LDA, DWORK ) / + $ RPVGRW + END IF + DWORK( 1 ) = RPVGRW + RCOND = ZERO + END IF + RETURN + END IF +C +C Compute the norm of the matrix A and the +C reciprocal pivot growth factor RPVGRW. +C + IF( NOTRAN ) THEN + NORM = '1' + ELSE + NORM = 'I' + END IF + ANORM = DLANGE( NORM, N, N, A, LDA, DWORK ) + RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AF, LDAF, DWORK ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = DLANGE( 'M', N, N, A, LDA, DWORK ) / RPVGRW + END IF +C +C Compute the reciprocal of the condition number of A. +C + CALL DGECON( NORM, N, AF, LDAF, ANORM, RCOND, DWORK, IWORK, + $ INFO ) +C +C Set INFO = N+1 if the matrix is singular to working precision. +C + IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) + $ INFO = N + 1 + END IF +C +C Compute the solution matrix X. +C + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) +C +C Use iterative refinement to improve the computed solution and +C compute error bounds and backward error estimates for it. +C + CALL DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, + $ LDX, FERR, BERR, DWORK, IWORK, INFO ) +C +C Transform the solution matrix X to a solution of the original +C system. +C + IF( NOTRAN ) THEN + IF( COLEQU ) THEN + DO 80 J = 1, NRHS + DO 70 I = 1, N + X( I, J ) = C( I )*X( I, J ) + 70 CONTINUE + 80 CONTINUE + DO 90 J = 1, NRHS + FERR( J ) = FERR( J ) / COLCND + 90 CONTINUE + END IF + ELSE IF( ROWEQU ) THEN + DO 110 J = 1, NRHS + DO 100 I = 1, N + X( I, J ) = R( I )*X( I, J ) + 100 CONTINUE + 110 CONTINUE + DO 120 J = 1, NRHS + FERR( J ) = FERR( J ) / ROWCND + 120 CONTINUE + END IF +C + DWORK( 1 ) = RPVGRW + RETURN +C +C *** Last line of MB02PD *** + END diff --git a/mex/sources/libslicot/MB02QD.f b/mex/sources/libslicot/MB02QD.f new file mode 100644 index 000000000..610c25043 --- /dev/null +++ b/mex/sources/libslicot/MB02QD.f @@ -0,0 +1,502 @@ + SUBROUTINE MB02QD( JOB, INIPER, M, N, NRHS, RCOND, SVLMAX, A, LDA, + $ B, LDB, Y, JPVT, RANK, SVAL, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a solution, optionally corresponding to specified free +C elements, to a real linear least squares problem: +C +C minimize || A * X - B || +C +C using a complete orthogonal factorization of the M-by-N matrix A, +C which may be rank-deficient. +C +C Several right hand side vectors b and solution vectors x can be +C handled in a single call; they are stored as the columns of the +C M-by-NRHS right hand side matrix B and the N-by-NRHS solution +C matrix X. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies whether or not a standard least squares solution +C must be computed, as follows: +C = 'L': Compute a standard least squares solution (Y = 0); +C = 'F': Compute a solution with specified free elements +C (given in Y). +C +C INIPER CHARACTER*1 +C Specifies whether an initial column permutation, defined +C by JPVT, must be performed, as follows: +C = 'P': Perform an initial column permutation; +C = 'N': Do not perform an initial column permutation. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C NRHS (input) INTEGER +C The number of right hand sides, i.e., the number of +C columns of the matrices B and X. NRHS >= 0. +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of A, which +C is defined as the order of the largest leading triangular +C submatrix R11 in the QR factorization with pivoting of A, +C whose estimated condition number is less than 1/RCOND. +C 0 <= RCOND <= 1. +C +C SVLMAX (input) DOUBLE PRECISION +C If A is a submatrix of another matrix C, and the rank +C decision should be related to that matrix, then SVLMAX +C should be an estimate of the largest singular value of C +C (for instance, the Frobenius norm of C). If this is not +C the case, the input value SVLMAX = 0 should work. +C SVLMAX >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading M-by-N part of this array must +C contain the given matrix A. +C On exit, the leading M-by-N part of this array contains +C details of its complete orthogonal factorization: +C the leading RANK-by-RANK upper triangular part contains +C the upper triangular factor T11 (see METHOD); +C the elements below the diagonal, with the entries 2 to +C min(M,N)+1 of the array DWORK, represent the orthogonal +C matrix Q as a product of min(M,N) elementary reflectors +C (see METHOD); +C the elements of the subarray A(1:RANK,RANK+1:N), with the +C next RANK entries of the array DWORK, represent the +C orthogonal matrix Z as a product of RANK elementary +C reflectors (see METHOD). +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,NRHS) +C On entry, the leading M-by-NRHS part of this array must +C contain the right hand side matrix B. +C On exit, the leading N-by-NRHS part of this array contains +C the solution matrix X. +C If M >= N and RANK = N, the residual sum-of-squares for +C the solution in the i-th column is given by the sum of +C squares of elements N+1:M in that column. +C If NRHS = 0, this array is not referenced, and the routine +C returns the effective rank of A, and its QR factorization. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,M,N). +C +C Y (input) DOUBLE PRECISION array, dimension ( N*NRHS ) +C If JOB = 'F', the elements Y(1:(N-RANK)*NRHS) are used as +C free elements in computing the solution (see METHOD). +C The remaining elements are not referenced. +C If JOB = 'L', or NRHS = 0, this array is not referenced. +C +C JPVT (input/output) INTEGER array, dimension (N) +C On entry with INIPER = 'P', if JPVT(i) <> 0, the i-th +C column of A is an initial column, otherwise it is a free +C column. Before the QR factorization of A, all initial +C columns are permuted to the leading positions; only the +C remaining free columns are moved as a result of column +C pivoting during the factorization. +C If INIPER = 'N', JPVT need not be set on entry. +C On exit, if JPVT(i) = k, then the i-th column of A*P +C was the k-th column of A. +C +C RANK (output) INTEGER +C The effective rank of A, i.e., the order of the submatrix +C R11. This is the same as the order of the submatrix T11 +C in the complete orthogonal factorization of A. +C +C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) +C The estimates of some of the singular values of the +C triangular factor R11: +C SVAL(1): largest singular value of R(1:RANK,1:RANK); +C SVAL(2): smallest singular value of R(1:RANK,1:RANK); +C SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1), +C if RANK < MIN( M, N ), or of R(1:RANK,1:RANK), +C otherwise. +C If the triangular factorization is a rank-revealing one +C (which will be the case if the leading columns were well- +C conditioned), then SVAL(1) will also be an estimate for +C the largest singular value of A, and SVAL(2) and SVAL(3) +C will be estimates for the RANK-th and (RANK+1)-st singular +C values of A, respectively. +C By examining these values, one can confirm that the rank +C is well defined with respect to the chosen value of RCOND. +C The ratio SVAL(1)/SVAL(2) is an estimate of the condition +C number of R(1:RANK,1:RANK). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension LDWORK +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and the entries 2 to min(M,N) + RANK + 1 +C contain the scalar factors of the elementary reflectors +C used in the complete orthogonal factorization of A. +C Among the entries 2 to min(M,N) + 1, only the first RANK +C elements are useful, if INIPER = 'N'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( min(M,N)+3*N+1, 2*min(M,N)+NRHS ) +C For optimum performance LDWORK should be larger. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C If INIPER = 'P', the routine first computes a QR factorization +C with column pivoting: +C A * P = Q * [ R11 R12 ] +C [ 0 R22 ] +C with R11 defined as the largest leading submatrix whose estimated +C condition number is less than 1/RCOND. The order of R11, RANK, +C is the effective rank of A. +C If INIPER = 'N', the effective rank is estimated during a +C truncated QR factorization (with column pivoting) process, and +C the submatrix R22 is not upper triangular, but full and of small +C norm. (See SLICOT Library routines MB03OD or MB03OY, respectively, +C for further details.) +C +C Then, R22 is considered to be negligible, and R12 is annihilated +C by orthogonal transformations from the right, arriving at the +C complete orthogonal factorization: +C A * P = Q * [ T11 0 ] * Z +C [ 0 0 ] +C The solution is then +C X = P * Z' [ inv(T11)*Q1'*B ] +C [ Y ] +C where Q1 consists of the first RANK columns of Q, and Y contains +C free elements (if JOB = 'F'), or is zero (if JOB = 'L'). +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C FURTHER COMMENTS +C +C Significant gain in efficiency is possible for small-rank problems +C using truncated QR factorization (option INIPER = 'N'). +C +C CONTRIBUTORS +C +C P.Hr. Petkov, Technical University of Sofia, Oct. 1998, +C modification of the LAPACK routine DGELSX. +C V. Sima, Katholieke Universiteit Leuven, Jan. 1999, SLICOT Library +C version. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. +C +C KEYWORDS +C +C Least squares problems, QR factorization. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO, ONE, DONE, NTDONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, DONE = ZERO, + $ NTDONE = ONE ) +C .. +C .. Scalar Arguments .. + CHARACTER INIPER, JOB + INTEGER INFO, LDA, LDB, LDWORK, M, N, NRHS, RANK + DOUBLE PRECISION RCOND, SVLMAX +C .. +C .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), + $ SVAL( 3 ), Y ( * ) +C .. +C .. Local Scalars .. + LOGICAL LEASTS, PERMUT + INTEGER I, IASCL, IBSCL, J, K, MAXWRK, MINWRK, MN + DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM, T1, T2 +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DLABAD, DLACPY, DLASCL, DLASET, DORMQR, DORMRZ, + $ DTRSM, DTZRZF, MB03OD, MB03OY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. +C .. Executable Statements .. +C + MN = MIN( M, N ) + LEASTS = LSAME( JOB, 'L' ) + PERMUT = LSAME( INIPER, 'P' ) +C +C Test the input scalar arguments. +C + INFO = 0 + MINWRK = MAX( MN + 3*N + 1, 2*MN + NRHS ) + IF( .NOT. ( LEASTS .OR. LSAME( JOB, 'F' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( PERMUT .OR. LSAME( INIPER, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -5 + ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN + INFO = -6 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.MINWRK ) THEN + INFO = -17 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MN.EQ.0 ) THEN + RANK = 0 + DWORK( 1 ) = ONE + RETURN + END IF +C +C Get machine parameters. +C + SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C +C Scale A, B if max entries outside range [SMLNUM,BIGNUM]. +C + ANRM = DLANGE( 'M', M, N, A, LDA, DWORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN +C +C Scale matrix norm up to SMLNUM. +C + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN +C +C Scale matrix norm down to BIGNUM. +C + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN +C +C Matrix all zero. Return zero solution. +C + IF( NRHS.GT.0 ) + $ CALL DLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) + RANK = 0 + DWORK( 1 ) = ONE + RETURN + END IF +C + IF( NRHS.GT.0 ) THEN + BNRM = DLANGE( 'M', M, NRHS, B, LDB, DWORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN +C +C Scale matrix norm up to SMLNUM. +C + CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, + $ INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN +C +C Scale matrix norm down to BIGNUM. +C + CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, + $ INFO ) + IBSCL = 2 + END IF + END IF +C +C Compute a rank-revealing QR factorization of A and estimate its +C effective rank using incremental condition estimation: +C A * P = Q * R. +C Workspace need min(M,N)+3*N+1; +C prefer min(M,N)+2*N+N*NB. +C Details of Householder transformations stored in DWORK(1:MN). +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + MAXWRK = MINWRK + IF( PERMUT ) THEN + CALL MB03OD( 'Q', M, N, A, LDA, JPVT, RCOND, SVLMAX, + $ DWORK( 1 ), RANK, SVAL, DWORK( MN+1 ), LDWORK-MN, + $ INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK( MN+1 ) ) + MN ) + ELSE + CALL MB03OY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, + $ DWORK( 1 ), DWORK( MN+1 ), INFO ) + END IF +C +C Logically partition R = [ R11 R12 ] +C [ 0 R22 ], +C where R11 = R(1:RANK,1:RANK). +C +C [R11,R12] = [ T11, 0 ] * Z. +C +C Details of Householder transformations stored in DWORK(MN+1:2*MN). +C Workspace need 3*min(M,N); +C prefer 2*min(M,N)+min(M,N)*NB. +C + IF( RANK.LT.N ) THEN + CALL DTZRZF( RANK, N, A, LDA, DWORK( MN+1 ), DWORK( 2*MN+1 ), + $ LDWORK-2*MN, INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN ) + END IF +C + IF( NRHS.GT.0 ) THEN +C +C B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS). +C +C Workspace: need 2*min(M,N)+NRHS; +C prefer min(M,N)+NRHS*NB. +C + CALL DORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA, + $ DWORK( 1 ), B, LDB, DWORK( 2*MN+1 ), LDWORK-2*MN, + $ INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN ) +C +C B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS). +C + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, + $ NRHS, ONE, A, LDA, B, LDB ) +C + IF( RANK.LT.N ) THEN +C +C Set B(RANK+1:N,1:NRHS). +C + IF( LEASTS ) THEN + CALL DLASET( 'Full', N-RANK, NRHS, ZERO, ZERO, + $ B(RANK+1,1), LDB ) + ELSE + CALL DLACPY( 'Full', N-RANK, NRHS, Y, N-RANK, + $ B(RANK+1,1), LDB ) + END IF +C +C B(1:N,1:NRHS) := Z' * B(1:N,1:NRHS). +C +C Workspace need 2*min(M,N)+NRHS; +C prefer 2*min(M,N)+NRHS*NB. +C + CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A, + $ LDA, DWORK( MN+1 ), B, LDB, DWORK( 2*MN+1 ), + $ LDWORK-2*MN, INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN ) + END IF +C +C Additional workspace: NRHS. +C +C B(1:N,1:NRHS) := P * B(1:N,1:NRHS). +C + DO 50 J = 1, NRHS + DO 20 I = 1, N + DWORK( 2*MN+I ) = NTDONE + 20 CONTINUE + DO 40 I = 1, N + IF( DWORK( 2*MN+I ).EQ.NTDONE ) THEN + IF( JPVT( I ).NE.I ) THEN + K = I + T1 = B( K, J ) + T2 = B( JPVT( K ), J ) + 30 CONTINUE + B( JPVT( K ), J ) = T1 + DWORK( 2*MN+K ) = DONE + T1 = T2 + K = JPVT( K ) + T2 = B( JPVT( K ), J ) + IF( JPVT( K ).NE.I ) + $ GO TO 30 + B( I, J ) = T1 + DWORK( 2*MN+K ) = DONE + END IF + END IF + 40 CONTINUE + 50 CONTINUE +C +C Undo scaling for B. +C + IF( IBSCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, + $ INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, + $ INFO ) + END IF + END IF +C +C Undo scaling for A. +C + IF( IASCL.EQ.1 ) THEN + IF( NRHS.GT.0 ) + $ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, + $ INFO ) + CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA, + $ INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + IF( NRHS.GT.0 ) + $ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, + $ INFO ) + CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA, + $ INFO ) + END IF +C + DO 60 I = MN + RANK, 1, -1 + DWORK( I+1 ) = DWORK( I ) + 60 CONTINUE +C + DWORK( 1 ) = MAXWRK + RETURN +C *** Last line of MB02QD *** + END diff --git a/mex/sources/libslicot/MB02QY.f b/mex/sources/libslicot/MB02QY.f new file mode 100644 index 000000000..329f54d46 --- /dev/null +++ b/mex/sources/libslicot/MB02QY.f @@ -0,0 +1,339 @@ + SUBROUTINE MB02QY( M, N, NRHS, RANK, A, LDA, JPVT, B, LDB, TAU, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine the minimum-norm solution to a real linear least +C squares problem: +C +C minimize || A * X - B ||, +C +C using the rank-revealing QR factorization of a real general +C M-by-N matrix A, computed by SLICOT Library routine MB03OD. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices A and B. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C NRHS (input) INTEGER +C The number of columns of the matrix B. NRHS >= 0. +C +C RANK (input) INTEGER +C The effective rank of A, as returned by SLICOT Library +C routine MB03OD. min(M,N) >= RANK >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C ( LDA, N ) +C On entry, the leading min(M,N)-by-N upper trapezoidal +C part of this array contains the triangular factor R, as +C returned by SLICOT Library routine MB03OD. The strict +C lower trapezoidal part of A is not referenced. +C On exit, if RANK < N, the leading RANK-by-RANK upper +C triangular part of this array contains the upper +C triangular matrix R of the complete orthogonal +C factorization of A, and the submatrix (1:RANK,RANK+1:N) +C of this array, with the array TAU, represent the +C orthogonal matrix Z (of the complete orthogonal +C factorization of A), as a product of RANK elementary +C reflectors. +C On exit, if RANK = N, this array is unchanged. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C JPVT (input) INTEGER array, dimension ( N ) +C The recorded permutations performed by SLICOT Library +C routine MB03OD; if JPVT(i) = k, then the i-th column +C of A*P was the k-th column of the original matrix A. +C +C B (input/output) DOUBLE PRECISION array, dimension +C ( LDB, NRHS ) +C On entry, if NRHS > 0, the leading M-by-NRHS part of +C this array must contain the matrix B (corresponding to +C the transformed matrix A, returned by SLICOT Library +C routine MB03OD). +C On exit, if NRHS > 0, the leading N-by-NRHS part of this +C array contains the solution matrix X. +C If M >= N and RANK = N, the residual sum-of-squares +C for the solution in the i-th column is given by the sum +C of squares of elements N+1:M in that column. +C If NRHS = 0, the array B is not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= max(1,M,N), if NRHS > 0. +C LDB >= 1, if NRHS = 0. +C +C TAU (output) DOUBLE PRECISION array, dimension ( min(M,N) ) +C The scalar factors of the elementary reflectors. +C If RANK = N, the array TAU is not referenced. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( 1, N, NRHS ). +C For good performance, LDWORK should sometimes be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine uses a QR factorization with column pivoting: +C +C A * P = Q * R = Q * [ R11 R12 ], +C [ 0 R22 ] +C +C where R11 is an upper triangular submatrix of estimated rank +C RANK, the effective rank of A. The submatrix R22 can be +C considered as negligible. +C +C If RANK < N, then R12 is annihilated by orthogonal +C transformations from the right, arriving at the complete +C orthogonal factorization: +C +C A * P = Q * [ T11 0 ] * Z. +C [ 0 0 ] +C +C The minimum-norm solution is then +C +C X = P * Z' [ inv(T11)*Q1'*B ], +C [ 0 ] +C +C where Q1 consists of the first RANK columns of Q. +C +C The input data for MB02QY are the transformed matrices Q' * A +C (returned by SLICOT Library routine MB03OD) and Q' * B. +C Matrix Q is not needed. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Least squares solutions; QR decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDWORK, M, N, NRHS, RANK +C .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), TAU( * ) +C .. Local Scalars .. + INTEGER I, IASCL, IBSCL, J, MN + DOUBLE PRECISION ANRM, BIGNUM, BNRM, MAXWRK, SMLNUM +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLANTR + EXTERNAL DLAMCH, DLANGE, DLANTR +C .. External Subroutines .. + EXTERNAL DCOPY, DLABAD, DLASCL, DLASET, DORMRZ, DTRSM, + $ DTZRZF, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. +C .. Executable Statements .. +C + MN = MIN( M, N ) +C +C Test the input scalar arguments. +C + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( RANK.LT.0 .OR. RANK.GT.MN ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.1 .OR. ( NRHS.GT.0 .AND. LDB.LT.MAX( M, N ) ) ) + $ THEN + INFO = -9 + ELSE IF( LDWORK.LT.MAX( 1, N, NRHS ) ) THEN + INFO = -12 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02QY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( MN, NRHS ).EQ.0 ) THEN + DWORK( 1 ) = ONE + RETURN + END IF +C +C Logically partition R = [ R11 R12 ], +C [ 0 R22 ] +C +C where R11 = R(1:RANK,1:RANK). If RANK = N, let T11 = R11. +C + MAXWRK = DBLE( N ) + IF( RANK.LT.N ) THEN +C +C Get machine parameters. +C + SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C +C Scale A, B if max entries outside range [SMLNUM,BIGNUM]. +C + ANRM = DLANTR( 'MaxNorm', 'Upper', 'Non-unit', RANK, N, A, LDA, + $ DWORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN +C +C Scale matrix norm up to SMLNUM. +C + CALL DLASCL( 'Upper', 0, 0, ANRM, SMLNUM, RANK, N, A, LDA, + $ INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN +C +C Scale matrix norm down to BIGNUM. +C + CALL DLASCL( 'Upper', 0, 0, ANRM, BIGNUM, RANK, N, A, LDA, + $ INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN +C +C Matrix all zero. Return zero solution. +C + CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, B, LDB ) + DWORK( 1 ) = ONE + RETURN + END IF +C + BNRM = DLANGE( 'MaxNorm', M, NRHS, B, LDB, DWORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN +C +C Scale matrix norm up to SMLNUM. +C + CALL DLASCL( 'General', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, + $ INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN +C +C Scale matrix norm down to BIGNUM. +C + CALL DLASCL( 'General', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, + $ INFO ) + IBSCL = 2 + END IF +C +C [R11,R12] = [ T11, 0 ] * Z. +C Details of Householder rotations are stored in TAU. +C Workspace need RANK, prefer RANK*NB. +C + CALL DTZRZF( RANK, N, A, LDA, TAU, DWORK, LDWORK, INFO ) + MAXWRK = MAX( MAXWRK, DWORK( 1 ) ) + END IF +C +C B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS). +C + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, + $ NRHS, ONE, A, LDA, B, LDB ) +C + IF( RANK.LT.N ) THEN +C + CALL DLASET( 'Full', N-RANK, NRHS, ZERO, ZERO, B( RANK+1, 1 ), + $ LDB ) +C +C B(1:N,1:NRHS) := Z' * B(1:N,1:NRHS). +C Workspace need NRHS, prefer NRHS*NB. +C + CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A, + $ LDA, TAU, B, LDB, DWORK, LDWORK, INFO ) + MAXWRK = MAX( MAXWRK, DWORK( 1 ) ) +C +C Undo scaling. +C + IF( IASCL.EQ.1 ) THEN + CALL DLASCL( 'General', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, + $ INFO ) + CALL DLASCL( 'Upper', 0, 0, SMLNUM, ANRM, RANK, RANK, A, + $ LDA, INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + CALL DLASCL( 'General', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, + $ INFO ) + CALL DLASCL( 'Upper', 0, 0, BIGNUM, ANRM, RANK, RANK, A, + $ LDA, INFO ) + END IF + IF( IBSCL.EQ.1 ) THEN + CALL DLASCL( 'General', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, + $ INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL DLASCL( 'General', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, + $ INFO ) + END IF + END IF +C +C B(1:N,1:NRHS) := P * B(1:N,1:NRHS). +C Workspace N. +C + DO 20 J = 1, NRHS +C + DO 10 I = 1, N + DWORK( JPVT( I ) ) = B( I, J ) + 10 CONTINUE +C + CALL DCOPY( N, DWORK, 1, B( 1, J ), 1 ) + 20 CONTINUE +C + DWORK( 1 ) = MAXWRK + RETURN +C +C *** Last line of MB02QY *** + END diff --git a/mex/sources/libslicot/MB02RD.f b/mex/sources/libslicot/MB02RD.f new file mode 100644 index 000000000..d524e7f9b --- /dev/null +++ b/mex/sources/libslicot/MB02RD.f @@ -0,0 +1,197 @@ + SUBROUTINE MB02RD( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a system of linear equations +C H * X = B or H' * X = B +C with an upper Hessenberg N-by-N matrix H using the LU +C factorization computed by MB02SD. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANS CHARACTER*1 +C Specifies the form of the system of equations: +C = 'N': H * X = B (No transpose) +C = 'T': H'* X = B (Transpose) +C = 'C': H'* X = B (Conjugate transpose = Transpose) +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix H. N >= 0. +C +C NRHS (input) INTEGER +C The number of right hand sides, i.e., the number of +C columns of the matrix B. NRHS >= 0. +C +C H (input) DOUBLE PRECISION array, dimension (LDH,N) +C The factors L and U from the factorization H = P*L*U +C as computed by MB02SD. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C IPIV (input) INTEGER array, dimension (N) +C The pivot indices from MB02SD; for 1<=i<=N, row i of the +C matrix was interchanged with row IPIV(i). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,NRHS) +C On entry, the right hand side matrix B. +C On exit, the solution matrix X. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C Error Indicator +C +C INFO (output) INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine uses the factorization +C H = P * L * U +C where P is a permutation matrix, L is lower triangular with unit +C diagonal elements (and one nonzero subdiagonal), and U is upper +C triangular. +C +C REFERENCES +C +C - +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0( N x NRHS ) operations. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +C .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDB, LDH, N, NRHS +C .. +C .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION B( LDB, * ), H( LDH, * ) +C .. Local Scalars .. + LOGICAL NOTRAN + INTEGER J, JP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DSWAP, DTRSM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Test the input parameters. +C + INFO = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +C + IF( NOTRAN ) THEN +C +C Solve H * X = B. +C +C Solve L * X = B, overwriting B with X. +C +C L is represented as a product of permutations and unit lower +C triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), +C where each transformation L(i) is a rank-one modification of +C the identity matrix. +C + DO 10 J = 1, N - 1 + JP = IPIV( J ) + IF( JP.NE.J ) + $ CALL DSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) + CALL DAXPY( NRHS, -H( J+1, J ), B( J, 1 ), LDB, B( J+1, 1 ), + $ LDB ) + 10 CONTINUE +C +C Solve U * X = B, overwriting B with X. +C + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, + $ NRHS, ONE, H, LDH, B, LDB ) +C + ELSE +C +C Solve H' * X = B. +C +C Solve U' * X = B, overwriting B with X. +C + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, + $ ONE, H, LDH, B, LDB ) +C +C Solve L' * X = B, overwriting B with X. +C + DO 20 J = N - 1, 1, -1 + CALL DAXPY( NRHS, -H( J+1, J ), B( J+1, 1 ), LDB, B( J, 1 ), + $ LDB ) + JP = IPIV( J ) + IF( JP.NE.J ) + $ CALL DSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) + 20 CONTINUE + END IF +C + RETURN +C *** Last line of MB02RD *** + END diff --git a/mex/sources/libslicot/MB02RZ.f b/mex/sources/libslicot/MB02RZ.f new file mode 100644 index 000000000..a82be52be --- /dev/null +++ b/mex/sources/libslicot/MB02RZ.f @@ -0,0 +1,216 @@ + SUBROUTINE MB02RZ( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a system of linear equations +C H * X = B, H' * X = B or H**H * X = B +C with a complex upper Hessenberg N-by-N matrix H using the LU +C factorization computed by MB02SZ. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANS CHARACTER*1 +C Specifies the form of the system of equations: +C = 'N': H * X = B (No transpose) +C = 'T': H'* X = B (Transpose) +C = 'C': H**H * X = B (Conjugate transpose) +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix H. N >= 0. +C +C NRHS (input) INTEGER +C The number of right hand sides, i.e., the number of +C columns of the matrix B. NRHS >= 0. +C +C H (input) COMPLEX*16 array, dimension (LDH,N) +C The factors L and U from the factorization H = P*L*U +C as computed by MB02SZ. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C IPIV (input) INTEGER array, dimension (N) +C The pivot indices from MB02SZ; for 1<=i<=N, row i of the +C matrix was interchanged with row IPIV(i). +C +C B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) +C On entry, the right hand side matrix B. +C On exit, the solution matrix X. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C INFO (output) INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine uses the factorization +C H = P * L * U +C where P is a permutation matrix, L is lower triangular with unit +C diagonal elements (and one nonzero subdiagonal), and U is upper +C triangular. +C +C REFERENCES +C +C - +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0( N x NRHS ) complex operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TB01FW by A.J. Laub, University of +C Southern California, United States of America, May 1980. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Frequency response, Hessenberg form, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +C .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDB, LDH, N, NRHS +C .. +C .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 B( LDB, * ), H( LDH, * ) +C .. Local Scalars .. + LOGICAL NOTRAN + INTEGER J, JP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL XERBLA, ZAXPY, ZSWAP, ZTRSM +C .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +C .. Executable Statements .. +C +C Test the input parameters. +C + INFO = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02RZ', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +C + IF( NOTRAN ) THEN +C +C Solve H * X = B. +C +C Solve L * X = B, overwriting B with X. +C +C L is represented as a product of permutations and unit lower +C triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), +C where each transformation L(i) is a rank-one modification of +C the identity matrix. +C + DO 10 J = 1, N - 1 + JP = IPIV( J ) + IF( JP.NE.J ) + $ CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) + CALL ZAXPY( NRHS, -H( J+1, J ), B( J, 1 ), LDB, B( J+1, 1 ), + $ LDB ) + 10 CONTINUE +C +C Solve U * X = B, overwriting B with X. +C + CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, + $ NRHS, ONE, H, LDH, B, LDB ) +C + ELSE IF( LSAME( TRANS, 'T' ) ) THEN +C +C Solve H' * X = B. +C +C Solve U' * X = B, overwriting B with X. +C + CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, + $ H, LDH, B, LDB ) +C +C Solve L' * X = B, overwriting B with X. +C + DO 20 J = N - 1, 1, -1 + CALL ZAXPY( NRHS, -H( J+1, J ), B( J+1, 1 ), LDB, B( J, 1 ), + $ LDB ) + JP = IPIV( J ) + IF( JP.NE.J ) + $ CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) + 20 CONTINUE +C + ELSE +C +C Solve H**H * X = B. +C +C Solve U**H * X = B, overwriting B with X. +C + CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, + $ H, LDH, B, LDB ) +C +C Solve L**H * X = B, overwriting B with X. +C + DO 30 J = N - 1, 1, -1 + CALL ZAXPY( NRHS, -DCONJG( H( J+1, J ) ), B( J+1, 1 ), LDB, + $ B( J, 1 ), LDB ) + JP = IPIV( J ) + IF( JP.NE.J ) + $ CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) + 30 CONTINUE +C + END IF +C + RETURN +C *** Last line of MB02RZ *** + END diff --git a/mex/sources/libslicot/MB02SD.f b/mex/sources/libslicot/MB02SD.f new file mode 100644 index 000000000..2c72554ee --- /dev/null +++ b/mex/sources/libslicot/MB02SD.f @@ -0,0 +1,164 @@ + SUBROUTINE MB02SD( N, H, LDH, IPIV, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute an LU factorization of an n-by-n upper Hessenberg +C matrix H using partial pivoting with row interchanges. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix H. N >= 0. +C +C H (input/output) DOUBLE PRECISION array, dimension (LDH,N) +C On entry, the n-by-n upper Hessenberg matrix to be +C factored. +C On exit, the factors L and U from the factorization +C H = P*L*U; the unit diagonal elements of L are not stored, +C and L is lower bidiagonal. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C IPIV (output) INTEGER array, dimension (N) +C The pivot indices; for 1 <= i <= N, row i of the matrix +C was interchanged with row IPIV(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, U(i,i) is exactly zero. The +C factorization has been completed, but the factor U +C is exactly singular, and division by zero will occur +C if it is used to solve a system of equations. +C +C METHOD +C +C The factorization has the form +C H = P * L * U +C where P is a permutation matrix, L is lower triangular with unit +C diagonal elements (and one nonzero subdiagonal), and U is upper +C triangular. +C +C This is the right-looking Level 1 BLAS version of the algorithm +C (adapted after DGETF2). +C +C REFERENCES +C +C - +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0( N ) operations. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, +C Jan. 2005. +C +C KEYWORDS +C +C Hessenberg form, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDH, N +C .. Array Arguments .. + INTEGER IPIV(*) + DOUBLE PRECISION H(LDH,*) +C .. Local Scalars .. + INTEGER J, JP +C .. External Subroutines .. + EXTERNAL DAXPY, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02SD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C + DO 10 J = 1, N +C +C Find pivot and test for singularity. +C + JP = J + IF ( J.LT.N ) THEN + IF ( ABS( H( J+1, J ) ).GT.ABS( H( J, J ) ) ) + $ JP = J + 1 + END IF + IPIV( J ) = JP + IF( H( JP, J ).NE.ZERO ) THEN +C +C Apply the interchange to columns J:N. +C + IF( JP.NE.J ) + $ CALL DSWAP( N-J+1, H( J, J ), LDH, H( JP, J ), LDH ) +C +C Compute element J+1 of J-th column. +C + IF( J.LT.N ) + $ H( J+1, J ) = H( J+1, J )/H( J, J ) +C + ELSE IF( INFO.EQ.0 ) THEN +C + INFO = J + END IF +C + IF( J.LT.N ) THEN +C +C Update trailing submatrix. +C + CALL DAXPY( N-J, -H( J+1, J ), H( J, J+1 ), LDH, + $ H( J+1, J+1 ), LDH ) + END IF + 10 CONTINUE + RETURN +C *** Last line of MB02SD *** + END diff --git a/mex/sources/libslicot/MB02SZ.f b/mex/sources/libslicot/MB02SZ.f new file mode 100644 index 000000000..4643a9189 --- /dev/null +++ b/mex/sources/libslicot/MB02SZ.f @@ -0,0 +1,169 @@ + SUBROUTINE MB02SZ( N, H, LDH, IPIV, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute an LU factorization of a complex n-by-n upper +C Hessenberg matrix H using partial pivoting with row interchanges. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix H. N >= 0. +C +C H (input/output) COMPLEX*16 array, dimension (LDH,N) +C On entry, the n-by-n upper Hessenberg matrix to be +C factored. +C On exit, the factors L and U from the factorization +C H = P*L*U; the unit diagonal elements of L are not stored, +C and L is lower bidiagonal. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C IPIV (output) INTEGER array, dimension (N) +C The pivot indices; for 1 <= i <= N, row i of the matrix +C was interchanged with row IPIV(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, U(i,i) is exactly zero. The +C factorization has been completed, but the factor U +C is exactly singular, and division by zero will occur +C if it is used to solve a system of equations. +C +C METHOD +C +C The factorization has the form +C H = P * L * U +C where P is a permutation matrix, L is lower triangular with unit +C diagonal elements (and one nonzero subdiagonal), and U is upper +C triangular. +C +C This is the right-looking Level 2 BLAS version of the algorithm +C (adapted after ZGETF2). +C +C REFERENCES +C +C - +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0( N ) complex operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TB01FX by A.J. Laub, University of +C Southern California, United States of America, May 1980. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, +C Jan. 2005. +C +C KEYWORDS +C +C Frequency response, Hessenberg form, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +C .. Scalar Arguments .. + INTEGER INFO, LDH, N +C .. Array Arguments .. + INTEGER IPIV(*) + COMPLEX*16 H(LDH,*) +C .. Local Scalars .. + INTEGER J, JP +C .. External Functions .. + DOUBLE PRECISION DCABS1 + EXTERNAL DCABS1 +C .. External Subroutines .. + EXTERNAL XERBLA, ZAXPY, ZSWAP +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02SZ', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C + DO 10 J = 1, N +C +C Find pivot and test for singularity. +C + JP = J + IF ( J.LT.N ) THEN + IF ( DCABS1( H( J+1, J ) ).GT.DCABS1( H( J, J ) ) ) + $ JP = J + 1 + END IF + IPIV( J ) = JP + IF( H( JP, J ).NE.ZERO ) THEN +C +C Apply the interchange to columns J:N. +C + IF( JP.NE.J ) + $ CALL ZSWAP( N-J+1, H( J, J ), LDH, H( JP, J ), LDH ) +C +C Compute element J+1 of J-th column. +C + IF( J.LT.N ) + $ H( J+1, J ) = H( J+1, J )/H( J, J ) +C + ELSE IF( INFO.EQ.0 ) THEN +C + INFO = J + END IF +C + IF( J.LT.N ) THEN +C +C Update trailing submatrix. +C + CALL ZAXPY( N-J, -H( J+1, J ), H( J, J+1 ), LDH, + $ H( J+1, J+1 ), LDH ) + END IF + 10 CONTINUE + RETURN +C *** Last line of MB02SZ *** + END diff --git a/mex/sources/libslicot/MB02TD.f b/mex/sources/libslicot/MB02TD.f new file mode 100644 index 000000000..865ffbf39 --- /dev/null +++ b/mex/sources/libslicot/MB02TD.f @@ -0,0 +1,236 @@ + SUBROUTINE MB02TD( NORM, N, HNORM, H, LDH, IPIV, RCOND, IWORK, + $ DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the reciprocal of the condition number of an upper +C Hessenberg matrix H, in either the 1-norm or the infinity-norm, +C using the LU factorization computed by MB02SD. +C +C ARGUMENTS +C +C Mode Parameters +C +C NORM CHARACTER*1 +C Specifies whether the 1-norm condition number or the +C infinity-norm condition number is required: +C = '1' or 'O': 1-norm; +C = 'I': Infinity-norm. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix H. N >= 0. +C +C HNORM (input) DOUBLE PRECISION +C If NORM = '1' or 'O', the 1-norm of the original matrix H. +C If NORM = 'I', the infinity-norm of the original matrix H. +C +C H (input) DOUBLE PRECISION array, dimension (LDH,N) +C The factors L and U from the factorization H = P*L*U +C as computed by MB02SD. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C IPIV (input) INTEGER array, dimension (N) +C The pivot indices; for 1 <= i <= N, row i of the matrix +C was interchanged with row IPIV(i). +C +C RCOND (output) DOUBLE PRECISION +C The reciprocal of the condition number of the matrix H, +C computed as RCOND = 1/(norm(H) * norm(inv(H))). +C +C Workspace +C +C IWORK DOUBLE PRECISION array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (3*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C An estimate is obtained for norm(inv(H)), and the reciprocal of +C the condition number is computed as +C RCOND = 1 / ( norm(H) * norm(inv(H)) ). +C +C REFERENCES +C +C - +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0( N ) operations. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER NORM + INTEGER INFO, LDH, N + DOUBLE PRECISION HNORM, RCOND +C .. +C .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION DWORK( * ), H( LDH, * ) +C .. Local Scalars .. + LOGICAL ONENRM + CHARACTER NORMIN + INTEGER IX, J, JP, KASE, KASE1 +C + DOUBLE PRECISION HINVNM, SCALE, SMLNUM, T +C .. +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, IDAMAX, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DLACON, DLATRS, DRSCL, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. +C .. Executable Statements .. +C +C Test the input parameters. +C + INFO = 0 + ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) + IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( HNORM.LT.ZERO ) THEN + INFO = -3 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02TD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( HNORM.EQ.ZERO ) THEN + RETURN + END IF +C + SMLNUM = DLAMCH( 'Safe minimum' ) +C +C Estimate the norm of inv(H). +C + HINVNM = ZERO + NORMIN = 'N' + IF( ONENRM ) THEN + KASE1 = 1 + ELSE + KASE1 = 2 + END IF + KASE = 0 + 10 CONTINUE + CALL DLACON( N, DWORK( N+1 ), DWORK, IWORK, HINVNM, KASE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.KASE1 ) THEN +C +C Multiply by inv(L). +C + DO 20 J = 1, N - 1 + JP = IPIV( J ) + T = DWORK( JP ) + IF( JP.NE.J ) THEN + DWORK( JP ) = DWORK( J ) + DWORK( J ) = T + END IF + DWORK( J+1 ) = DWORK( J+1 ) - T * H( J+1, J ) + 20 CONTINUE +C +C Multiply by inv(U). +C + CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, + $ H, LDH, DWORK, SCALE, DWORK( 2*N+1 ), INFO ) + ELSE +C +C Multiply by inv(U'). +C + CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, H, + $ LDH, DWORK, SCALE, DWORK( 2*N+1 ), INFO ) +C +C Multiply by inv(L'). +C + DO 30 J = N - 1, 1, -1 + DWORK( J ) = DWORK( J ) - H( J+1, J ) * DWORK( J+1 ) + JP = IPIV( J ) + IF( JP.NE.J ) THEN + T = DWORK( JP ) + DWORK( JP ) = DWORK( J ) + DWORK( J ) = T + END IF + 30 CONTINUE + END IF +C +C Divide X by 1/SCALE if doing so will not cause overflow. +C + NORMIN = 'Y' + IF( SCALE.NE.ONE ) THEN + IX = IDAMAX( N, DWORK, 1 ) + IF( SCALE.LT.ABS( DWORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO + $ ) GO TO 40 + CALL DRSCL( N, SCALE, DWORK, 1 ) + END IF + GO TO 10 + END IF +C +C Compute the estimate of the reciprocal condition number. +C + IF( HINVNM.NE.ZERO ) + $ RCOND = ( ONE / HINVNM ) / HNORM +C + 40 CONTINUE + RETURN +C *** Last line of MB02TD *** + END diff --git a/mex/sources/libslicot/MB02TZ.f b/mex/sources/libslicot/MB02TZ.f new file mode 100644 index 000000000..8cc434d75 --- /dev/null +++ b/mex/sources/libslicot/MB02TZ.f @@ -0,0 +1,247 @@ + SUBROUTINE MB02TZ( NORM, N, HNORM, H, LDH, IPIV, RCOND, DWORK, + $ ZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the reciprocal of the condition number of a complex +C upper Hessenberg matrix H, in either the 1-norm or the +C infinity-norm, using the LU factorization computed by MB02SZ. +C +C ARGUMENTS +C +C Mode Parameters +C +C NORM CHARACTER*1 +C Specifies whether the 1-norm condition number or the +C infinity-norm condition number is required: +C = '1' or 'O': 1-norm; +C = 'I': Infinity-norm. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix H. N >= 0. +C +C HNORM (input) DOUBLE PRECISION +C If NORM = '1' or 'O', the 1-norm of the original matrix H. +C If NORM = 'I', the infinity-norm of the original matrix H. +C +C H (input) COMPLEX*16 array, dimension (LDH,N) +C The factors L and U from the factorization H = P*L*U +C as computed by MB02SZ. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C IPIV (input) INTEGER array, dimension (N) +C The pivot indices; for 1 <= i <= N, row i of the matrix +C was interchanged with row IPIV(i). +C +C RCOND (output) DOUBLE PRECISION +C The reciprocal of the condition number of the matrix H, +C computed as RCOND = 1/(norm(H) * norm(inv(H))). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C ZWORK COMPLEX*16 array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C An estimate is obtained for norm(inv(H)), and the reciprocal of +C the condition number is computed as +C RCOND = 1 / ( norm(H) * norm(inv(H)) ). +C +C REFERENCES +C +C - +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0( N ) complex operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TB01FY by A.J. Laub, University of +C Southern California, United States of America, May 1980. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2005. +C +C KEYWORDS +C +C Frequency response, Hessenberg form, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER NORM + INTEGER INFO, LDH, N + DOUBLE PRECISION HNORM, RCOND +C .. +C .. Array Arguments .. + INTEGER IPIV(*) + DOUBLE PRECISION DWORK( * ) + COMPLEX*16 H( LDH, * ), ZWORK( * ) +C .. Local Scalars .. + LOGICAL ONENRM + CHARACTER NORMIN + INTEGER IX, J, JP, KASE, KASE1 +C + DOUBLE PRECISION HINVNM, SCALE, SMLNUM + COMPLEX*16 T, ZDUM +C .. +C .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, IZAMAX, LSAME +C .. +C .. External Subroutines .. + EXTERNAL XERBLA, ZDRSCL, ZLACON, ZLATRS +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX +C .. +C .. Statement Functions .. + DOUBLE PRECISION CABS1 +C .. +C .. Statement Function definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +C .. +C .. Executable Statements .. +C +C Test the input parameters. +C + INFO = 0 + ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) + IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( HNORM.LT.ZERO ) THEN + INFO = -3 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02TZ', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( HNORM.EQ.ZERO ) THEN + RETURN + END IF +C + SMLNUM = DLAMCH( 'Safe minimum' ) +C +C Estimate the norm of inv(H). +C + HINVNM = ZERO + NORMIN = 'N' + IF( ONENRM ) THEN + KASE1 = 1 + ELSE + KASE1 = 2 + END IF + KASE = 0 + 10 CONTINUE + CALL ZLACON( N, ZWORK( N+1 ), ZWORK, HINVNM, KASE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.KASE1 ) THEN +C +C Multiply by inv(L). +C + DO 20 J = 1, N - 1 + JP = IPIV( J ) + T = ZWORK( JP ) + IF( JP.NE.J ) THEN + ZWORK( JP ) = ZWORK( J ) + ZWORK( J ) = T + END IF + ZWORK( J+1 ) = ZWORK( J+1 ) - T * H( J+1, J ) + 20 CONTINUE +C +C Multiply by inv(U). +C + CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, + $ H, LDH, ZWORK, SCALE, DWORK, INFO ) + ELSE +C +C Multiply by inv(U'). +C + CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit', + $ NORMIN, N, H, LDH, ZWORK, SCALE, DWORK, INFO ) +C +C Multiply by inv(L'). +C + DO 30 J = N - 1, 1, -1 + ZWORK( J ) = ZWORK( J ) - + $ DCONJG( H( J+1, J ) ) * ZWORK( J+1 ) + JP = IPIV( J ) + IF( JP.NE.J ) THEN + T = ZWORK( JP ) + ZWORK( JP ) = ZWORK( J ) + ZWORK( J ) = T + END IF + 30 CONTINUE + END IF +C +C Divide X by 1/SCALE if doing so will not cause overflow. +C + NORMIN = 'Y' + IF( SCALE.NE.ONE ) THEN + IX = IZAMAX( N, ZWORK, 1 ) + IF( SCALE.LT.CABS1( ZWORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO + $ ) GO TO 40 + CALL ZDRSCL( N, SCALE, ZWORK, 1 ) + END IF + GO TO 10 + END IF +C +C Compute the estimate of the reciprocal condition number. +C + IF( HINVNM.NE.ZERO ) + $ RCOND = ( ONE / HINVNM ) / HNORM +C + 40 CONTINUE + RETURN +C *** Last line of MB02TZ *** + END diff --git a/mex/sources/libslicot/MB02UD.f b/mex/sources/libslicot/MB02UD.f new file mode 100644 index 000000000..101c7426e --- /dev/null +++ b/mex/sources/libslicot/MB02UD.f @@ -0,0 +1,624 @@ + SUBROUTINE MB02UD( FACT, SIDE, TRANS, JOBP, M, N, ALPHA, RCOND, + $ RANK, R, LDR, Q, LDQ, SV, B, LDB, RP, LDRP, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the minimum norm least squares solution of one of the +C following linear systems +C +C op(R)*X = alpha*B, (1) +C X*op(R) = alpha*B, (2) +C +C where alpha is a real scalar, op(R) is either R or its transpose, +C R', R is an L-by-L real upper triangular matrix, B is an M-by-N +C real matrix, and L = M for (1), or L = N for (2). Singular value +C decomposition, R = Q*S*P', is used, assuming that R is rank +C deficient. +C +C ARGUMENTS +C +C Mode Parameters +C +C FACT CHARACTER*1 +C Specifies whether R has been previously factored or not, +C as follows: +C = 'F': R has been factored and its rank and singular +C value decomposition, R = Q*S*P', are available; +C = 'N': R has not been factored and its singular value +C decomposition, R = Q*S*P', should be computed. +C +C SIDE CHARACTER*1 +C Specifies whether op(R) appears on the left or right +C of X as follows: +C = 'L': Solve op(R)*X = alpha*B (op(R) is on the left); +C = 'R': Solve X*op(R) = alpha*B (op(R) is on the right). +C +C TRANS CHARACTER*1 +C Specifies the form of op(R) to be used as follows: +C = 'N': op(R) = R; +C = 'T': op(R) = R'; +C = 'C': op(R) = R'. +C +C JOBP CHARACTER*1 +C Specifies whether or not the pseudoinverse of R is to be +C computed or it is available as follows: +C = 'P': Compute pinv(R), if FACT = 'N', or +C use pinv(R), if FACT = 'F'; +C = 'N': Do not compute or use pinv(R). +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix B. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix B. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then B need not be +C set before entry. +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of R. +C Singular values of R satisfying Sv(i) <= RCOND*Sv(1) are +C treated as zero. If RCOND <= 0, then EPS is used instead, +C where EPS is the relative machine precision (see LAPACK +C Library routine DLAMCH). RCOND <= 1. +C RCOND is not used if FACT = 'F'. +C +C RANK (input or output) INTEGER +C The rank of matrix R. +C RANK is an input parameter when FACT = 'F', and an output +C parameter when FACT = 'N'. L >= RANK >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,L) +C On entry, if FACT = 'F', the leading L-by-L part of this +C array must contain the L-by-L orthogonal matrix P' from +C singular value decomposition, R = Q*S*P', of the matrix R; +C if JOBP = 'P', the first RANK rows of P' are assumed to be +C scaled by inv(S(1:RANK,1:RANK)). +C On entry, if FACT = 'N', the leading L-by-L upper +C triangular part of this array must contain the upper +C triangular matrix R. +C On exit, if INFO = 0, the leading L-by-L part of this +C array contains the L-by-L orthogonal matrix P', with its +C first RANK rows scaled by inv(S(1:RANK,1:RANK)), when +C JOBP = 'P'. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,L). +C +C Q (input or output) DOUBLE PRECISION array, dimension +C (LDQ,L) +C On entry, if FACT = 'F', the leading L-by-L part of this +C array must contain the L-by-L orthogonal matrix Q from +C singular value decomposition, R = Q*S*P', of the matrix R. +C If FACT = 'N', this array need not be set on entry, and +C on exit, if INFO = 0, the leading L-by-L part of this +C array contains the orthogonal matrix Q. +C +C LDQ INTEGER +C The leading dimension of array Q. LDQ >= MAX(1,L). +C +C SV (input or output) DOUBLE PRECISION array, dimension (L) +C On entry, if FACT = 'F', the first RANK entries of this +C array must contain the reciprocal of the largest RANK +C singular values of the matrix R, and the last L-RANK +C entries of this array must contain the remaining singular +C values of R sorted in descending order. +C If FACT = 'N', this array need not be set on input, and +C on exit, if INFO = 0, the first RANK entries of this array +C contain the reciprocal of the largest RANK singular values +C of the matrix R, and the last L-RANK entries of this array +C contain the remaining singular values of R sorted in +C descending order. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, if ALPHA <> 0, the leading M-by-N part of this +C array must contain the matrix B. +C On exit, if INFO = 0 and RANK > 0, the leading M-by-N part +C of this array contains the M-by-N solution matrix X. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C RP (input or output) DOUBLE PRECISION array, dimension +C (LDRP,L) +C On entry, if FACT = 'F', JOBP = 'P', and RANK > 0, the +C leading L-by-L part of this array must contain the L-by-L +C matrix pinv(R), the Moore-Penrose pseudoinverse of R. +C On exit, if FACT = 'N', JOBP = 'P', and RANK > 0, the +C leading L-by-L part of this array contains the L-by-L +C matrix pinv(R), the Moore-Penrose pseudoinverse of R. +C If JOBP = 'N', this array is not referenced. +C +C LDRP INTEGER +C The leading dimension of array RP. +C LDRP >= MAX(1,L), if JOBP = 'P'. +C LDRP >= 1, if JOBP = 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK; +C if INFO = i, 1 <= i <= L, then DWORK(2:L) contain the +C unconverged superdiagonal elements of an upper bidiagonal +C matrix D whose diagonal is in SV (not necessarily sorted). +C D satisfies R = Q*D*P', so it has the same singular +C values as R, and singular vectors related by Q and P'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,L), if FACT = 'F'; +C LDWORK >= MAX(1,5*L), if FACT = 'N'. +C For optimum performance LDWORK should be larger than +C MAX(1,L,M*N), if FACT = 'F'; +C MAX(1,5*L,M*N), if FACT = 'N'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, i = 1:L, the SVD algorithm has failed +C to converge. In this case INFO specifies how many +C superdiagonals did not converge (see the description +C of DWORK); this failure is not likely to occur. +C +C METHOD +C +C The L-by-L upper triangular matrix R is factored as R = Q*S*P', +C if FACT = 'N', using SLICOT Library routine MB03UD, where Q and P +C are L-by-L orthogonal matrices and S is an L-by-L diagonal matrix +C with non-negative diagonal elements, SV(1), SV(2), ..., SV(L), +C ordered decreasingly. Then, the effective rank of R is estimated, +C and matrix (or matrix-vector) products and scalings are used to +C compute X. If FACT = 'F', only matrix (or matrix-vector) products +C and scalings are performed. +C +C FURTHER COMMENTS +C +C Option JOBP = 'P' should be used only if the pseudoinverse is +C really needed. Usually, it is possible to avoid the use of +C pseudoinverse, by computing least squares solutions. +C The routine uses BLAS 3 calculations if LDWORK >= M*N, and BLAS 2 +C calculations, otherwise. No advantage of any additional workspace +C larger than L is taken for matrix products, but the routine can +C be called repeatedly for chunks of columns of B, if LDWORK < M*N. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute of Informatics, Bucharest, Oct. 1999. +C +C REVISIONS +C +C V. Sima, Feb. 2000. +C +C KEYWORDS +C +C Bidiagonalization, orthogonal transformation, singular value +C decomposition, singular values, triangular form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER FACT, JOBP, SIDE, TRANS + INTEGER INFO, LDB, LDQ, LDR, LDRP, LDWORK, M, N, RANK + DOUBLE PRECISION ALPHA, RCOND +C .. Array Arguments .. + DOUBLE PRECISION B(LDB,*), DWORK(*), Q(LDQ,*), R(LDR,*), + $ RP(LDRP,*), SV(*) +C .. Local Scalars .. + LOGICAL LEFT, NFCT, PINV, TRAN + CHARACTER*1 NTRAN + INTEGER I, L, MAXWRK, MINWRK, MN + DOUBLE PRECISION TOLL +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLACPY, DLASET, MB01SD, + $ MB03UD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C +C Check the input scalar arguments. +C + INFO = 0 + NFCT = LSAME( FACT, 'N' ) + LEFT = LSAME( SIDE, 'L' ) + PINV = LSAME( JOBP, 'P' ) + TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) + IF( LEFT ) THEN + L = M + ELSE + L = N + END IF + MN = M*N + IF( .NOT.NFCT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -2 + ELSE IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN + INFO = -3 + ELSE IF( .NOT.PINV .AND. .NOT.LSAME( JOBP, 'N' ) ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( NFCT .AND. RCOND.GT.ONE ) THEN + INFO = -8 + ELSE IF( .NOT.NFCT .AND. ( RANK.LT.ZERO .OR. RANK.GT.L ) ) THEN + INFO = -9 + ELSE IF( LDR.LT.MAX( 1, L ) ) THEN + INFO = -11 + ELSE IF( LDQ.LT.MAX( 1, L ) ) THEN + INFO = -13 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -16 + ELSE IF( LDRP.LT.1 .OR. ( PINV .AND. LDRP.LT.L ) ) THEN + INFO = -18 + END IF +C +C Compute workspace +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately following +C subroutine, as returned by ILAENV.) +C + MINWRK = 1 + IF( INFO.EQ.0 .AND. LDWORK.GE.1 .AND. L.GT.0 ) THEN + MINWRK = MAX( 1, L ) + MAXWRK = MAX( MINWRK, MN ) + IF( NFCT ) THEN + MAXWRK = MAX( MAXWRK, 3*L+2*L* + $ ILAENV( 1, 'DGEBRD', ' ', L, L, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*L+L* + $ ILAENV( 1, 'DORGBR', 'Q', L, L, L, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*L+L* + $ ILAENV( 1, 'DORGBR', 'P', L, L, L, -1 ) ) + MINWRK = MAX( 1, 5*L ) + MAXWRK = MAX( MAXWRK, MINWRK ) + END IF + END IF +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -20 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02UD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( L.EQ.0 ) THEN + IF( NFCT ) + $ RANK = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( NFCT ) THEN +C +C Compute the SVD of R, R = Q*S*P'. +C Matrix Q is computed in the array Q, and P' overwrites R. +C Workspace: need 5*L; +C prefer larger. +C + CALL MB03UD( 'Vectors', 'Vectors', L, R, LDR, Q, LDQ, SV, + $ DWORK, LDWORK, INFO ) + IF ( INFO.NE.0 ) + $ RETURN +C +C Use the default tolerance, if required. +C + TOLL = RCOND + IF( TOLL.LE.ZERO ) + $ TOLL = DLAMCH( 'Precision' ) + TOLL = MAX( TOLL*SV(1), DLAMCH( 'Safe minimum' ) ) +C +C Estimate the rank of R. +C + DO 10 I = 1, L + IF ( TOLL.GT.SV(I) ) + $ GO TO 20 + 10 CONTINUE +C + I = L + 1 + 20 CONTINUE + RANK = I - 1 +C + DO 30 I = 1, RANK + SV(I) = ONE / SV(I) + 30 CONTINUE +C + IF( PINV .AND. RANK.GT.0 ) THEN +C +C Compute pinv(S)'*P' in R. +C + CALL MB01SD( 'Row scaling', RANK, L, R, LDR, SV, SV ) +C +C Compute pinv(R) = P*pinv(S)*Q' in RP. +C + CALL DGEMM( 'Transpose', 'Transpose', L, L, RANK, ONE, R, + $ LDR, Q, LDQ, ZERO, RP, LDRP ) + END IF + END IF +C +C Return if min(M,N) = 0 or RANK = 0. +C + IF( MIN( M, N ).EQ.0 .OR. RANK.EQ.0 ) THEN + DWORK(1) = MAXWRK + RETURN + END IF +C +C Set X = 0 if alpha = 0. +C + IF( ALPHA.EQ.ZERO ) THEN + CALL DLASET( 'Full', M, N, ZERO, ZERO, B, LDB ) + DWORK(1) = MAXWRK + RETURN + END IF +C + IF( PINV ) THEN +C + IF( LEFT ) THEN +C +C Compute alpha*op(pinv(R))*B in workspace and save it in B. +C Workspace: need M (BLAS 2); +C prefer M*N (BLAS 3). +C + IF( LDWORK.GE.MN ) THEN + CALL DGEMM( TRANS, 'NoTranspose', M, N, M, ALPHA, + $ RP, LDRP, B, LDB, ZERO, DWORK, M ) + CALL DLACPY( 'Full', M, N, DWORK, M, B, LDB ) + ELSE +C + DO 40 I = 1, N + CALL DGEMV( TRANS, M, M, ALPHA, RP, LDRP, B(1,I), 1, + $ ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) + 40 CONTINUE +C + END IF + ELSE +C +C Compute alpha*B*op(pinv(R)) in workspace and save it in B. +C Workspace: need N (BLAS 2); +C prefer M*N (BLAS 3). +C + IF( LDWORK.GE.MN ) THEN + CALL DGEMM( 'NoTranspose', TRANS, M, N, N, ALPHA, B, LDB, + $ RP, LDRP, ZERO, DWORK, M ) + CALL DLACPY( 'Full', M, N, DWORK, M, B, LDB ) + ELSE +C + IF( TRAN ) THEN + NTRAN = 'N' + ELSE + NTRAN = 'T' + END IF +C + DO 50 I = 1, M + CALL DGEMV( NTRAN, N, N, ALPHA, RP, LDRP, B(I,1), LDB, + $ ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) + 50 CONTINUE +C + END IF + END IF +C + ELSE +C + IF( LEFT ) THEN +C +C Compute alpha*P*pinv(S)*Q'*B or alpha*Q*pinv(S)'*P'*B. +C Workspace: need M (BLAS 2); +C prefer M*N (BLAS 3). +C + IF( LDWORK.GE.MN ) THEN + IF( TRAN ) THEN +C +C Compute alpha*P'*B in workspace. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, + $ ALPHA, R, LDR, B, LDB, ZERO, DWORK, M ) +C +C Compute alpha*pinv(S)'*P'*B. +C + CALL MB01SD( 'Row scaling', RANK, N, DWORK, M, SV, + $ SV ) +C +C Compute alpha*Q*pinv(S)'*P'*B. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, RANK, + $ ONE, Q, LDQ, DWORK, M, ZERO, B, LDB ) + ELSE +C +C Compute alpha*Q'*B in workspace. +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, N, M, + $ ALPHA, Q, LDQ, B, LDB, ZERO, DWORK, M ) +C +C Compute alpha*pinv(S)*Q'*B. +C + CALL MB01SD( 'Row scaling', RANK, N, DWORK, M, SV, + $ SV ) +C +C Compute alpha*P*pinv(S)*Q'*B. +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, N, RANK, + $ ONE, R, LDR, DWORK, M, ZERO, B, LDB ) + END IF + ELSE + IF( TRAN ) THEN +C +C Compute alpha*P'*B in B using workspace. +C + DO 60 I = 1, N + CALL DGEMV( 'NoTranspose', M, M, ALPHA, R, LDR, + $ B(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) + 60 CONTINUE +C +C Compute alpha*pinv(S)'*P'*B. +C + CALL MB01SD( 'Row scaling', RANK, N, B, LDB, SV, SV ) +C +C Compute alpha*Q*pinv(S)'*P'*B in B using workspace. +C + DO 70 I = 1, N + CALL DGEMV( 'NoTranspose', M, RANK, ONE, Q, LDQ, + $ B(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) + 70 CONTINUE + ELSE +C +C Compute alpha*Q'*B in B using workspace. +C + DO 80 I = 1, N + CALL DGEMV( 'Transpose', M, M, ALPHA, Q, LDQ, + $ B(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) + 80 CONTINUE +C +C Compute alpha*pinv(S)*Q'*B. +C + CALL MB01SD( 'Row scaling', RANK, N, B, LDB, SV, SV ) +C +C Compute alpha*P*pinv(S)*Q'*B in B using workspace. +C + DO 90 I = 1, N + CALL DGEMV( 'Transpose', RANK, M, ONE, R, LDR, + $ B(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) + 90 CONTINUE + END IF + END IF + ELSE +C +C Compute alpha*B*P*pinv(S)*Q' or alpha*B*Q*pinv(S)'*P'. +C Workspace: need N (BLAS 2); +C prefer M*N (BLAS 3). +C + IF( LDWORK.GE.MN ) THEN + IF( TRAN ) THEN +C +C Compute alpha*B*Q in workspace. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N, + $ ALPHA, B, LDB, Q, LDQ, ZERO, DWORK, M ) +C +C Compute alpha*B*Q*pinv(S)'. +C + CALL MB01SD( 'Column scaling', M, RANK, DWORK, M, SV, + $ SV ) +C +C Compute alpha*B*Q*pinv(S)'*P' in B. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, RANK, + $ ONE, DWORK, M, R, LDR, ZERO, B, LDB ) + ELSE +C +C Compute alpha*B*P in workspace. +C + CALL DGEMM( 'NoTranspose', 'Transpose', M, N, N, + $ ALPHA, B, LDB, R, LDR, ZERO, DWORK, M ) +C +C Compute alpha*B*P*pinv(S). +C + CALL MB01SD( 'Column scaling', M, RANK, DWORK, M, SV, + $ SV ) +C +C Compute alpha*B*P*pinv(S)*Q' in B. +C + CALL DGEMM( 'NoTranspose', 'Transpose', M, N, RANK, + $ ONE, DWORK, M, Q, LDQ, ZERO, B, LDB ) + END IF + ELSE + IF( TRAN ) THEN +C +C Compute alpha*B*Q in B using workspace. +C + DO 100 I = 1, M + CALL DGEMV( 'Transpose', N, N, ALPHA, Q, LDQ, + $ B(I,1), LDB, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) + 100 CONTINUE +C +C Compute alpha*B*Q*pinv(S)'. +C + CALL MB01SD( 'Column scaling', M, RANK, B, LDB, SV, + $ SV ) +C +C Compute alpha*B*Q*pinv(S)'*P' in B using workspace. +C + DO 110 I = 1, M + CALL DGEMV( 'Transpose', RANK, N, ONE, R, LDR, + $ B(I,1), LDB, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) + 110 CONTINUE +C + ELSE +C +C Compute alpha*B*P in B using workspace. +C + DO 120 I = 1, M + CALL DGEMV( 'NoTranspose', N, N, ALPHA, R, LDR, + $ B(I,1), LDB, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) + 120 CONTINUE +C +C Compute alpha*B*P*pinv(S). +C + CALL MB01SD( 'Column scaling', M, RANK, B, LDB, SV, + $ SV ) +C +C Compute alpha*B*P*pinv(S)*Q' in B using workspace. +C + DO 130 I = 1, M + CALL DGEMV( 'NoTranspose', N, RANK, ONE, Q, LDQ, + $ B(I,1), LDB, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) + 130 CONTINUE + END IF + END IF + END IF + END IF +C +C Return optimal workspace in DWORK(1). +C + DWORK(1) = MAXWRK +C + RETURN +C *** Last line of MB02UD *** + END diff --git a/mex/sources/libslicot/MB02UU.f b/mex/sources/libslicot/MB02UU.f new file mode 100644 index 000000000..649cc5139 --- /dev/null +++ b/mex/sources/libslicot/MB02UU.f @@ -0,0 +1,162 @@ + SUBROUTINE MB02UU( N, A, LDA, RHS, IPIV, JPIV, SCALE ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for x in A * x = scale * RHS, using the LU factorization +C of the N-by-N matrix A computed by SLICOT Library routine MB02UV. +C The factorization has the form A = P * L * U * Q, where P and Q +C are permutation matrices, L is unit lower triangular and U is +C upper triangular. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. +C +C A (input) DOUBLE PRECISION array, dimension (LDA, N) +C The leading N-by-N part of this array must contain +C the LU part of the factorization of the matrix A computed +C by SLICOT Library routine MB02UV: A = P * L * U * Q. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1, N). +C +C RHS (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the right hand side +C of the system. +C On exit, this array contains the solution of the system. +C +C IPIV (input) INTEGER array, dimension (N) +C The pivot indices; for 1 <= i <= N, row i of the +C matrix has been interchanged with row IPIV(i). +C +C JPIV (input) INTEGER array, dimension (N) +C The pivot indices; for 1 <= j <= N, column j of the +C matrix has been interchanged with column JPIV(j). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, chosen 0 < SCALE <= 1 to prevent +C overflow in the solution. +C +C FURTHER COMMENTS +C +C In the interest of speed, this routine does not check the input +C for errors. It should only be used if the order of the matrix A +C is very small. +C +C CONTRIBUTOR +C +C Bo Kagstrom and P. Poromaa, Univ. of Umea, Sweden, Nov. 1993. +C +C REVISIONS +C +C April 1998 (T. Penzl). +C Sep. 1998 (V. Sima). +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TWO + PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) +C .. Scalar Arguments .. + INTEGER LDA, N + DOUBLE PRECISION SCALE +C .. Array Arguments .. + INTEGER IPIV( * ), JPIV( * ) + DOUBLE PRECISION A( LDA, * ), RHS( * ) +C .. Local Scalars .. + INTEGER I, IP, J + DOUBLE PRECISION BIGNUM, EPS, FACTOR, SMLNUM, TEMP +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, IDAMAX +C .. External Subroutines .. + EXTERNAL DAXPY, DLABAD, DSCAL +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX +C .. Executable Statements .. +C +C Set constants to control owerflow. +C + EPS = DLAMCH( 'Precision' ) + SMLNUM = DLAMCH( 'Safe minimum' ) / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C +C Apply permutations IPIV to RHS. +C + DO 20 I = 1, N - 1 + IP = IPIV(I) + IF ( IP.NE.I ) THEN + TEMP = RHS(I) + RHS(I) = RHS(IP) + RHS(IP) = TEMP + ENDIF + 20 CONTINUE +C +C Solve for L part. +C + DO 40 I = 1, N - 1 + CALL DAXPY( N-I, -RHS(I), A(I+1, I), 1, RHS(I+1), 1 ) + 40 CONTINUE +C +C Solve for U part. +C +C Check for scaling. +C + FACTOR = TWO * DBLE( N ) + I = 1 + 60 CONTINUE + IF ( ( FACTOR * SMLNUM ) * ABS( RHS(I) ) .LE. ABS( A(I, I) ) ) + $ THEN + I = I + 1 + IF ( I .LE. N ) GO TO 60 + SCALE = ONE + ELSE + SCALE = ( ONE / FACTOR ) / ABS( RHS( IDAMAX( N, RHS, 1 ) ) ) + CALL DSCAL( N, SCALE, RHS, 1 ) + END IF +C + DO 100 I = N, 1, -1 + TEMP = ONE / A(I, I) + RHS(I) = RHS(I) * TEMP + DO 80 J = I + 1, N + RHS(I) = RHS(I) - RHS(J) * ( A(I, J) * TEMP ) + 80 CONTINUE + 100 CONTINUE +C +C Apply permutations JPIV to the solution (RHS). +C + DO 120 I = N - 1, 1, -1 + IP = JPIV(I) + IF ( IP.NE.I ) THEN + TEMP = RHS(I) + RHS(I) = RHS(IP) + RHS(IP) = TEMP + ENDIF + 120 CONTINUE +C + RETURN +C *** Last line of MB02UU *** + END diff --git a/mex/sources/libslicot/MB02UV.f b/mex/sources/libslicot/MB02UV.f new file mode 100644 index 000000000..61e5bbc73 --- /dev/null +++ b/mex/sources/libslicot/MB02UV.f @@ -0,0 +1,195 @@ + SUBROUTINE MB02UV( N, A, LDA, IPIV, JPIV, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute an LU factorization, using complete pivoting, of the +C N-by-N matrix A. The factorization has the form A = P * L * U * Q, +C where P and Q are permutation matrices, L is lower triangular with +C unit diagonal elements and U is upper triangular. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA, N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A to be factored. +C On exit, the leading N-by-N part of this array contains +C the factors L and U from the factorization A = P*L*U*Q; +C the unit diagonal elements of L are not stored. If U(k, k) +C appears to be less than SMIN, U(k, k) is given the value +C of SMIN, giving a nonsingular perturbed system. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1, N). +C +C IPIV (output) INTEGER array, dimension (N) +C The pivot indices; for 1 <= i <= N, row i of the +C matrix has been interchanged with row IPIV(i). +C +C JPIV (output) INTEGER array, dimension (N) +C The pivot indices; for 1 <= j <= N, column j of the +C matrix has been interchanged with column JPIV(j). +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C = k: U(k, k) is likely to produce owerflow if one tries +C to solve for x in Ax = b. So U is perturbed to get +C a nonsingular system. This is a warning. +C +C FURTHER COMMENTS +C +C In the interests of speed, this routine does not check the input +C for errors. It should only be used to factorize matrices A of +C very small order. +C +C CONTRIBUTOR +C +C Bo Kagstrom and Peter Poromaa, Univ. of Umea, Sweden, Nov. 1993. +C +C REVISIONS +C +C April 1998 (T. Penzl). +C Sep. 1998 (V. Sima). +C March 1999 (V. Sima). +C March 2004 (V. Sima). +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, N +C .. Array Arguments .. + INTEGER IPIV( * ), JPIV( * ) + DOUBLE PRECISION A( LDA, * ) +C .. Local Scalars .. + INTEGER I, IP, IPV, JP, JPV + DOUBLE PRECISION BIGNUM, EPS, SMIN, SMLNUM, XMAX +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. External Subroutines .. + EXTERNAL DGER, DLABAD, DSCAL, DSWAP +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. Executable Statements .. +C +C Set constants to control owerflow. + + INFO = 0 + EPS = DLAMCH( 'Precision' ) + SMLNUM = DLAMCH( 'Safe minimum' ) / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C +C Find max element in matrix A. +C + IPV = 1 + JPV = 1 + XMAX = ZERO + DO 40 JP = 1, N + DO 20 IP = 1, N + IF ( ABS( A(IP, JP) ) .GT. XMAX ) THEN + XMAX = ABS( A(IP, JP) ) + IPV = IP + JPV = JP + ENDIF + 20 CONTINUE + 40 CONTINUE + SMIN = MAX( EPS * XMAX, SMLNUM ) +C +C Swap rows. +C + IF ( IPV .NE. 1 ) CALL DSWAP( N, A(IPV, 1), LDA, A(1, 1), LDA ) + IPIV(1) = IPV +C +C Swap columns. +C + IF ( JPV .NE. 1 ) CALL DSWAP( N, A(1, JPV), 1, A(1, 1), 1 ) + JPIV(1) = JPV +C +C Check for singularity. +C + IF ( ABS( A(1, 1) ) .LT. SMIN ) THEN + INFO = 1 + A(1, 1) = SMIN + ENDIF + IF ( N.GT.1 ) THEN + CALL DSCAL( N - 1, ONE / A(1, 1), A(2, 1), 1 ) + CALL DGER( N - 1, N - 1, -ONE, A(2, 1), 1, A(1, 2), LDA, + $ A(2, 2), LDA ) + ENDIF +C +C Factorize the rest of A with complete pivoting. +C Set pivots less than SMIN to SMIN. +C + DO 100 I = 2, N - 1 +C +C Find max element in remaining matrix. +C + IPV = I + JPV = I + XMAX = ZERO + DO 80 JP = I, N + DO 60 IP = I, N + IF ( ABS( A(IP, JP) ) .GT. XMAX ) THEN + XMAX = ABS( A(IP, JP) ) + IPV = IP + JPV = JP + ENDIF + 60 CONTINUE + 80 CONTINUE +C +C Swap rows. +C + IF ( IPV .NE. I ) CALL DSWAP( N, A(IPV, 1), LDA, A(I, 1), LDA ) + IPIV(I) = IPV +C +C Swap columns. +C + IF ( JPV .NE. I ) CALL DSWAP( N, A(1, JPV), 1, A(1, I), 1 ) + JPIV(I) = JPV +C +C Check for almost singularity. +C + IF ( ABS( A(I, I) ) .LT. SMIN ) THEN + INFO = I + A(I, I) = SMIN + ENDIF + CALL DSCAL( N - I, ONE / A(I, I), A(I + 1, I), 1 ) + CALL DGER( N - I, N - I, -ONE, A(I + 1, I), 1, A(I, I + 1), + $ LDA, A(I + 1, I + 1), LDA ) + 100 CONTINUE + IF ( ABS( A(N, N) ) .LT. SMIN ) THEN + INFO = N + A(N, N) = SMIN + ENDIF +C + RETURN +C *** Last line of MB02UV *** + END diff --git a/mex/sources/libslicot/MB02VD.f b/mex/sources/libslicot/MB02VD.f new file mode 100644 index 000000000..5896d2349 --- /dev/null +++ b/mex/sources/libslicot/MB02VD.f @@ -0,0 +1,187 @@ + SUBROUTINE MB02VD( TRANS, M, N, A, LDA, IPIV, B, LDB, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the solution to a real system of linear equations +C X * op(A) = B, +C where op(A) is either A or its transpose, A is an N-by-N matrix, +C and X and B are M-by-N matrices. +C The LU decomposition with partial pivoting and row interchanges, +C A = P * L * U, is used, where P is a permutation matrix, L is unit +C lower triangular, and U is upper triangular. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANS CHARACTER*1 +C Specifies the form of op(A) to be used as follows: +C = 'N': op(A) = A; +C = 'T': op(A) = A'; +C = 'C': op(A) = A'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix B. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix B, and the order of +C the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the coefficient matrix A. +C On exit, the leading N-by-N part of this array contains +C the factors L and U from the factorization A = P*L*U; +C the unit diagonal elements of L are not stored. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C IPIV (output) INTEGER array, dimension (N) +C The pivot indices that define the permutation matrix P; +C row i of the matrix was interchanged with row IPIV(i). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading M-by-N part of this array must +C contain the right hand side matrix B. +C On exit, if INFO = 0, the leading M-by-N part of this +C array contains the solution matrix X. +C +C LDB (input) INTEGER +C The leading dimension of the array B. LDB >= max(1,M). +C +C INFO (output) INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, U(i,i) is exactly zero. The +C factorization has been completed, but the factor U +C is exactly singular, so the solution could not be +C computed. +C +C METHOD +C +C The LU decomposition with partial pivoting and row interchanges is +C used to factor A as +C A = P * L * U, +C where P is a permutation matrix, L is unit lower triangular, and +C U is upper triangular. The factored form of A is then used to +C solve the system of equations X * A = B or X * A' = B. +C +C FURTHER COMMENTS +C +C This routine enables to solve the system X * A = B or X * A' = B +C as easily and efficiently as possible; it is similar to the LAPACK +C Library routine DGESV, which solves A * X = B. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, linear algebra. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, M, N +C .. +C .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +C .. +C .. Local Scalars .. + LOGICAL TRAN +C .. +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. +C .. External Subroutines .. + EXTERNAL DGETRF, DTRSM, MA02GD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C +C Test the scalar input parameters. +C + INFO = 0 + TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -8 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02VD', -INFO ) + RETURN + END IF +C +C Compute the LU factorization of A. +C + CALL DGETRF( N, N, A, LDA, IPIV, INFO ) +C + IF( INFO.EQ.0 ) THEN + IF( TRAN ) THEN +C +C Compute X = B * A**(-T). +C + CALL MA02GD( M, B, LDB, 1, N, IPIV, 1 ) + CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Unit', M, N, + $ ONE, A, LDA, B, LDB ) + CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', M, + $ N, ONE, A, LDA, B, LDB ) + ELSE +C +C Compute X = B * A**(-1). +C + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', M, + $ N, ONE, A, LDA, B, LDB ) + CALL DTRSM( 'Right', 'Lower', 'NoTranspose', 'Unit', M, N, + $ ONE, A, LDA, B, LDB ) + CALL MA02GD( M, B, LDB, 1, N, IPIV, -1 ) + END IF + END IF + RETURN +C +C *** Last line of MB02VD *** + END diff --git a/mex/sources/libslicot/MB02WD.f b/mex/sources/libslicot/MB02WD.f new file mode 100644 index 000000000..59816e037 --- /dev/null +++ b/mex/sources/libslicot/MB02WD.f @@ -0,0 +1,458 @@ + SUBROUTINE MB02WD( FORM, F, N, IPAR, LIPAR, DPAR, LDPAR, ITMAX, + $ A, LDA, B, INCB, X, INCX, TOL, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the system of linear equations Ax = b, with A symmetric, +C positive definite, or, in the implicit form, f(A, x) = b, where +C y = f(A, x) is a symmetric positive definite linear mapping +C from x to y, using the conjugate gradient (CG) algorithm without +C preconditioning. +C +C ARGUMENTS +C +C Mode Parameters +C +C FORM CHARACTER*1 +C Specifies the form of the system of equations, as +C follows: +C = 'U' : Ax = b, the upper triagular part of A is used; +C = 'L' : Ax = b, the lower triagular part of A is used; +C = 'F' : the implicit, function form, f(A, x) = b. +C +C Function Parameters +C +C F EXTERNAL +C If FORM = 'F', then F is a subroutine which calculates the +C value of f(A, x), for given A and x. +C If FORM <> 'F', then F is not called. +C +C F must have the following interface: +C +C SUBROUTINE F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, X, +C $ INCX, DWORK, LDWORK, INFO ) +C +C where +C +C N (input) INTEGER +C The dimension of the vector x. N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of +C the matrix A. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 0. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C The real parameters needed for solving the +C problem. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 0. +C +C A (input) DOUBLE PRECISION array, dimension +C (LDA, NC), where NC is the number of columns. +C The leading NR-by-NC part of this array must +C contain the (compressed) representation of the +C matrix A, where NR is the number of rows of A +C (function of IPAR entries). +C +C LDA (input) INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,NR). +C +C X (input/output) DOUBLE PRECISION array, dimension +C (1+(N-1)*INCX) +C On entry, this incremented array must contain the +C vector x. +C On exit, this incremented array contains the value +C of the function f, y = f(A, x). +C +C INCX (input) INTEGER +C The increment for the elements of X. INCX > 0. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C The workspace array for subroutine F. +C +C LDWORK (input) INTEGER +C The size of the array DWORK (as large as needed +C in the subroutine F). +C +C INFO INTEGER +C Error indicator, set to a negative value if an +C input scalar argument is erroneous, and to +C positive values for other possible errors in the +C subroutine F. The LAPACK Library routine XERBLA +C should be used in conjunction with negative INFO. +C INFO must be zero if the subroutine finished +C successfully. +C +C Parameters marked with "(input)" must not be changed. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the vector x. N >= 0. +C If FORM = 'U' or FORM = 'L', N is also the number of rows +C and columns of the matrix A. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C If FORM = 'F', the integer parameters describing the +C structure of the matrix A. +C This parameter is ignored if FORM = 'U' or FORM = 'L'. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 0. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C If FORM = 'F', the real parameters needed for solving +C the problem. +C This parameter is ignored if FORM = 'U' or FORM = 'L'. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 0. +C +C ITMAX (input) INTEGER +C The maximal number of iterations to do. ITMAX >= 0. +C +C A (input) DOUBLE PRECISION array, +C dimension (LDA, NC), if FORM = 'F', +C dimension (LDA, N), otherwise. +C If FORM = 'F', the leading NR-by-NC part of this array +C must contain the (compressed) representation of the +C matrix A, where NR and NC are the number of rows and +C columns, respectively, of the matrix A. The array A is +C not referenced by this routine itself, except in the +C calls to the routine F. +C If FORM <> 'F', the leading N-by-N part of this array +C must contain the matrix A, assumed to be symmetric; +C only the triangular part specified by FORM is referenced. +C +C LDA (input) INTEGER +C The leading dimension of array A. +C LDA >= MAX(1,NR), if FORM = 'F'; +C LDA >= MAX(1,N), if FORM = 'U' or FORM = 'L'. +C +C B (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCB) +C The incremented vector b. +C +C INCB (input) INTEGER +C The increment for the elements of B. INCB > 0. +C +C X (input/output) DOUBLE PRECISION array, dimension +C (1+(N-1)*INCX) +C On entry, this incremented array must contain an initial +C approximation of the solution. If an approximation is not +C known, setting all elements of x to zero is recommended. +C On exit, this incremented array contains the computed +C solution x of the system of linear equations. +C +C INCX (input) INTEGER +C The increment for the elements of X. INCX > 0. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If TOL > 0, absolute tolerance for the iterative process. +C The algorithm will stop if || Ax - b ||_2 <= TOL. Since +C it is advisable to use a relative tolerance, say TOLER, +C TOL should be chosen as TOLER*|| b ||_2. +C If TOL <= 0, a default relative tolerance, +C TOLDEF = N*EPS*|| b ||_2, is used, where EPS is the +C machine precision (see LAPACK Library routine DLAMCH). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the number of +C iterations performed and DWORK(2) returns the remaining +C residual, || Ax - b ||_2. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(2,3*N + DWORK(F)), if FORM = 'F', +C where DWORK(F) is the workspace needed by F; +C LDWORK >= MAX(2,3*N), if FORM = 'U' or FORM = 'L'. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: the algorithm finished after ITMAX > 0 iterations, +C without achieving the desired precision TOL; +C = 2: ITMAX is zero; in this case, DWORK(2) is not set. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, then F returned with INFO = i. +C +C METHOD +C +C The following CG iteration is used for solving Ax = b: +C +C Start: q(0) = r(0) = Ax - b +C +C < q(k), r(k) > +C ALPHA(k) = - ---------------- +C < q(k), Aq(k) > +C x(k+1) = x(k) - ALPHA(k) * q(k) +C r(k+1) = r(k) - ALPHA(k) * Aq(k) +C < r(k+1), r(k+1) > +C BETA(k) = -------------------- +C < r(k) , r(k) > +C q(k+1) = r(k+1) + BETA(k) * q(k) +C +C where <.,.> denotes the scalar product. +C +C REFERENCES +C +C [1] Golub, G.H. and van Loan, C.F. +C Matrix Computations. Third Edition. +C M. D. Johns Hopkins University Press, Baltimore, pp. 520-528, +C 1996. +C +C [2] Luenberger, G. +C Introduction to Linear and Nonlinear Programming. +C Addison-Wesley, Reading, MA, p.187, York, 1973. +C +C NUMERICAL ASPECTS +C +C Since the residuals are orthogonal in the scalar product +C = y'Ax, the algorithm is theoretically finite. But rounding +C errors cause a loss of orthogonality, so a finite termination +C cannot be guaranteed. However, one can prove [2] that +C +C || x-x_k ||_A := sqrt( (x-x_k)' * A * (x-x_k) ) +C +C sqrt( kappa_2(A) ) - 1 +C <= 2 || x-x_0 ||_A * ------------------------ , +C sqrt( kappa_2(A) ) + 1 +C +C where kappa_2 is the condition number. +C +C The approximate number of floating point operations is +C (k*(N**2 + 15*N) + N**2 + 3*N)/2, if FORM <> 'F', +C k*(f + 7*N) + f, if FORM = 'F', +C where k is the number of CG iterations performed, and f is the +C number of floating point operations required by the subroutine F. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Oct. 2000, during a stay at University of Twente, NL. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, +C March, 2002. +C +C KEYWORDS +C +C Conjugate gradients, convergence, linear system of equations, +C matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER FORM + INTEGER INCB, INCX, INFO, ITMAX, IWARN, LDA, LDPAR, + $ LDWORK, LIPAR, N + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(*), DPAR(*), DWORK(*), X(*) + INTEGER IPAR(*) +C .. Local Scalars .. + DOUBLE PRECISION ALPHA, BETA, RES, RESOLD, TOLDEF + INTEGER AQ, DWLEFT, K, R + LOGICAL MAT +C .. External Functions .. + DOUBLE PRECISION DDOT, DLAMCH, DNRM2 + LOGICAL LSAME + EXTERNAL DDOT, DLAMCH, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSCAL, DSYMV, F, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MAT = LSAME( FORM, 'U' ) .OR. LSAME( FORM, 'L' ) +C +C Check the scalar input parameters. +C + IWARN = 0 + INFO = 0 + IF( .NOT.( MAT .OR. LSAME( FORM, 'F' ) ) ) THEN + INFO = -1 + ELSEIF ( N.LT.0 ) THEN + INFO = -3 + ELSEIF ( .NOT. MAT .AND. LIPAR.LT.0 ) THEN + INFO = -5 + ELSEIF ( .NOT. MAT .AND. LDPAR.LT.0 ) THEN + INFO = -7 + ELSEIF ( ITMAX.LT.0 ) THEN + INFO = -8 + ELSEIF ( LDA.LT.1 .OR. ( MAT .AND. LDA.LT.N ) ) THEN + INFO = -10 + ELSEIF ( INCB.LE.0 ) THEN + INFO = -12 + ELSEIF ( INCX.LE.0 ) THEN + INFO = -14 + ELSEIF ( LDWORK.LT.MAX( 2, 3*N ) ) THEN + INFO = -17 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02WD', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK(1) = ZERO + DWORK(2) = ZERO + RETURN + ENDIF +C + IF ( ITMAX.EQ.0 ) THEN + DWORK(1) = ZERO + IWARN = 2 + RETURN + ENDIF +C +C Set default tolerance, if needed. +C + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) + $ TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' )*DNRM2( N, B, INCB ) +C +C Initialize local variables. +C + K = 0 +C +C Vector q is stored in DWORK(1), A*q or f(A, q) in DWORK(AQ), +C and r in DWORK(R). The workspace for F starts in DWORK(DWLEFT). +C + AQ = N + 1 + R = N + AQ + DWLEFT = N + R +C +C Prepare the first iteration, initialize r and q. +C + IF ( MAT ) THEN + CALL DCOPY( N, B, INCB, DWORK(R), 1 ) + CALL DSYMV( FORM, N, ONE, A, LDA, X, INCX, -ONE, DWORK(R), 1 ) + ELSE + CALL DCOPY( N, X, INCX, DWORK(R), 1 ) + CALL F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, DWORK(R), 1, + $ DWORK(DWLEFT), LDWORK-DWLEFT+1, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + CALL DAXPY( N, -ONE, B, INCB, DWORK(R), 1 ) + ENDIF + CALL DCOPY( N, DWORK(R), 1, DWORK, 1 ) +C + RES = DNRM2( N, DWORK(R), 1 ) +C +C Do nothing if x is already the solution. +C + IF ( RES.LE.TOLDEF ) GOTO 20 +C +C Begin of the iteration loop. +C +C WHILE ( RES.GT.TOLDEF .AND. K.LE.ITMAX ) DO + 10 CONTINUE +C +C Calculate A*q or f(A, q). +C + IF ( MAT ) THEN + CALL DSYMV( FORM, N, ONE, A, LDA, DWORK, 1, ZERO, DWORK(AQ), + $ 1 ) + ELSE + CALL DCOPY( N, DWORK, 1, DWORK(AQ), 1 ) + CALL F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, DWORK(AQ), 1, + $ DWORK(DWLEFT), LDWORK-DWLEFT+1, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + ENDIF +C +C Calculate ALPHA(k). +C + ALPHA = DDOT( N, DWORK, 1, DWORK(R), 1 ) / + $ DDOT( N, DWORK, 1, DWORK(AQ), 1 ) +C +C x(k+1) = x(k) - ALPHA(k)*q(k). +C + CALL DAXPY( N, -ALPHA, DWORK, 1, X, INCX ) +C +C r(k+1) = r(k) - ALPHA(k)*(A*q(k)). +C + CALL DAXPY( N, -ALPHA, DWORK(AQ), 1, DWORK(R), 1 ) +C +C Save RES and calculate a new RES. +C + RESOLD = RES + RES = DNRM2( N, DWORK(R), 1 ) +C +C Exit if tolerance is reached. +C + IF ( RES.LE.TOLDEF ) GOTO 20 +C +C Calculate BETA(k). +C + BETA = ( RES/RESOLD )**2 +C +C q(k+1) = r(k+1) + BETA(k)*q(k). +C + CALL DSCAL( N, BETA, DWORK, 1 ) + CALL DAXPY( N, ONE, DWORK(R), 1, DWORK, 1 ) +C +C End of the iteration loop. +C + K = K + 1 + IF ( K.LT.ITMAX ) GOTO 10 +C END WHILE 10 +C +C Tolerance was not reached! +C + IWARN = 1 +C + 20 CONTINUE +C + DWORK(1) = K + DWORK(2) = RES +C +C *** Last line of MB02WD *** + END diff --git a/mex/sources/libslicot/MB02XD.f b/mex/sources/libslicot/MB02XD.f new file mode 100644 index 000000000..0575a907a --- /dev/null +++ b/mex/sources/libslicot/MB02XD.f @@ -0,0 +1,409 @@ + SUBROUTINE MB02XD( FORM, STOR, UPLO, F, M, N, NRHS, IPAR, LIPAR, + $ DPAR, LDPAR, A, LDA, B, LDB, ATA, LDATA, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a set of systems of linear equations, A'*A*X = B, or, +C in the implicit form, f(A)*X = B, with A'*A or f(A) positive +C definite, using symmetric Gaussian elimination. +C +C ARGUMENTS +C +C Mode Parameters +C +C FORM CHARACTER*1 +C Specifies the form in which the matrix A is provided, as +C follows: +C = 'S' : standard form, the matrix A is given; +C = 'F' : the implicit, function form f(A) is provided. +C If FORM = 'F', then the routine F is called to compute the +C matrix A'*A. +C +C STOR CHARACTER*1 +C Specifies the storage scheme for the symmetric +C matrix A'*A, as follows: +C = 'F' : full storage is used; +C = 'P' : packed storage is used. +C +C UPLO CHARACTER*1 +C Specifies which part of the matrix A'*A is stored, as +C follows: +C = 'U' : the upper triagular part is stored; +C = 'L' : the lower triagular part is stored. +C +C Function Parameters +C +C F EXTERNAL +C If FORM = 'F', then F is a subroutine which calculates the +C value of f(A) = A'*A, for given A. +C If FORM = 'S', then F is not called. +C +C F must have the following interface: +C +C SUBROUTINE F( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, A, +C $ LDA, ATA, LDATA, DWORK, LDWORK, INFO ) +C +C where +C +C STOR (input) CHARACTER*1 +C Specifies the storage scheme for the symmetric +C matrix A'*A, as follows: +C = 'F' : full storage is used; +C = 'P' : packed storage is used. +C +C UPLO (input) CHARACTER*1 +C Specifies which part of the matrix A'*A is stored, +C as follows: +C = 'U' : the upper triagular part is stored; +C = 'L' : the lower triagular part is stored. +C +C N (input) INTEGER +C The order of the matrix A'*A. N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of +C the matrix A. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 0. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C The real parameters needed for solving the +C problem. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 0. +C +C A (input) DOUBLE PRECISION array, dimension +C (LDA, NC), where NC is the number of columns. +C The leading NR-by-NC part of this array must +C contain the (compressed) representation of the +C matrix A, where NR is the number of rows of A +C (function of IPAR entries). +C +C LDA (input) INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,NR). +C +C ATA (output) DOUBLE PRECISION array, +C dimension (LDATA,N), if STOR = 'F', +C dimension (N*(N+1)/2), if STOR = 'P'. +C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 +C (if STOR = 'P') part of this array contains the +C upper or lower triangle of the matrix A'*A, +C depending on UPLO = 'U', or UPLO = 'L', +C respectively, stored either as a two-dimensional, +C or one-dimensional array, depending on STOR. +C +C LDATA (input) INTEGER +C The leading dimension of the array ATA. +C LDATA >= MAX(1,N), if STOR = 'F'. +C LDATA >= 1, if STOR = 'P'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C The workspace array for subroutine F. +C +C LDWORK (input) INTEGER +C The size of the array DWORK (as large as needed +C in the subroutine F). +C +C INFO INTEGER +C Error indicator, set to a negative value if an +C input scalar argument is erroneous, and to +C positive values for other possible errors in the +C subroutine F. The LAPACK Library routine XERBLA +C should be used in conjunction with negative INFO. +C INFO must be zero if the subroutine finished +C successfully. +C +C Parameters marked with "(input)" must not be changed. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The order of the matrix A'*A, the number of columns of the +C matrix A, and the number of rows of the matrix X. N >= 0. +C +C NRHS (input) INTEGER +C The number of columns of the matrices B and X. NRHS >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C If FORM = 'F', the integer parameters describing the +C structure of the matrix A. +C This parameter is ignored if FORM = 'S'. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 0. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C If FORM = 'F', the real parameters needed for solving +C the problem. +C This parameter is ignored if FORM = 'S'. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 0. +C +C A (input) DOUBLE PRECISION array, +C dimension (LDA, N), if FORM = 'S', +C dimension (LDA, NC), if FORM = 'F', where NC is +C the number of columns. +C If FORM = 'S', the leading M-by-N part of this array +C must contain the matrix A. +C If FORM = 'F', the leading NR-by-NC part of this array +C must contain an appropriate representation of matrix A, +C where NR is the number of rows. +C If FORM = 'F', this array is not referenced by this +C routine itself, except in the call to the routine F. +C +C LDA INTEGER +C The leading dimension of array A. +C LDA >= MAX(1,M), if FORM = 'S'; +C LDA >= MAX(1,NR), if FORM = 'F'. +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB, NRHS) +C On entry, the leading N-by-NRHS part of this array must +C contain the right hand side matrix B. +C On exit, if INFO = 0 and M (or NR) is nonzero, the leading +C N-by-NRHS part of this array contains the solution X of +C the set of systems of linear equations A'*A*X = B or +C f(A)*X = B. If M (or NR) is zero, then B is unchanged. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C ATA (output) DOUBLE PRECISION array, +C dimension (LDATA,N), if STOR = 'F', +C dimension (N*(N+1)/2), if STOR = 'P'. +C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if +C STOR = 'P') part of this array contains the upper or lower +C triangular Cholesky factor of the matrix A'*A, depending +C on UPLO = 'U', or UPLO = 'L', respectively, stored either +C as a two-dimensional, or one-dimensional array, depending +C on STOR. +C +C LDATA INTEGER +C The leading dimension of the array ATA. +C LDATA >= MAX(1,N), if STOR = 'F'. +C LDATA >= 1, if STOR = 'P'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, then the (i,i) element of the +C triangular factor of the matrix A'*A is exactly +C zero (the matrix A'*A is exactly singular); +C if INFO = j > n, then F returned with INFO = j-n. +C +C METHOD +C +C The matrix A'*A is built either directly (if FORM = 'S'), or +C implicitly, by calling the routine F. Then, A'*A is Cholesky +C factored and its factor is used to solve the set of systems of +C linear equations, A'*A*X = B. +C +C REFERENCES +C +C [1] Golub, G.H. and van Loan, C.F. +C Matrix Computations. Third Edition. +C M. D. Johns Hopkins University Press, Baltimore, 1996. +C +C [2] Anderson, E., Bai, Z., Bischof, C., Blackford, Demmel, J., +C Dongarra, J., Du Croz, J., Greenbaum, A., Hammarling, S., +C McKenney, A., Sorensen, D. +C LAPACK Users' Guide: Third Edition, SIAM, Philadelphia, 1999. +C +C NUMERICAL ASPECTS +C +C For speed, this routine does not check for near singularity of the +C matrix A'*A. If the matrix A is nearly rank deficient, then the +C computed X could be inaccurate. Estimates of the reciprocal +C condition numbers of the matrices A and A'*A can be obtained +C using LAPACK routines DGECON and DPOCON (DPPCON), respectively. +C +C The approximate number of floating point operations is +C (M+3)*N**2/2 + N**3/6 + NRHS*N**2, if FORM = 'S', +C f + N**3/6 + NRHS*N**2, if FORM = 'F', +C where M is the number of rows of A, and f is the number of +C floating point operations required by the subroutine F. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. +C +C REVISIONS +C +C V. Sima, Mar. 2002. +C +C KEYWORDS +C +C Linear system of equations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER FORM, STOR, UPLO + INTEGER INFO, LDA, LDATA, LDB, LDPAR, LDWORK, LIPAR, M, + $ N, NRHS +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ATA(*), B(LDB,*), DPAR(*), DWORK(*) + INTEGER IPAR(*) +C .. Local Scalars .. + INTEGER IERR, J, J1 + LOGICAL FULL, MAT, UPPER +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEMV, DPOTRF, DPOTRS, DPPTRF, DPPTRS, DSYRK, F, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MAT = LSAME( FORM, 'S' ) + FULL = LSAME( STOR, 'F' ) + UPPER = LSAME( UPLO, 'U' ) +C +C Check the scalar input parameters. +C + INFO = 0 + IF( .NOT.( MAT .OR. LSAME( FORM, 'F' ) ) ) THEN + INFO = -1 + ELSEIF ( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN + INFO = -2 + ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -3 + ELSEIF ( M.LT.0 ) THEN + INFO = -5 + ELSEIF ( N.LT.0 ) THEN + INFO = -6 + ELSEIF ( NRHS.LT.0 ) THEN + INFO = -7 + ELSEIF ( .NOT. MAT .AND. LIPAR.LT.0 ) THEN + INFO = -9 + ELSEIF ( .NOT. MAT .AND. LDPAR.LT.0 ) THEN + INFO = -11 + ELSEIF ( LDA.LT.1 .OR. ( MAT .AND. LDA.LT.M ) ) THEN + INFO = -13 + ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSEIF ( LDATA.LT.1 .OR. ( FULL .AND. LDATA.LT.N ) ) THEN + INFO = -17 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02XD', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. ( MAT .AND. M.EQ.0 ) ) + $ RETURN +C +C Build a triangle of the matrix A'*A. +C + IF ( MAT ) THEN +C +C Matrix A is given in the usual form. +C + IF ( FULL ) THEN + CALL DSYRK( UPLO, 'Transpose', N, M, ONE, A, LDA, ZERO, + $ ATA, LDATA ) + ELSEIF ( UPPER ) THEN + J1 = 1 +C + DO 10 J = 1, N + CALL DGEMV( 'Transpose', M, J, ONE, A, LDA, A(1,J), 1, + $ ZERO, ATA(J1), 1 ) + J1 = J1 + J + 10 CONTINUE +C + ELSE + J1 = 1 +C + DO 20 J = 1, N + CALL DGEMV( 'Transpose', M, N-J+1, ONE, A(1,J), LDA, + $ A(1,J), 1, ZERO, ATA(J1), 1 ) + J1 = J1 + N - J + 1 + 20 CONTINUE +C + ENDIF +C + ELSE +C +C Implicit form, A'*A = f(A). +C + CALL F( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, ATA, + $ LDATA, DWORK, LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = N + IERR + RETURN + ENDIF +C + ENDIF +C +C Factor the matrix A'*A. +C + IF ( FULL ) THEN + CALL DPOTRF( UPLO, N, ATA, LDATA, IERR ) + ELSE + CALL DPPTRF( UPLO, N, ATA, IERR ) + ENDIF +C + IF ( IERR.NE.0 ) THEN + INFO = IERR + RETURN + ENDIF +C +C Solve the set of linear systems. +C + IF ( FULL ) THEN + CALL DPOTRS( UPLO, N, NRHS, ATA, LDATA, B, LDB, IERR ) + ELSE + CALL DPPTRS( UPLO, N, NRHS, ATA, B, LDB, IERR ) + ENDIF +C +C *** Last line of MB02XD *** + END diff --git a/mex/sources/libslicot/MB02YD.f b/mex/sources/libslicot/MB02YD.f new file mode 100644 index 000000000..981af1f03 --- /dev/null +++ b/mex/sources/libslicot/MB02YD.f @@ -0,0 +1,371 @@ + SUBROUTINE MB02YD( COND, N, R, LDR, IPVT, DIAG, QTB, RANK, X, TOL, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine a vector x which solves the system of linear +C equations +C +C A*x = b , D*x = 0 , +C +C in the least squares sense, where A is an m-by-n matrix, +C D is an n-by-n diagonal matrix, and b is an m-vector. +C It is assumed that a QR factorization, with column pivoting, of A +C is available, that is, A*P = Q*R, where P is a permutation matrix, +C Q has orthogonal columns, and R is an upper triangular matrix +C with diagonal elements of nonincreasing magnitude. +C The routine needs the full upper triangle of R, the permutation +C matrix P, and the first n components of Q'*b (' denotes the +C transpose). The system A*x = b, D*x = 0, is then equivalent to +C +C R*z = Q'*b , P'*D*P*z = 0 , (1) +C +C where x = P*z. If this system does not have full rank, then a +C least squares solution is obtained. On output, MB02YD also +C provides an upper triangular matrix S such that +C +C P'*(A'*A + D*D)*P = S'*S . +C +C The system (1) is equivalent to S*z = c , where c contains the +C first n components of the vector obtained by applying to +C [ (Q'*b)' 0 ]' the transformations which triangularized +C [ R' P'*D*P ]', getting S. +C +C ARGUMENTS +C +C Mode Parameters +C +C COND CHARACTER*1 +C Specifies whether the condition of the matrix S should be +C estimated, as follows: +C = 'E' : use incremental condition estimation and store +C the numerical rank of S in RANK; +C = 'N' : do not use condition estimation, but check the +C diagonal entries of S for zero values; +C = 'U' : use the rank already stored in RANK. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix R. N >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR, N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix R. +C On exit, the full upper triangle is unaltered, and the +C strict lower triangle contains the strict upper triangle +C (transposed) of the upper triangular matrix S. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C IPVT (input) INTEGER array, dimension (N) +C This array must define the permutation matrix P such that +C A*P = Q*R. Column j of P is column IPVT(j) of the identity +C matrix. +C +C DIAG (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the diagonal elements of the +C matrix D. +C +C QTB (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the first n elements of the +C vector Q'*b. +C +C RANK (input or output) INTEGER +C On entry, if COND = 'U', this parameter must contain the +C (numerical) rank of the matrix S. +C On exit, if COND = 'E' or 'N', this parameter contains +C the numerical rank of the matrix S, estimated according +C to the value of COND. +C +C X (output) DOUBLE PRECISION array, dimension (N) +C This array contains the least squares solution of the +C system A*x = b, D*x = 0. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If COND = 'E', the tolerance to be used for finding the +C rank of the matrix S. If the user sets TOL > 0, then the +C given value of TOL is used as a lower bound for the +C reciprocal condition number; a (sub)matrix whose +C estimated condition number is less than 1/TOL is +C considered to be of full rank. If the user sets TOL <= 0, +C then an implicitly computed, default tolerance, defined by +C TOLDEF = N*EPS, is used instead, where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C This parameter is not relevant if COND = 'U' or 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, the first N elements of this array contain the +C diagonal elements of the upper triangular matrix S, and +C the next N elements contain the solution z. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 4*N, if COND = 'E'; +C LDWORK >= 2*N, if COND <> 'E'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Standard plane rotations are used to annihilate the elements of +C the diagonal matrix D, updating the upper triangular matrix R +C and the first n elements of the vector Q'*b. A basic least squares +C solution is computed. +C +C REFERENCES +C +C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. +C User's Guide for MINPACK-1. +C Applied Math. Division, Argonne National Laboratory, Argonne, +C Illinois, Report ANL-80-74, 1980. +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C This routine is a LAPACK-based modification of QRSOLV from the +C MINPACK package [1], and with optional condition estimation. +C The option COND = 'U' is useful when dealing with several +C right-hand side vectors. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. +C +C KEYWORDS +C +C Linear system of equations, matrix operations, plane rotations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, SVLMAX + PARAMETER ( ZERO = 0.0D0, SVLMAX = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER COND + INTEGER INFO, LDR, LDWORK, N, RANK + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IPVT(*) + DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), X(*) +C .. Local Scalars .. + DOUBLE PRECISION CS, QTBPJ, SN, TEMP, TOLDEF + INTEGER I, J, K, L + LOGICAL ECOND, NCOND, UCOND +C .. Local Arrays .. + DOUBLE PRECISION DUM(3) +C .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARTG, DROT, DSWAP, MB03OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + ECOND = LSAME( COND, 'E' ) + NCOND = LSAME( COND, 'N' ) + UCOND = LSAME( COND, 'U' ) + INFO = 0 + IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN + INFO = -1 + ELSEIF( N.LT.0 ) THEN + INFO = -2 + ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSEIF ( UCOND .AND. ( RANK.LT.0 .OR. RANK.GT.N ) ) THEN + INFO = -8 + ELSEIF ( LDWORK.LT.2*N .OR. ( ECOND .AND. LDWORK.LT.4*N ) ) THEN + INFO = -12 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02YD', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + IF ( .NOT.UCOND ) + $ RANK = 0 + RETURN + END IF +C +C Copy R and Q'*b to preserve input and initialize S. +C In particular, save the diagonal elements of R in X. +C + DO 20 J = 1, N + X(J) = R(J,J) + DO 10 I = J, N + R(I,J) = R(J,I) + 10 CONTINUE + 20 CONTINUE +C + CALL DCOPY( N, QTB, 1, DWORK(N+1), 1 ) +C +C Eliminate the diagonal matrix D using Givens rotations. +C + DO 50 J = 1, N +C +C Prepare the row of D to be eliminated, locating the +C diagonal element using P from the QR factorization. +C + L = IPVT(J) + IF ( DIAG(L).NE.ZERO ) THEN + QTBPJ = ZERO + DWORK(J) = DIAG(L) +C + DO 30 K = J + 1, N + DWORK(K) = ZERO + 30 CONTINUE +C +C The transformations to eliminate the row of D modify only +C a single element of Q'*b beyond the first n, which is +C initially zero. +C + DO 40 K = J, N +C +C Determine a Givens rotation which eliminates the +C appropriate element in the current row of D. +C + IF ( DWORK(K).NE.ZERO ) THEN +C + CALL DLARTG( R(K,K), DWORK(K), CS, SN, TEMP ) +C +C Compute the modified diagonal element of R and +C the modified elements of (Q'*b,0). +C Accumulate the tranformation in the row of S. +C + TEMP = CS*DWORK(N+K) + SN*QTBPJ + QTBPJ = -SN*DWORK(N+K) + CS*QTBPJ + DWORK(N+K) = TEMP + CALL DROT( N-K+1, R(K,K), 1, DWORK(K), 1, CS, SN ) +C + END IF + 40 CONTINUE +C + END IF +C +C Store the diagonal element of S and, if COND <> 'E', restore +C the corresponding diagonal element of R. +C + DWORK(J) = R(J,J) + IF ( .NOT.ECOND ) + $ R(J,J) = X(J) + 50 CONTINUE +C +C Solve the triangular system for z. If the system is singular, +C then obtain a least squares solution. +C + IF ( ECOND ) THEN + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance in rank determination. +C + TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) + END IF +C +C Interchange the strict upper and lower triangular parts of R. +C + DO 60 J = 2, N + CALL DSWAP( J-1, R(1,J), 1, R(J,1), LDR ) + 60 CONTINUE +C +C Estimate the reciprocal condition number of S and set the rank. +C Additional workspace: 2*N. +C + CALL MB03OD( 'No QR', N, N, R, LDR, IPVT, TOLDEF, SVLMAX, + $ DWORK, RANK, DUM, DWORK(2*N+1), LDWORK-2*N, + $ INFO ) + R(1,1) = X(1) +C +C Restore the strict upper and lower triangular parts of R. +C + DO 70 J = 2, N + CALL DSWAP( J-1, R(1,J), 1, R(J,1), LDR ) + R(J,J) = X(J) + 70 CONTINUE +C + ELSEIF ( NCOND ) THEN +C +C Determine rank(S) by checking zero diagonal entries. +C + RANK = N +C + DO 80 J = 1, N + IF ( DWORK(J).EQ.ZERO .AND. RANK.EQ.N ) + $ RANK = J - 1 + 80 CONTINUE +C + END IF +C + DUM(1) = ZERO + IF ( RANK.LT.N ) + $ CALL DCOPY( N-RANK, DUM, 0, DWORK(N+RANK+1), 1 ) +C +C Solve S*z = c using back substitution. +C + DO 100 J = RANK, 1, -1 + TEMP = ZERO +C + DO 90 I = J + 1, RANK + TEMP = TEMP + R(I,J)*DWORK(N+I) + 90 CONTINUE +C + DWORK(N+J) = ( DWORK(N+J) - TEMP )/DWORK(J) + 100 CONTINUE +C +C Permute the components of z back to components of x. +C + DO 110 J = 1, N + L = IPVT(J) + X(L) = DWORK(N+J) + 110 CONTINUE +C + RETURN +C +C *** Last line of MB02YD *** + END diff --git a/mex/sources/libslicot/MB03MD.f b/mex/sources/libslicot/MB03MD.f new file mode 100644 index 000000000..7f47657fd --- /dev/null +++ b/mex/sources/libslicot/MB03MD.f @@ -0,0 +1,343 @@ + SUBROUTINE MB03MD( N, L, THETA, Q, E, Q2, E2, PIVMIN, TOL, RELTOL, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute an upper bound THETA using a bisection method such that +C the bidiagonal matrix +C +C |q(1) e(1) 0 ... 0 | +C | 0 q(2) e(2) . | +C J = | . . | +C | . e(N-1)| +C | 0 ... ... q(N) | +C +C has precisely L singular values less than or equal to THETA plus +C a given tolerance TOL. +C +C This routine is mainly intended to be called only by other SLICOT +C routines. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the bidiagonal matrix J. N >= 0. +C +C L (input/output) INTEGER +C On entry, L must contain the number of singular values +C of J which must be less than or equal to the upper bound +C computed by the routine. 0 <= L <= N. +C On exit, L may be increased if the L-th smallest singular +C value of J has multiplicity greater than 1. In this case, +C L is increased by the number of singular values of J which +C are larger than its L-th smallest one and approach the +C L-th smallest singular value of J within a distance less +C than TOL. +C If L has been increased, then the routine returns with +C IWARN set to 1. +C +C THETA (input/output) DOUBLE PRECISION +C On entry, THETA must contain an initial estimate for the +C upper bound to be computed. If THETA < 0.0 on entry, then +C one of the following default values is used. +C If L = 0, THETA is set to 0.0 irrespective of the input +C value of THETA; if L = 1, then THETA is taken as +C MIN(ABS(Q(i))), for i = 1,2,...,N; otherwise, THETA is +C taken as ABS(Q(N-L+1)). +C On exit, THETA contains the computed upper bound such that +C the bidiagonal matrix J has precisely L singular values +C less than or equal to THETA + TOL. +C +C Q (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the diagonal elements q(1), +C q(2),...,q(N) of the bidiagonal matrix J. That is, +C Q(i) = J(i,i) for i = 1,2,...,N. +C +C E (input) DOUBLE PRECISION array, dimension (N-1) +C This array must contain the superdiagonal elements +C e(1),e(2),...,e(N-1) of the bidiagonal matrix J. That is, +C E(k) = J(k,k+1) for k = 1,2,...,N-1. +C +C Q2 (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the squares of the diagonal +C elements q(1),q(2),...,q(N) of the bidiagonal matrix J. +C That is, Q2(i) = J(i,i)**2 for i = 1,2,...,N. +C +C E2 (input) DOUBLE PRECISION array, dimension (N-1) +C This array must contain the squares of the superdiagonal +C elements e(1),e(2),...,e(N-1) of the bidiagonal matrix J. +C That is, E2(k) = J(k,k+1)**2 for k = 1,2,...,N-1. +C +C PIVMIN (input) DOUBLE PRECISION +C The minimum absolute value of a "pivot" in the Sturm +C sequence loop. +C PIVMIN >= max( max( |q(i)|, |e(k)| )**2*sf_min, sf_min ), +C where i = 1,2,...,N, k = 1,2,...,N-1, and sf_min is at +C least the smallest number that can divide one without +C overflow (see LAPACK Library routine DLAMCH). +C Note that this condition is not checked by the routine. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C This parameter defines the multiplicity of singular values +C by considering all singular values within an interval of +C length TOL as coinciding. TOL is used in checking how many +C singular values are less than or equal to THETA. Also in +C computing an appropriate upper bound THETA by a bisection +C method, TOL is used as a stopping criterion defining the +C minimum (absolute) subinterval width. TOL >= 0. +C +C RELTOL DOUBLE PRECISION +C This parameter specifies the minimum relative width of an +C interval. When an interval is narrower than TOL, or than +C RELTOL times the larger (in magnitude) endpoint, then it +C is considered to be sufficiently small and bisection has +C converged. +C RELTOL >= BASE * EPS, where BASE is machine radix and EPS +C is machine precision (see LAPACK Library routine DLAMCH). +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warnings; +C = 1: if the value of L has been increased as the L-th +C smallest singular value of J coincides with the +C (L+1)-th smallest one. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Let s(i), i = 1,2,...,N, be the N non-negative singular values of +C the bidiagonal matrix J arranged so that s(1) >= ... >= s(N) >= 0. +C The routine then computes an upper bound T such that s(N-L) > T >= +C s(N-L+1) as follows (see [2]). +C First, if the initial estimate of THETA is not specified by the +C user then the routine initialises THETA to be an estimate which +C is close to the requested value of THETA if s(N-L) >> s(N-L+1). +C Second, a bisection method (see [1, 8.5]) is used which generates +C a sequence of shrinking intervals [Y,Z] such that either THETA in +C [Y,Z] was found (so that J has L singular values less than or +C equal to THETA), or +C +C (number of s(i) <= Y) < L < (number of s(i) <= Z). +C +C This bisection method is applied to an associated 2N-by-2N +C symmetric tridiagonal matrix T" whose eigenvalues (see [1]) are +C given by s(1),s(2),...,s(N),-s(1),-s(2),...,-s(N). One of the +C starting values for the bisection method is the initial value of +C THETA. If this value is an upper bound, then the initial lower +C bound is set to zero, else the initial upper bound is computed +C from the Gershgorin Circle Theorem [1, Theorem 7.2-1], applied to +C T". The computation of the "number of s(i) <= Y (or Z)" is +C achieved by calling SLICOT Library routine MB03ND, which applies +C Sylvester's Law of Inertia or equivalently Sturm sequences +C [1, 8.5] to the associated matrix T". If +C +C Z - Y <= MAX( TOL, PIVMIN, RELTOL*MAX( ABS( Y ), ABS( Z ) ) ) +C +C at some stage of the bisection method, then at least two singular +C values of J lie in the interval [Y,Z] within a distance less than +C TOL from each other. In this case, s(N-L) and s(N-L+1) are assumed +C to coincide, the upper bound T is set to the value of Z, the value +C of L is increased and IWARN is set to 1. +C +C REFERENCES +C +C [1] Golub, G.H. and Van Loan, C.F. +C Matrix Computations. +C The Johns Hopkins University Press, Baltimore, Maryland, 1983. +C +C [2] Van Huffel, S. and Vandewalle, J. +C The Partial Total Least Squares Algorithm. +C J. Comput. and Appl. Math., 21, pp. 333-341, 1988. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB03AD by S. Van Huffel, Katholieke +C University, Leuven, Belgium. +C +C REVISIONS +C +C June 16, 1997, Oct. 26, 2003. +C +C KEYWORDS +C +C Bidiagonal matrix, singular values. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, TWO + PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0 ) + DOUBLE PRECISION FUDGE + PARAMETER ( FUDGE = TWO ) +C .. Scalar Arguments .. + INTEGER INFO, IWARN, L, N + DOUBLE PRECISION PIVMIN, RELTOL, THETA, TOL +C .. Array Arguments .. + DOUBLE PRECISION E(*), E2(*), Q(*), Q2(*) +C .. Local Scalars .. + INTEGER I, NUM, NUMZ + DOUBLE PRECISION H, TH, Y, Z +C .. External Functions .. + INTEGER MB03ND + DOUBLE PRECISION DLAMCH, MB03MY + EXTERNAL DLAMCH, MB03MY, MB03ND +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX +C .. Executable Statements .. +C +C Test some input scalar arguments. +C + IWARN = 0 + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( L.LT.0 .OR. L.GT.N ) THEN + INFO = -2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB03MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C +C Step 1: initialisation of THETA. +C ----------------------- + IF ( L.EQ.0 ) THETA = ZERO + IF ( THETA.LT.ZERO ) THEN + IF ( L.EQ.1 ) THEN +C +C An upper bound which is close if S(N-1) >> S(N): +C + THETA = MB03MY( N, Q, 1 ) + IF ( N.EQ.1 ) + $ RETURN + ELSE +C +C An experimentally established estimate which is good if +C S(N-L) >> S(N-L+1): +C + THETA = ABS( Q(N-L+1) ) + END IF + END IF +C +C Step 2: Check quality of initial estimate THETA. +C --------------------------------------- + NUM = MB03ND( N, THETA, Q2, E2, PIVMIN, INFO ) + IF ( NUM.EQ.L ) + $ RETURN +C +C Step 3: initialisation starting values for bisection method. +C --------------------------------------------------- +C Let S(i), i=1,...,N, be the singular values of J in decreasing +C order. Then, the computed Y and Z will be such that +C (number of S(i) <= Y) < L < (number of S(i) <= Z). +C + IF ( NUM.LT.L ) THEN + TH = ABS( Q(1) ) + Z = ZERO + Y = THETA + NUMZ = N +C + DO 20 I = 1, N - 1 + H = ABS( Q(I+1) ) + Z = MAX( MAX( TH, H ) + ABS( E(I) ), Z ) + TH = H + 20 CONTINUE +C +C Widen the Gershgorin interval a bit for machines with sloppy +C arithmetic. +C + Z = Z + FUDGE*ABS( Z )*DLAMCH( 'Epsilon' )*DBLE( N ) + $ + FUDGE*PIVMIN + ELSE + Z = THETA + Y = ZERO + NUMZ = NUM + END IF +C +C Step 4: Bisection method for finding the upper bound on the L +C smallest singular values of the bidiagonal. +C ------------------------------------------ +C A sequence of subintervals [Y,Z] is produced such that +C (number of S(i) <= Y) < L < (number of S(i) <= Z). +C NUM : number of S(i) <= TH, +C NUMZ: number of S(i) <= Z. +C +C WHILE ( ( NUM .NE. L ) .AND. +C ( ( Z-Y ) .GT. MAX( TOL, PIVMIN, RELTOL*ABS( Z ) ) ) ) DO + 40 IF ( ( NUM.NE.L ) .AND. + $ ( ABS( Z-Y ).GT.MAX( TOL, PIVMIN, + $ RELTOL*MAX( ABS( Y ), ABS( Z ) ) ) ) ) + $ THEN + TH = ( Y + Z )/TWO + NUM = MB03ND( N, TH, Q2, E2, PIVMIN, INFO ) + IF ( NUM.LT.L ) THEN + Y = TH + ELSE + Z = TH + NUMZ = NUM + END IF + GO TO 40 + END IF +C END WHILE 40 +C +C If NUM <> L and ( Z - Y ) <= TOL, then at least two singular +C values of J lie in the interval [Y,Z] within a distance less than +C TOL from each other. S(N-L) and S(N-L+1) are then assumed to +C coincide. L is increased, and a warning is given. +C + IF ( NUM.NE.L ) THEN + L = NUMZ + THETA = Z + IWARN = 1 + ELSE + THETA = TH + END IF +C + RETURN +C *** Last line of MB03MD *** + END diff --git a/mex/sources/libslicot/MB03MY.f b/mex/sources/libslicot/MB03MY.f new file mode 100644 index 000000000..cee355e8a --- /dev/null +++ b/mex/sources/libslicot/MB03MY.f @@ -0,0 +1,91 @@ + DOUBLE PRECISION FUNCTION MB03MY( NX, X, INCX ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the absolute minimal value of NX elements in an array. +C The function returns the value zero if NX < 1. +C +C ARGUMENTS +C +C NX (input) INTEGER +C The number of elements in X to be examined. +C +C X (input) DOUBLE PRECISION array, dimension (NX * INCX) +C The one-dimensional array of which the absolute minimal +C value of the elements is to be computed. +C This array is not referenced if NX < 1. +C +C INCX (input) INTEGER +C The increment to be taken in the array X, defining the +C distance between two consecutive elements. INCX >= 1. +C INCX = 1, if all elements are contiguous in memory. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MB03AZ by S. Van Huffel, Katholieke +C University, Leuven, Belgium. +C +C REVISIONS +C +C June 16, 1997. +C +C KEYWORDS +C +C None. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INCX, NX +C .. Array Arguments .. + DOUBLE PRECISION X(*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION DX +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C +C Quick return if possible. +C + IF ( NX.LE.0 ) THEN + MB03MY = ZERO + RETURN + END IF +C + MB03MY = ABS( X(1) ) +C + DO 20 I = 1+INCX, NX*INCX, INCX + DX = ABS( X(I) ) + IF ( DX.LT.MB03MY ) MB03MY = DX + 20 CONTINUE +C + RETURN +C *** Last line of MB03MY *** + END diff --git a/mex/sources/libslicot/MB03ND.f b/mex/sources/libslicot/MB03ND.f new file mode 100644 index 000000000..c681c2e53 --- /dev/null +++ b/mex/sources/libslicot/MB03ND.f @@ -0,0 +1,217 @@ + INTEGER FUNCTION MB03ND( N, THETA, Q2, E2, PIVMIN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find the number of singular values of the bidiagonal matrix +C +C |q(1) e(1) . ... 0 | +C | 0 q(2) e(2) . | +C J = | . . | +C | . e(N-1)| +C | 0 ... ... 0 q(N) | +C +C which are less than or equal to a given bound THETA. +C +C This routine is intended to be called only by other SLICOT +C routines. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the bidiagonal matrix J. N >= 0. +C +C THETA (input) DOUBLE PRECISION +C Given bound. +C Note: If THETA < 0.0 on entry, then MB03ND is set to 0 +C as the singular values of J are non-negative. +C +C Q2 (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the squares of the diagonal +C elements q(1),q(2),...,q(N) of the bidiagonal matrix J. +C That is, Q2(i) = J(i,i)**2 for i = 1,2,...,N. +C +C E2 (input) DOUBLE PRECISION array, dimension (N-1) +C This array must contain the squares of the superdiagonal +C elements e(1),e(2),...,e(N-1) of the bidiagonal matrix J. +C That is, E2(k) = J(k,k+1)**2 for k = 1,2,...,N-1. +C +C PIVMIN (input) DOUBLE PRECISION +C The minimum absolute value of a "pivot" in the Sturm +C sequence loop. +C PIVMIN >= max( max( |q(i)|, |e(k)| )**2*sf_min, sf_min ), +C where i = 1,2,...,N, k = 1,2,...,N-1, and sf_min is at +C least the smallest number that can divide one without +C overflow (see LAPACK Library routine DLAMCH). +C Note that this condition is not checked by the routine. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The computation of the number of singular values s(i) of J which +C are less than or equal to THETA is based on applying Sylvester's +C Law of Inertia, or equivalently, Sturm sequences [1,p.52] to the +C unreduced symmetric tridiagonal matrices associated with J as +C follows. Let T be the following 2N-by-2N symmetric matrix +C associated with J: +C +C | 0 J'| +C T = | |. +C | J 0 | +C +C (The eigenvalues of T are given by s(1),s(2),...,s(N),-s(1),-s(2), +C ...,-s(N)). Then, by permuting the rows and columns of T into the +C order 1, N+1, 2, N+2, ..., N, 2N it follows that T is orthogonally +C similar to the tridiagonal matrix T" with zeros on its diagonal +C and q(1), e(1), q(2), e(2), ..., e(N-1), q(N) on its offdiagonals +C [3,4]. If q(1),q(2),...,q(N) and e(1),e(2),...,e(N-1) are nonzero, +C Sylvester's Law of Inertia may be applied directly to T". +C Otherwise, T" is block diagonal and each diagonal block (which is +C then unreduced) must be analysed separately by applying +C Sylvester's Law of Inertia. +C +C REFERENCES +C +C [1] Parlett, B.N. +C The Symmetric Eigenvalue Problem. +C Prentice Hall, Englewood Cliffs, New Jersey, 1980. +C +C [2] Demmel, J. and Kahan, W. +C Computing Small Singular Values of Bidiagonal Matrices with +C Guaranteed High Relative Accuracy. +C Technical Report, Courant Inst., New York, March 1988. +C +C [3] Van Huffel, S. and Vandewalle, J. +C The Partial Total Least-Squares Algorithm. +C J. Comput. and Appl. Math., 21, pp. 333-341, 1988. +C +C [4] Golub, G.H. and Kahan, W. +C Calculating the Singular Values and Pseudo-inverse of a +C Matrix. +C SIAM J. Numer. Anal., Ser. B, 2, pp. 205-224, 1965. +C +C [5] Demmel, J.W., Dhillon, I. and Ren, H. +C On the Correctness of Parallel Bisection in Floating Point. +C Computer Science Division Technical Report UCB//CSD-94-805, +C University of California, Berkeley, CA 94720, March 1994. +C +C NUMERICAL ASPECTS +C +C The singular values s(i) could also be obtained with the use of +C the symmetric tridiagonal matrix T = J'J, whose eigenvalues are +C the squared singular values of J [4,p.213]. However, the method +C actually used by the routine is more accurate and equally +C efficient (see [2]). +C +C To avoid overflow, matrix J should be scaled so that its largest +C element is no greater than overflow**(1/2) * underflow**(1/4) +C in absolute value (and not much smaller than that, for maximal +C accuracy). +C +C With respect to accuracy the following condition holds (see [2]): +C +C If the established value is denoted by p, then at least p +C singular values of J are less than or equal to +C THETA/(1 - (3 x N - 1.5) x EPS) and no more than p singular values +C are less than or equal to +C THETA x (1 - (6 x N-2) x EPS)/(1 - (3 x N - 1.5) x EPS). +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB03BD by S. Van Huffel, Katholieke +C University, Leuven, Belgium. +C +C REVISIONS +C +C July 10, 1997. +C +C KEYWORDS +C +C Bidiagonal matrix, singular values. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, N + DOUBLE PRECISION PIVMIN, THETA +C .. Array Arguments .. + DOUBLE PRECISION E2(*), Q2(*) +C .. Local Scalars .. + INTEGER J, NUMEIG + DOUBLE PRECISION R, T +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C +C Test the input scalar arguments. PIVMIN is not checked. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 +C +C Error return. +C + CALL XERBLA( 'MB03ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. THETA.LT.ZERO ) THEN + MB03ND = 0 + RETURN + END IF +C + NUMEIG = N + T = -THETA + R = T + IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN +C + DO 20 J = 1, N - 1 + R = T - Q2(J)/R + IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN + IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1 + R = T - E2(J)/R + IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN + IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1 + 20 CONTINUE +C + R = T - Q2(N)/R + IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN + IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1 + MB03ND = NUMEIG +C + RETURN +C *** Last line of MB03ND *** + END diff --git a/mex/sources/libslicot/MB03NY.f b/mex/sources/libslicot/MB03NY.f new file mode 100644 index 000000000..a6efae588 --- /dev/null +++ b/mex/sources/libslicot/MB03NY.f @@ -0,0 +1,208 @@ + DOUBLE PRECISION FUNCTION MB03NY( N, OMEGA, A, LDA, S, DWORK, + $ LDWORK, CWORK, LCWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the smallest singular value of A - jwI. +C +C FUNCTION VALUE +C +C MB03NY DOUBLE PRECISION +C The smallest singular value of A - jwI (if INFO = 0). +C If N = 0, the function value is set to zero. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the the matrix A. N >= 0. +C +C OMEGA (input) DOUBLE PRECISION +C The constant factor of A - jwI. +C +C A (input/workspace) DOUBLE PRECISION array, dimension +C (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, if OMEGA = 0, the contents of this array are +C destroyed. Otherwise, this array is unchanged. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C S (output) DOUBLE PRECISION array, dimension (N) +C The singular values of A - jwI in decreasing order. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX( 1, 5*N ). +C For optimum performance LDWORK should be larger. +C +C CWORK COMPLEX*16 array, dimension (LCWORK) +C On exit, if INFO = 0 and OMEGA <> 0, CWORK(1) returns the +C optimal value of LCWORK. +C If OMEGA is zero, this array is not referenced. +C +C LCWORK INTEGER +C The length of the array CWORK. +C LCWORK >= 1, if OMEGA = 0; +C LCWORK >= MAX( 1, N*N+3*N ), if OMEGA <> 0. +C For optimum performance LCWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 2: The SVD algorithm (in either LAPACK Library routine +C DGESVD or ZGESVD) fails to converge; this error is +C very rare. +C +C METHOD +C +C This procedure simply constructs the matrix A - jwI, and calls +C ZGESVD if w is not zero, or DGESVD if w = 0. +C +C FURTHER COMMENTS +C +C This routine is not very efficient because it computes all +C singular values, but it is very accurate. The routine is intended +C to be called only from the SLICOT Library routine AB13FD. +C +C CONTRIBUTOR +C +C R. Byers, the routine SIGMIN (January, 1995). +C +C REVISIONS +C +C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. +C +C REVISIONS +C +C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. +C Apr. 2002, V. Sima. +C +C KEYWORDS +C +C singular values. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + COMPLEX*16 CONE, RTMONE + PARAMETER ( CONE = ( 1.0D0, 0.0D0 ), + $ RTMONE = ( 0.0D0, 1.0D0 ) ) +C .. Scalar Arguments .. + INTEGER INFO, LCWORK, LDA, LDWORK, N + DOUBLE PRECISION OMEGA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), S(*) + COMPLEX*16 CWORK(*) +C .. Local Scalars .. + INTEGER I, IC, J +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1,1) + COMPLEX*16 ZDUMMY(1,1) +C .. External Subroutines .. + EXTERNAL DGESVD, XERBLA, ZGESVD +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDWORK.LT.MAX( 1, 5*N ) ) THEN + INFO = -7 + ELSE IF( LCWORK.LT.1 .OR. ( OMEGA.NE.ZERO .AND. + $ LCWORK.LT.N*N + 3*N ) ) THEN + INFO = -9 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB03NY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + MB03NY = ZERO + DWORK(1) = ONE + IF ( OMEGA.NE.ZERO ) + $ CWORK(1) = CONE + RETURN + END IF +C + IF ( OMEGA.EQ.ZERO ) THEN +C +C OMEGA = 0 allows real SVD. +C + CALL DGESVD( 'No vectors', 'No vectors', N, N, A, N, S, DUMMY, + $ 1, DUMMY, 1, DWORK, LDWORK, INFO ) + IF ( INFO.NE.0 ) THEN + INFO = 2 + RETURN + END IF + ELSE +C +C General case, that is complex SVD. +C + IC = 1 + DO 20 J = 1, N + DO 10 I = 1, N + CWORK(IC) = A(I,J) + IC = IC + 1 + 10 CONTINUE + CWORK((J-1)*N+J) = CWORK((J-1)*N+J) - OMEGA * RTMONE + 20 CONTINUE + CALL ZGESVD( 'No vectors', 'No vectors', N, N, CWORK, N, S, + $ ZDUMMY, 1, ZDUMMY, 1, CWORK(N*N+1), LCWORK-N*N, + $ DWORK, INFO ) + IF ( INFO.NE.0 ) THEN + INFO = 2 + RETURN + END IF + CWORK(1) = CWORK(N*N+1) + DBLE( N*N ) * CONE + DWORK(1) = DBLE( 5*N ) + END IF +C + MB03NY = S(N) +C +C *** Last line of MB03NY *** + END diff --git a/mex/sources/libslicot/MB03OD.f b/mex/sources/libslicot/MB03OD.f new file mode 100644 index 000000000..71cb43d66 --- /dev/null +++ b/mex/sources/libslicot/MB03OD.f @@ -0,0 +1,306 @@ + SUBROUTINE MB03OD( JOBQR, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU, + $ RANK, SVAL, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute (optionally) a rank-revealing QR factorization of a +C real general M-by-N matrix A, which may be rank-deficient, +C and estimate its effective rank using incremental condition +C estimation. +C +C The routine uses a QR factorization with column pivoting: +C A * P = Q * R, where R = [ R11 R12 ], +C [ 0 R22 ] +C with R11 defined as the largest leading submatrix whose estimated +C condition number is less than 1/RCOND. The order of R11, RANK, +C is the effective rank of A. +C +C MB03OD does not perform any scaling of the matrix A. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBQR CHARACTER*1 +C = 'Q': Perform a QR factorization with column pivoting; +C = 'N': Do not perform the QR factorization (but assume +C that it has been done outside). +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C ( LDA, N ) +C On entry with JOBQR = 'Q', the leading M by N part of this +C array must contain the given matrix A. +C On exit with JOBQR = 'Q', the leading min(M,N) by N upper +C triangular part of A contains the triangular factor R, +C and the elements below the diagonal, with the array TAU, +C represent the orthogonal matrix Q as a product of +C min(M,N) elementary reflectors. +C On entry and on exit with JOBQR = 'N', the leading +C min(M,N) by N upper triangular part of A contains the +C triangular factor R, as determined by the QR factorization +C with pivoting. The elements below the diagonal of A are +C not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C JPVT (input/output) INTEGER array, dimension ( N ) +C On entry with JOBQR = 'Q', if JPVT(i) <> 0, the i-th +C column of A is an initial column, otherwise it is a free +C column. Before the QR factorization of A, all initial +C columns are permuted to the leading positions; only the +C remaining free columns are moved as a result of column +C pivoting during the factorization. For rank determination +C it is preferable that all columns be free. +C On exit with JOBQR = 'Q', if JPVT(i) = k, then the i-th +C column of A*P was the k-th column of A. +C Array JPVT is not referenced when JOBQR = 'N'. +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of A, which +C is defined as the order of the largest leading triangular +C submatrix R11 in the QR factorization with pivoting of A, +C whose estimated condition number is less than 1/RCOND. +C RCOND >= 0. +C NOTE that when SVLMAX > 0, the estimated rank could be +C less than that defined above (see SVLMAX). +C +C SVLMAX (input) DOUBLE PRECISION +C If A is a submatrix of another matrix B, and the rank +C decision should be related to that matrix, then SVLMAX +C should be an estimate of the largest singular value of B +C (for instance, the Frobenius norm of B). If this is not +C the case, the input value SVLMAX = 0 should work. +C SVLMAX >= 0. +C +C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) +C On exit with JOBQR = 'Q', the leading min(M,N) elements of +C TAU contain the scalar factors of the elementary +C reflectors. +C Array TAU is not referenced when JOBQR = 'N'. +C +C RANK (output) INTEGER +C The effective (estimated) rank of A, i.e. the order of +C the submatrix R11. +C +C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) +C The estimates of some of the singular values of the +C triangular factor R: +C SVAL(1): largest singular value of R(1:RANK,1:RANK); +C SVAL(2): smallest singular value of R(1:RANK,1:RANK); +C SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1), +C if RANK < MIN( M, N ), or of R(1:RANK,1:RANK), +C otherwise. +C If the triangular factorization is a rank-revealing one +C (which will be the case if the leading columns were well- +C conditioned), then SVAL(1) will also be an estimate for +C the largest singular value of A, and SVAL(2) and SVAL(3) +C will be estimates for the RANK-th and (RANK+1)-st singular +C values of A, respectively. +C By examining these values, one can confirm that the rank +C is well defined with respect to the chosen value of RCOND. +C The ratio SVAL(1)/SVAL(2) is an estimate of the condition +C number of R(1:RANK,1:RANK). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 3*N + 1, if JOBQR = 'Q'; +C LDWORK >= max( 1, 2*min( M, N ) ), if JOBQR = 'N'. +C For good performance when JOBQR = 'Q', LDWORK should be +C larger. Specifically, LDWORK >= 2*N + ( N + 1 )*NB, where +C NB is the optimal block size for the LAPACK Library +C routine DGEQP3. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes or uses a QR factorization with column +C pivoting of A, A * P = Q * R, with R defined above, and then +C finds the largest leading submatrix whose estimated condition +C number is less than 1/RCOND, taking the possible positive value of +C SVLMAX into account. This is performed using the LAPACK +C incremental condition estimation scheme and a slightly modified +C rank decision test. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBQR + INTEGER INFO, LDA, LDWORK, M, N, RANK + DOUBLE PRECISION RCOND, SVLMAX +C .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), SVAL( 3 ), TAU( * ), DWORK( * ) +C .. Local Scalars .. + LOGICAL LJOBQR + INTEGER I, ISMAX, ISMIN, MAXWRK, MINWRK, MN + DOUBLE PRECISION C1, C2, S1, S2, SMAX, SMAXPR, SMIN, SMINPR +C .. +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEQP3, DLAIC1, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX, MIN +C .. +C .. Executable Statements .. +C + LJOBQR = LSAME( JOBQR, 'Q' ) + MN = MIN( M, N ) + ISMIN = 1 + ISMAX = MN + 1 + IF( LJOBQR ) THEN + MINWRK = 3*N + 1 + ELSE + MINWRK = MAX( 1, 2*MN ) + END IF + MAXWRK = MINWRK +C +C Test the input scalar arguments. +C + INFO = 0 + IF( .NOT.LJOBQR .AND. .NOT.LSAME( JOBQR, 'N' ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( RCOND.LT.ZERO ) THEN + INFO = -7 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -8 + ELSE IF( LDWORK.LT.MINWRK ) THEN + INFO = -13 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03OD', -INFO ) + RETURN + END IF +C +C Quick return if possible +C + IF( MN.EQ.0 ) THEN + RANK = 0 + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + DWORK( 1 ) = ONE + RETURN + END IF +C + IF ( LJOBQR ) THEN +C +C Compute QR factorization with column pivoting of A: +C A * P = Q * R +C Workspace need 3*N + 1; +C prefer 2*N + (N+1)*NB. +C Details of Householder rotations stored in TAU. +C + CALL DGEQP3( M, N, A, LDA, JPVT, TAU, DWORK, LDWORK, INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + END IF +C +C Determine RANK using incremental condition estimation +C + DWORK( ISMIN ) = ONE + DWORK( ISMAX ) = ONE + SMAX = ABS( A( 1, 1 ) ) + SMIN = SMAX + IF( SMAX.EQ.ZERO .OR. SVLMAX*RCOND.GT.SMAX ) THEN + RANK = 0 + SVAL( 1 ) = SMAX + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + ELSE + RANK = 1 + SMINPR = SMIN +C + 10 CONTINUE + IF( RANK.LT.MN ) THEN + I = RANK + 1 + CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, A( 1, I ), + $ A( I, I ), SMINPR, S1, C1 ) + CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, A( 1, I ), + $ A( I, I ), SMAXPR, S2, C2 ) +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN + DO 20 I = 1, RANK + DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) + DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) + 20 CONTINUE + DWORK( ISMIN+RANK ) = C1 + DWORK( ISMAX+RANK ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + GO TO 10 + END IF + END IF + END IF + END IF + SVAL( 1 ) = SMAX + SVAL( 2 ) = SMIN + SVAL( 3 ) = SMINPR + END IF +C + DWORK( 1 ) = MAXWRK + RETURN +C *** Last line of MB03OD *** + END diff --git a/mex/sources/libslicot/MB03OY.f b/mex/sources/libslicot/MB03OY.f new file mode 100644 index 000000000..e39734d55 --- /dev/null +++ b/mex/sources/libslicot/MB03OY.f @@ -0,0 +1,388 @@ + SUBROUTINE MB03OY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, + $ TAU, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a rank-revealing QR factorization of a real general +C M-by-N matrix A, which may be rank-deficient, and estimate its +C effective rank using incremental condition estimation. +C +C The routine uses a truncated QR factorization with column pivoting +C [ R11 R12 ] +C A * P = Q * R, where R = [ ], +C [ 0 R22 ] +C with R11 defined as the largest leading upper triangular submatrix +C whose estimated condition number is less than 1/RCOND. The order +C of R11, RANK, is the effective rank of A. Condition estimation is +C performed during the QR factorization process. Matrix R22 is full +C (but of small norm), or empty. +C +C MB03OY does not perform any scaling of the matrix A. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C ( LDA, N ) +C On entry, the leading M-by-N part of this array must +C contain the given matrix A. +C On exit, the leading RANK-by-RANK upper triangular part +C of A contains the triangular factor R11, and the elements +C below the diagonal in the first RANK columns, with the +C array TAU, represent the orthogonal matrix Q as a product +C of RANK elementary reflectors. +C The remaining N-RANK columns contain the result of the +C QR factorization process used. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of A, which +C is defined as the order of the largest leading triangular +C submatrix R11 in the QR factorization with pivoting of A, +C whose estimated condition number is less than 1/RCOND. +C 0 <= RCOND <= 1. +C NOTE that when SVLMAX > 0, the estimated rank could be +C less than that defined above (see SVLMAX). +C +C SVLMAX (input) DOUBLE PRECISION +C If A is a submatrix of another matrix B, and the rank +C decision should be related to that matrix, then SVLMAX +C should be an estimate of the largest singular value of B +C (for instance, the Frobenius norm of B). If this is not +C the case, the input value SVLMAX = 0 should work. +C SVLMAX >= 0. +C +C RANK (output) INTEGER +C The effective (estimated) rank of A, i.e., the order of +C the submatrix R11. +C +C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) +C The estimates of some of the singular values of the +C triangular factor R: +C SVAL(1): largest singular value of R(1:RANK,1:RANK); +C SVAL(2): smallest singular value of R(1:RANK,1:RANK); +C SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1), +C if RANK < MIN( M, N ), or of R(1:RANK,1:RANK), +C otherwise. +C If the triangular factorization is a rank-revealing one +C (which will be the case if the leading columns were well- +C conditioned), then SVAL(1) will also be an estimate for +C the largest singular value of A, and SVAL(2) and SVAL(3) +C will be estimates for the RANK-th and (RANK+1)-st singular +C values of A, respectively. +C By examining these values, one can confirm that the rank +C is well defined with respect to the chosen value of RCOND. +C The ratio SVAL(1)/SVAL(2) is an estimate of the condition +C number of R(1:RANK,1:RANK). +C +C JPVT (output) INTEGER array, dimension ( N ) +C If JPVT(i) = k, then the i-th column of A*P was the k-th +C column of A. +C +C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) +C The leading RANK elements of TAU contain the scalar +C factors of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension ( 3*N-1 ) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a truncated QR factorization with column +C pivoting of A, A * P = Q * R, with R defined above, and, +C during this process, finds the largest leading submatrix whose +C estimated condition number is less than 1/RCOND, taking the +C possible positive value of SVLMAX into account. This is performed +C using the LAPACK incremental condition estimation scheme and a +C slightly modified rank decision test. The factorization process +C stops when RANK has been determined. +C +C The matrix Q is represented as a product of elementary reflectors +C +C Q = H(1) H(2) . . . H(k), where k = rank <= min(m,n). +C +C Each H(i) has the form +C +C H = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in +C A(i+1:m,i), and tau in TAU(i). +C +C The matrix P is represented in jpvt as follows: If +C jpvt(j) = i +C then the jth column of P is the ith canonical unit vector. +C +C REFERENCES +C +C [1] Bischof, C.H. and P. Tang. +C Generalizing Incremental Condition Estimation. +C LAPACK Working Notes 32, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-132, +C May 1991. +C +C [2] Bischof, C.H. and P. Tang. +C Robust Incremental Condition Estimation. +C LAPACK Working Notes 33, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-133, +C May 1991. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2009. +C +C KEYWORDS +C +C Eigenvalue problem, matrix operations, orthogonal transformation, +C singular values. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ZERO, ONE, P05 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, P05 = 0.05D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, M, N, RANK + DOUBLE PRECISION RCOND, SVLMAX +C .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), DWORK( * ), SVAL( 3 ), TAU( * ) +C .. +C .. Local Scalars .. + INTEGER I, ISMAX, ISMIN, ITEMP, J, MN, PVT + DOUBLE PRECISION AII, C1, C2, S1, S2, SMAX, SMAXPR, SMIN, + $ SMINPR, TEMP, TEMP2 +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2, IDAMAX +C .. External Subroutines .. + EXTERNAL DLAIC1, DLARF, DLARFG, DSCAL, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN + INFO = -5 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03OY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + MN = MIN( M, N ) + IF( MN.EQ.0 ) THEN + RANK = 0 + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF +C + ISMIN = 1 + ISMAX = ISMIN + N +C +C Initialize partial column norms and pivoting vector. The first n +C elements of DWORK store the exact column norms. The already used +C leading part is then overwritten by the condition estimator. +C + DO 10 I = 1, N + DWORK( I ) = DNRM2( M, A( 1, I ), 1 ) + DWORK( N+I ) = DWORK( I ) + JPVT( I ) = I + 10 CONTINUE +C +C Compute factorization and determine RANK using incremental +C condition estimation. +C + RANK = 0 +C + 20 CONTINUE + IF( RANK.LT.MN ) THEN + I = RANK + 1 +C +C Determine ith pivot column and swap if necessary. +C + PVT = ( I-1 ) + IDAMAX( N-I+1, DWORK( I ), 1 ) +C + IF( PVT.NE.I ) THEN + CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( I ) + JPVT( I ) = ITEMP + DWORK( PVT ) = DWORK( I ) + DWORK( N+PVT ) = DWORK( N+I ) + END IF +C +C Save A(I,I) and generate elementary reflector H(i). +C + IF( I.LT.M ) THEN + AII = A( I, I ) + CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) + ELSE + TAU( M ) = ZERO + END IF +C + IF( RANK.EQ.0 ) THEN +C +C Initialize; exit if matrix is zero (RANK = 0). +C + SMAX = ABS( A( 1, 1 ) ) + IF ( SMAX.EQ.ZERO ) THEN + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF + SMIN = SMAX + SMAXPR = SMAX + SMINPR = SMIN + C1 = ONE + C2 = ONE + ELSE +C +C One step of incremental condition estimation. +C + CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, A( 1, I ), + $ A( I, I ), SMINPR, S1, C1 ) + CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, A( 1, I ), + $ A( I, I ), SMAXPR, S2, C2 ) + END IF +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN +C +C Continue factorization, as rank is at least RANK. +C + IF( I.LT.N ) THEN +C +C Apply H(i) to A(i:m,i+1:n) from the left. +C + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, + $ TAU( I ), A( I, I+1 ), LDA, + $ DWORK( 2*N+1 ) ) + A( I, I ) = AII + END IF +C +C Update partial column norms. +C + DO 30 J = I + 1, N + IF( DWORK( J ).NE.ZERO ) THEN + TEMP = ONE - + $ ( ABS( A( I, J ) ) / DWORK( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = ONE + P05*TEMP* + $ ( DWORK( J ) / DWORK( N+J ) )**2 + IF( TEMP2.EQ.ONE ) THEN + IF( M-I.GT.0 ) THEN + DWORK( J ) = DNRM2( M-I, A( I+1, J ), 1 ) + DWORK( N+J ) = DWORK( J ) + ELSE + DWORK( J ) = ZERO + DWORK( N+J ) = ZERO + END IF + ELSE + DWORK( J ) = DWORK( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE +C + DO 40 I = 1, RANK + DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) + DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) + 40 CONTINUE +C + DWORK( ISMIN+RANK ) = C1 + DWORK( ISMAX+RANK ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + GO TO 20 + END IF + END IF + END IF + END IF +C +C Restore the changed part of the (RANK+1)-th column and set SVAL. +C + IF ( RANK.LT.N ) THEN + IF ( I.LT.M ) THEN + CALL DSCAL( M-I, -A( I, I )*TAU( I ), A( I+1, I ), 1 ) + A( I, I ) = AII + END IF + END IF + IF ( RANK.EQ.0 ) THEN + SMIN = ZERO + SMINPR = ZERO + END IF + SVAL( 1 ) = SMAX + SVAL( 2 ) = SMIN + SVAL( 3 ) = SMINPR +C + RETURN +C *** Last line of MB03OY *** + END diff --git a/mex/sources/libslicot/MB03PD.f b/mex/sources/libslicot/MB03PD.f new file mode 100644 index 000000000..5dae93666 --- /dev/null +++ b/mex/sources/libslicot/MB03PD.f @@ -0,0 +1,339 @@ + SUBROUTINE MB03PD( JOBRQ, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU, + $ RANK, SVAL, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute (optionally) a rank-revealing RQ factorization of a +C real general M-by-N matrix A, which may be rank-deficient, +C and estimate its effective rank using incremental condition +C estimation. +C +C The routine uses an RQ factorization with row pivoting: +C P * A = R * Q, where R = [ R11 R12 ], +C [ 0 R22 ] +C with R22 defined as the largest trailing submatrix whose estimated +C condition number is less than 1/RCOND. The order of R22, RANK, +C is the effective rank of A. +C +C MB03PD does not perform any scaling of the matrix A. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBRQ CHARACTER*1 +C = 'R': Perform an RQ factorization with row pivoting; +C = 'N': Do not perform the RQ factorization (but assume +C that it has been done outside). +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C ( LDA, N ) +C On entry with JOBRQ = 'R', the leading M-by-N part of this +C array must contain the given matrix A. +C On exit with JOBRQ = 'R', +C if M <= N, the upper triangle of the subarray +C A(1:M,N-M+1:N) contains the M-by-M upper triangular +C matrix R; +C if M >= N, the elements on and above the (M-N)-th +C subdiagonal contain the M-by-N upper trapezoidal matrix R; +C the remaining elements, with the array TAU, represent the +C orthogonal matrix Q as a product of min(M,N) elementary +C reflectors (see METHOD). +C On entry and on exit with JOBRQ = 'N', +C if M <= N, the upper triangle of the subarray +C A(1:M,N-M+1:N) must contain the M-by-M upper triangular +C matrix R; +C if M >= N, the elements on and above the (M-N)-th +C subdiagonal must contain the M-by-N upper trapezoidal +C matrix R; +C the remaining elements are not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C JPVT (input/output) INTEGER array, dimension ( M ) +C On entry with JOBRQ = 'R', if JPVT(i) <> 0, the i-th row +C of A is a final row, otherwise it is a free row. Before +C the RQ factorization of A, all final rows are permuted +C to the trailing positions; only the remaining free rows +C are moved as a result of row pivoting during the +C factorization. For rank determination it is preferable +C that all rows be free. +C On exit with JOBRQ = 'R', if JPVT(i) = k, then the i-th +C row of P*A was the k-th row of A. +C Array JPVT is not referenced when JOBRQ = 'N'. +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of A, which +C is defined as the order of the largest trailing triangular +C submatrix R22 in the RQ factorization with pivoting of A, +C whose estimated condition number is less than 1/RCOND. +C RCOND >= 0. +C NOTE that when SVLMAX > 0, the estimated rank could be +C less than that defined above (see SVLMAX). +C +C SVLMAX (input) DOUBLE PRECISION +C If A is a submatrix of another matrix B, and the rank +C decision should be related to that matrix, then SVLMAX +C should be an estimate of the largest singular value of B +C (for instance, the Frobenius norm of B). If this is not +C the case, the input value SVLMAX = 0 should work. +C SVLMAX >= 0. +C +C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) +C On exit with JOBRQ = 'R', the leading min(M,N) elements of +C TAU contain the scalar factors of the elementary +C reflectors. +C Array TAU is not referenced when JOBRQ = 'N'. +C +C RANK (output) INTEGER +C The effective (estimated) rank of A, i.e. the order of +C the submatrix R22. +C +C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) +C The estimates of some of the singular values of the +C triangular factor R: +C SVAL(1): largest singular value of +C R(M-RANK+1:M,N-RANK+1:N); +C SVAL(2): smallest singular value of +C R(M-RANK+1:M,N-RANK+1:N); +C SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N), +C if RANK < MIN( M, N ), or of +C R(M-RANK+1:M,N-RANK+1:N), otherwise. +C If the triangular factorization is a rank-revealing one +C (which will be the case if the trailing rows were well- +C conditioned), then SVAL(1) will also be an estimate for +C the largest singular value of A, and SVAL(2) and SVAL(3) +C will be estimates for the RANK-th and (RANK+1)-st singular +C values of A, respectively. +C By examining these values, one can confirm that the rank +C is well defined with respect to the chosen value of RCOND. +C The ratio SVAL(1)/SVAL(2) is an estimate of the condition +C number of R(M-RANK+1:M,N-RANK+1:N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) +C where LDWORK = max( 1, 3*M ), if JOBRQ = 'R'; +C LDWORK = max( 1, 3*min( M, N ) ), if JOBRQ = 'N'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes or uses an RQ factorization with row +C pivoting of A, P * A = R * Q, with R defined above, and then +C finds the largest trailing submatrix whose estimated condition +C number is less than 1/RCOND, taking the possible positive value of +C SVLMAX into account. This is performed using an adaptation of the +C LAPACK incremental condition estimation scheme and a slightly +C modified rank decision test. +C +C The matrix Q is represented as a product of elementary reflectors +C +C Q = H(1) H(2) . . . H(k), where k = min(m,n). +C +C Each H(i) has the form +C +C H = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit +C in A(m-k+i,1:n-k+i-1), and tau in TAU(i). +C +C The matrix P is represented in jpvt as follows: If +C jpvt(j) = i +C then the jth row of P is the ith canonical unit vector. +C +C REFERENCES +C +C [1] Bischof, C.H. and P. Tang. +C Generalizing Incremental Condition Estimation. +C LAPACK Working Notes 32, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-132, +C May 1991. +C +C [2] Bischof, C.H. and P. Tang. +C Robust Incremental Condition Estimation. +C LAPACK Working Notes 33, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-133, +C May 1991. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C +C REVISIONS +C +C Nov. 1997 +C +C KEYWORDS +C +C Eigenvalue problem, matrix operations, orthogonal transformation, +C singular values. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBRQ + INTEGER INFO, LDA, M, N, RANK + DOUBLE PRECISION RCOND, SVLMAX +C .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), SVAL( 3 ), TAU( * ), DWORK( * ) +C .. Local Scalars .. + LOGICAL LJOBRQ + INTEGER I, ISMAX, ISMIN, JWORK, MN + DOUBLE PRECISION C1, C2, S1, S2, SMAX, SMAXPR, SMIN, SMINPR +C .. +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLAIC1, MB04GD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. +C .. Executable Statements .. +C + LJOBRQ = LSAME( JOBRQ, 'R' ) + MN = MIN( M, N ) +C +C Test the input scalar arguments. +C + INFO = 0 + IF( .NOT.LJOBRQ .AND. .NOT.LSAME( JOBRQ, 'N' ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( RCOND.LT.ZERO ) THEN + INFO = -7 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -8 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MN.EQ.0 ) THEN + RANK = 0 + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF +C + IF ( LJOBRQ ) THEN +C +C Compute RQ factorization with row pivoting of A: +C P * A = R * Q +C Workspace 3*M. Details of Householder rotations stored in TAU. +C + CALL MB04GD( M, N, A, LDA, JPVT, TAU, DWORK( 1 ), INFO ) + END IF +C +C Determine RANK using incremental condition estimation. +C Workspace 3*min(M,N). +C + SMAX = ABS( A( M, N ) ) + IF( SMAX.EQ.ZERO .OR. SVLMAX*RCOND.GT.SMAX ) THEN + RANK = 0 + SVAL( 1 ) = SMAX + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + ELSE + ISMIN = MN + ISMAX = 2*MN + JWORK = ISMAX + 1 + DWORK( ISMIN ) = ONE + DWORK( ISMAX ) = ONE + RANK = 1 + SMIN = SMAX + SMINPR = SMIN +C + 10 CONTINUE + IF( RANK.LT.MN ) THEN + CALL DCOPY ( RANK, A( M-RANK, N-RANK+1 ), LDA, + $ DWORK( JWORK ), 1 ) + CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, + $ DWORK( JWORK ), A( M-RANK, N-RANK ), SMINPR, + $ S1, C1 ) + CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, + $ DWORK( JWORK ), A( M-RANK, N-RANK ), SMAXPR, + $ S2, C2 ) +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN + DO 20 I = 1, RANK + DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) + DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) + 20 CONTINUE + ISMIN = ISMIN - 1 + ISMAX = ISMAX - 1 + DWORK( ISMIN ) = C1 + DWORK( ISMAX ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + GO TO 10 + END IF + END IF + END IF + END IF + SVAL( 1 ) = SMAX + SVAL( 2 ) = SMIN + SVAL( 3 ) = SMINPR + END IF +C + RETURN +C *** Last line of MB03PD *** + END diff --git a/mex/sources/libslicot/MB03PY.f b/mex/sources/libslicot/MB03PY.f new file mode 100644 index 000000000..d0c7d0ca2 --- /dev/null +++ b/mex/sources/libslicot/MB03PY.f @@ -0,0 +1,392 @@ + SUBROUTINE MB03PY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, + $ TAU, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a rank-revealing RQ factorization of a real general +C M-by-N matrix A, which may be rank-deficient, and estimate its +C effective rank using incremental condition estimation. +C +C The routine uses a truncated RQ factorization with row pivoting: +C [ R11 R12 ] +C P * A = R * Q, where R = [ ], +C [ 0 R22 ] +C with R22 defined as the largest trailing upper triangular +C submatrix whose estimated condition number is less than 1/RCOND. +C The order of R22, RANK, is the effective rank of A. Condition +C estimation is performed during the RQ factorization process. +C Matrix R11 is full (but of small norm), or empty. +C +C MB03PY does not perform any scaling of the matrix A. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C ( LDA, N ) +C On entry, the leading M-by-N part of this array must +C contain the given matrix A. +C On exit, the upper triangle of the subarray +C A(M-RANK+1:M,N-RANK+1:N) contains the RANK-by-RANK upper +C triangular matrix R22; the remaining elements in the last +C RANK rows, with the array TAU, represent the orthogonal +C matrix Q as a product of RANK elementary reflectors +C (see METHOD). The first M-RANK rows contain the result +C of the RQ factorization process used. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of A, which +C is defined as the order of the largest trailing triangular +C submatrix R22 in the RQ factorization with pivoting of A, +C whose estimated condition number is less than 1/RCOND. +C 0 <= RCOND <= 1. +C NOTE that when SVLMAX > 0, the estimated rank could be +C less than that defined above (see SVLMAX). +C +C SVLMAX (input) DOUBLE PRECISION +C If A is a submatrix of another matrix B, and the rank +C decision should be related to that matrix, then SVLMAX +C should be an estimate of the largest singular value of B +C (for instance, the Frobenius norm of B). If this is not +C the case, the input value SVLMAX = 0 should work. +C SVLMAX >= 0. +C +C RANK (output) INTEGER +C The effective (estimated) rank of A, i.e., the order of +C the submatrix R22. +C +C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) +C The estimates of some of the singular values of the +C triangular factor R: +C SVAL(1): largest singular value of +C R(M-RANK+1:M,N-RANK+1:N); +C SVAL(2): smallest singular value of +C R(M-RANK+1:M,N-RANK+1:N); +C SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N), +C if RANK < MIN( M, N ), or of +C R(M-RANK+1:M,N-RANK+1:N), otherwise. +C If the triangular factorization is a rank-revealing one +C (which will be the case if the trailing rows were well- +C conditioned), then SVAL(1) will also be an estimate for +C the largest singular value of A, and SVAL(2) and SVAL(3) +C will be estimates for the RANK-th and (RANK+1)-st singular +C values of A, respectively. +C By examining these values, one can confirm that the rank +C is well defined with respect to the chosen value of RCOND. +C The ratio SVAL(1)/SVAL(2) is an estimate of the condition +C number of R(M-RANK+1:M,N-RANK+1:N). +C +C JPVT (output) INTEGER array, dimension ( M ) +C If JPVT(i) = k, then the i-th row of P*A was the k-th row +C of A. +C +C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) +C The trailing RANK elements of TAU contain the scalar +C factors of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension ( 3*M-1 ) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a truncated RQ factorization with row +C pivoting of A, P * A = R * Q, with R defined above, and, +C during this process, finds the largest trailing submatrix whose +C estimated condition number is less than 1/RCOND, taking the +C possible positive value of SVLMAX into account. This is performed +C using an adaptation of the LAPACK incremental condition estimation +C scheme and a slightly modified rank decision test. The +C factorization process stops when RANK has been determined. +C +C The matrix Q is represented as a product of elementary reflectors +C +C Q = H(k-rank+1) H(k-rank+2) . . . H(k), where k = min(m,n). +C +C Each H(i) has the form +C +C H = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit +C in A(m-k+i,1:n-k+i-1), and tau in TAU(i). +C +C The matrix P is represented in jpvt as follows: If +C jpvt(j) = i +C then the jth row of P is the ith canonical unit vector. +C +C REFERENCES +C +C [1] Bischof, C.H. and P. Tang. +C Generalizing Incremental Condition Estimation. +C LAPACK Working Notes 32, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-132, +C May 1991. +C +C [2] Bischof, C.H. and P. Tang. +C Robust Incremental Condition Estimation. +C LAPACK Working Notes 33, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-133, +C May 1991. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001, +C Jan. 2009. +C +C KEYWORDS +C +C Eigenvalue problem, matrix operations, orthogonal transformation, +C singular values. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ZERO, ONE, P05 + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D+0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, M, N, RANK + DOUBLE PRECISION RCOND, SVLMAX +C .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), DWORK( * ), SVAL( 3 ), TAU( * ) +C .. Local Scalars .. + INTEGER I, ISMAX, ISMIN, ITEMP, J, JWORK, K, MKI, NKI, + $ PVT + DOUBLE PRECISION AII, C1, C2, S1, S2, SMAX, SMAXPR, SMIN, + $ SMINPR, TEMP, TEMP2 +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2, IDAMAX +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DLAIC1, DLARF, DLARFG, DSCAL, DSWAP, + $ XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN + INFO = -5 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03PY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + K = MIN( M, N ) + IF( K.EQ.0 ) THEN + RANK = 0 + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF +C + ISMIN = M + ISMAX = ISMIN + M + JWORK = ISMAX + 1 +C +C Initialize partial row norms and pivoting vector. The first m +C elements of DWORK store the exact row norms. The already used +C trailing part is then overwritten by the condition estimator. +C + DO 10 I = 1, M + DWORK( I ) = DNRM2( N, A( I, 1 ), LDA ) + DWORK( M+I ) = DWORK( I ) + JPVT( I ) = I + 10 CONTINUE +C +C Compute factorization and determine RANK using incremental +C condition estimation. +C + RANK = 0 +C + 20 CONTINUE + IF( RANK.LT.K ) THEN + I = K - RANK +C +C Determine ith pivot row and swap if necessary. +C + MKI = M - RANK + NKI = N - RANK + PVT = IDAMAX( MKI, DWORK, 1 ) +C + IF( PVT.NE.MKI ) THEN + CALL DSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( MKI ) + JPVT( MKI ) = ITEMP + DWORK( PVT ) = DWORK( MKI ) + DWORK( M+PVT ) = DWORK( M+MKI ) + END IF +C + IF( NKI.GT.1 ) THEN +C +C Save A(m-k+i,n-k+i) and generate elementary reflector H(i) +C to annihilate A(m-k+i,1:n-k+i-1), k = min(m,n). +C + AII = A( MKI, NKI ) + CALL DLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I ) + $ ) + END IF +C + IF( RANK.EQ.0 ) THEN +C +C Initialize; exit if matrix is zero (RANK = 0). +C + SMAX = ABS( A( M, N ) ) + IF ( SMAX.EQ.ZERO ) THEN + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF + SMIN = SMAX + SMAXPR = SMAX + SMINPR = SMIN + C1 = ONE + C2 = ONE + ELSE +C +C One step of incremental condition estimation. +C + CALL DCOPY ( RANK, A( MKI, NKI+1 ), LDA, DWORK( JWORK ), 1 ) + CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, + $ DWORK( JWORK ), A( MKI, NKI ), SMINPR, S1, C1 ) + CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, + $ DWORK( JWORK ), A( MKI, NKI ), SMAXPR, S2, C2 ) + END IF +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN +C + IF( MKI.GT.1 ) THEN +C +C Continue factorization, as rank is at least RANK. +C Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right. +C + AII = A( MKI, NKI ) + A( MKI, NKI ) = ONE + CALL DLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA, + $ TAU( I ), A, LDA, DWORK( JWORK ) ) + A( MKI, NKI ) = AII +C +C Update partial row norms. +C + DO 30 J = 1, MKI - 1 + IF( DWORK( J ).NE.ZERO ) THEN + TEMP = ONE - + $ ( ABS( A( J, NKI ) )/DWORK( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = ONE + P05*TEMP* + $ ( DWORK( J ) / DWORK( M+J ) )**2 + IF( TEMP2.EQ.ONE ) THEN + DWORK( J ) = DNRM2( NKI-1, A( J, 1 ), + $ LDA ) + DWORK( M+J ) = DWORK( J ) + ELSE + DWORK( J ) = DWORK( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE +C + END IF +C + DO 40 I = 1, RANK + DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) + DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) + 40 CONTINUE +C + IF( RANK.GT.0 ) THEN + ISMIN = ISMIN - 1 + ISMAX = ISMAX - 1 + END IF + DWORK( ISMIN ) = C1 + DWORK( ISMAX ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + GO TO 20 + END IF + END IF + END IF + END IF +C +C Restore the changed part of the (M-RANK)-th row and set SVAL. +C + IF ( RANK.LT.K .AND. NKI.GT.1 ) THEN + CALL DSCAL( NKI-1, -A( MKI, NKI )*TAU( I ), A( MKI, 1 ), LDA ) + A( MKI, NKI ) = AII + END IF + SVAL( 1 ) = SMAX + SVAL( 2 ) = SMIN + SVAL( 3 ) = SMINPR +C + RETURN +C *** Last line of MB03PY *** + END diff --git a/mex/sources/libslicot/MB03QD.f b/mex/sources/libslicot/MB03QD.f new file mode 100644 index 000000000..d94eed1bb --- /dev/null +++ b/mex/sources/libslicot/MB03QD.f @@ -0,0 +1,316 @@ + SUBROUTINE MB03QD( DICO, STDOM, JOBU, N, NLOW, NSUP, ALPHA, + $ A, LDA, U, LDU, NDIM, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reorder the diagonal blocks of a principal submatrix of an +C upper quasi-triangular matrix A together with their eigenvalues by +C constructing an orthogonal similarity transformation UT. +C After reordering, the leading block of the selected submatrix of A +C has eigenvalues in a suitably defined domain of interest, usually +C related to stability/instability in a continuous- or discrete-time +C sense. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the spectrum separation to be +C performed as follows: +C = 'C': continuous-time sense; +C = 'D': discrete-time sense. +C +C STDOM CHARACTER*1 +C Specifies whether the domain of interest is of stability +C type (left part of complex plane or inside of a circle) +C or of instability type (right part of complex plane or +C outside of a circle) as follows: +C = 'S': stability type domain; +C = 'U': instability type domain. +C +C JOBU CHARACTER*1 +C Indicates how the performed orthogonal transformations UT +C are accumulated, as follows: +C = 'I': U is initialized to the unit matrix and the matrix +C UT is returned in U; +C = 'U': the given matrix U is updated and the matrix U*UT +C is returned in U. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and U. N >= 1. +C +C NLOW, (input) INTEGER +C NSUP NLOW and NSUP specify the boundary indices for the rows +C and columns of the principal submatrix of A whose diagonal +C blocks are to be reordered. 1 <= NLOW <= NSUP <= N. +C +C ALPHA (input) DOUBLE PRECISION +C The boundary of the domain of interest for the eigenvalues +C of A. If DICO = 'C', ALPHA is the boundary value for the +C real parts of eigenvalues, while for DICO = 'D', +C ALPHA >= 0 represents the boundary value for the moduli of +C eigenvalues. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain a matrix in a real Schur form whose 1-by-1 and +C 2-by-2 diagonal blocks between positions NLOW and NSUP +C are to be reordered. +C On exit, the leading N-by-N part contains the ordered +C real Schur matrix UT' * A * UT with the elements below the +C first subdiagonal set to zero. +C The leading NDIM-by-NDIM part of the principal submatrix +C D = A(NLOW:NSUP,NLOW:NSUP) has eigenvalues in the domain +C of interest and the trailing part of this submatrix has +C eigenvalues outside the domain of interest. +C The domain of interest for lambda(D), the eigenvalues of +C D, is defined by the parameters ALPHA, DICO and STDOM as +C follows: +C For DICO = 'C': +C Real(lambda(D)) < ALPHA if STDOM = 'S'; +C Real(lambda(D)) > ALPHA if STDOM = 'U'. +C For DICO = 'D': +C Abs(lambda(D)) < ALPHA if STDOM = 'S'; +C Abs(lambda(D)) > ALPHA if STDOM = 'U'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) +C On entry with JOBU = 'U', the leading N-by-N part of this +C array must contain a transformation matrix (e.g. from a +C previous call to this routine). +C On exit, if JOBU = 'U', the leading N-by-N part of this +C array contains the product of the input matrix U and the +C orthogonal matrix UT used to reorder the diagonal blocks +C of A. +C On exit, if JOBU = 'I', the leading N-by-N part of this +C array contains the matrix UT of the performed orthogonal +C transformations. +C Array U need not be set on entry if JOBU = 'I'. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= N. +C +C NDIM (output) INTEGER +C The number of eigenvalues of the selected principal +C submatrix lying inside the domain of interest. +C If NLOW = 1, NDIM is also the dimension of the invariant +C subspace corresponding to the eigenvalues of the leading +C NDIM-by-NDIM submatrix. In this case, if U is the +C orthogonal transformation matrix used to compute and +C reorder the real Schur form of A, its first NDIM columns +C form an orthonormal basis for the above invariant +C subspace. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: A(NLOW,NLOW-1) is nonzero, i.e. A(NLOW,NLOW) is not +C the leading element of a 1-by-1 or 2-by-2 diagonal +C block of A, or A(NSUP+1,NSUP) is nonzero, i.e. +C A(NSUP,NSUP) is not the bottom element of a 1-by-1 +C or 2-by-2 diagonal block of A; +C = 2: two adjacent blocks are too close to swap (the +C problem is very ill-conditioned). +C +C METHOD +C +C Given an upper quasi-triangular matrix A with 1-by-1 or 2-by-2 +C diagonal blocks, the routine reorders its diagonal blocks along +C with its eigenvalues by performing an orthogonal similarity +C transformation UT' * A * UT. The column transformation UT is also +C performed on the given (initial) transformation U (resulted from +C a possible previous step or initialized as the identity matrix). +C After reordering, the eigenvalues inside the region specified by +C the parameters ALPHA, DICO and STDOM appear at the top of +C the selected diagonal block between positions NLOW and NSUP. +C In other words, lambda(A(NLOW:NSUP,NLOW:NSUP)) are ordered such +C that lambda(A(NLOW:NLOW+NDIM-1,NLOW:NLOW+NDIM-1)) are inside and +C lambda(A(NLOW+NDIM:NSUP,NLOW+NDIM:NSUP)) are outside the domain +C of interest. If NLOW = 1, the first NDIM columns of U*UT span the +C corresponding invariant subspace of A. +C +C REFERENCES +C +C [1] Stewart, G.W. +C HQR3 and EXCHQZ: FORTRAN subroutines for calculating and +C ordering the eigenvalues of a real upper Hessenberg matrix. +C ACM TOMS, 2, pp. 275-280, 1976. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires less than 4*N operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, +C April 1998. Based on the RASP routine SEOR1. +C +C KEYWORDS +C +C Eigenvalues, invariant subspace, orthogonal transformation, real +C Schur form, similarity transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBU, STDOM + INTEGER INFO, LDA, LDU, N, NDIM, NLOW, NSUP + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), U(LDU,*) +C .. Local Scalars .. + LOGICAL DISCR, LSTDOM + INTEGER IB, L, LM1, NUP + DOUBLE PRECISION E1, E2, TLAMBD +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL DLASET, DTREXC, MB03QY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + LSTDOM = LSAME( STDOM, 'S' ) +C +C Check input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSTDOM .OR. LSAME( STDOM, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( JOBU, 'I' ) .OR. + $ LSAME( JOBU, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.1 ) THEN + INFO = -4 + ELSE IF( NLOW.LT.1 ) THEN + INFO = -5 + ELSE IF( NLOW.GT.NSUP .OR. NSUP.GT.N ) THEN + INFO = -6 + ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN + INFO = -7 + ELSE IF( LDA.LT.N ) THEN + INFO = -9 + ELSE IF( LDU.LT.N ) THEN + INFO = -11 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB03QD', -INFO ) + RETURN + END IF +C + IF( NLOW.GT.1 ) THEN + IF( A(NLOW,NLOW-1).NE.ZERO ) INFO = 1 + END IF + IF( NSUP.LT.N ) THEN + IF( A(NSUP+1,NSUP).NE.ZERO ) INFO = 1 + END IF + IF( INFO.NE.0 ) + $ RETURN +C +C Initialize U with an identity matrix if necessary. +C + IF( LSAME( JOBU, 'I' ) ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) +C + NDIM = 0 + L = NSUP + NUP = NSUP +C +C NUP is the minimal value such that the submatrix A(i,j) with +C NUP+1 <= i,j <= NSUP contains no eigenvalues inside the domain of +C interest. L is such that all the eigenvalues of the submatrix +C A(i,j) with L+1 <= i,j <= NUP lie inside the domain of interest. +C +C WHILE( L >= NLOW ) DO +C + 10 IF( L.GE.NLOW ) THEN + IB = 1 + IF( L.GT.NLOW ) THEN + LM1 = L - 1 + IF( A(L,LM1).NE.ZERO ) THEN + CALL MB03QY( N, LM1, A, LDA, U, LDU, E1, E2, INFO ) + IF( A(L,LM1).NE.ZERO ) IB = 2 + END IF + END IF + IF( DISCR ) THEN + IF( IB.EQ.1 ) THEN + TLAMBD = ABS( A(L,L) ) + ELSE + TLAMBD = DLAPY2( E1, E2 ) + END IF + ELSE + IF( IB.EQ.1 ) THEN + TLAMBD = A(L,L) + ELSE + TLAMBD = E1 + END IF + END IF + IF( ( LSTDOM .AND. TLAMBD.LT.ALPHA ) .OR. + $ ( .NOT.LSTDOM .AND. TLAMBD.GT.ALPHA ) ) THEN + NDIM = NDIM + IB + L = L - IB + ELSE + IF( NDIM.NE.0 ) THEN + CALL DTREXC( 'V', N, A, LDA, U, LDU, L, NUP, DWORK, + $ INFO ) + IF( INFO.NE.0 ) THEN + INFO = 2 + RETURN + END IF + NUP = NUP - 1 + L = L - 1 + ELSE + NUP = NUP - IB + L = L - IB + END IF + END IF + GO TO 10 + END IF +C +C END WHILE 10 +C + RETURN +C *** Last line of MB03QD *** + END diff --git a/mex/sources/libslicot/MB03QX.f b/mex/sources/libslicot/MB03QX.f new file mode 100644 index 000000000..26474ba96 --- /dev/null +++ b/mex/sources/libslicot/MB03QX.f @@ -0,0 +1,122 @@ + SUBROUTINE MB03QX( N, T, LDT, WR, WI, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the eigenvalues of an upper quasi-triangular matrix. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix T. N >= 0. +C +C T (input) DOUBLE PRECISION array, dimension(LDT,N) +C The upper quasi-triangular matrix T. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= max(1,N). +C +C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) +C The real and imaginary parts, respectively, of the +C eigenvalues of T. The eigenvalues are stored in the same +C order as on the diagonal of T. If T(i:i+1,i:i+1) is a +C 2-by-2 diagonal block with complex conjugated eigenvalues +C then WI(i) > 0 and WI(i+1) = -WI(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, +C March 1998. Based on the RASP routine SEIG. +C +C ****************************************************************** +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDT, N +C .. Array Arguments .. + DOUBLE PRECISION T(LDT, *), WI(*), WR(*) +C .. Local Scalars .. + INTEGER I, I1, INEXT + DOUBLE PRECISION A11, A12, A21, A22, CS, SN +C .. External Subroutines .. + EXTERNAL DLANV2, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -3 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB03QX', -INFO ) + RETURN + END IF +C + INEXT = 1 + DO 10 I = 1, N + IF( I.LT.INEXT ) + $ GO TO 10 + IF( I.NE.N ) THEN + IF( T(I+1,I).NE.ZERO ) THEN +C +C A pair of eigenvalues. +C + INEXT = I + 2 + I1 = I + 1 + A11 = T(I,I) + A12 = T(I,I1) + A21 = T(I1,I) + A22 = T(I1,I1) + CALL DLANV2( A11, A12, A21, A22, WR(I), WI(I), WR(I1), + $ WI(I1), CS, SN ) + GO TO 10 + END IF + END IF +C +C Simple eigenvalue. +C + INEXT = I + 1 + WR(I) = T(I,I) + WI(I) = ZERO + 10 CONTINUE +C + RETURN +C *** Last line of MB03QX *** + END diff --git a/mex/sources/libslicot/MB03QY.f b/mex/sources/libslicot/MB03QY.f new file mode 100644 index 000000000..bf3c8d1ae --- /dev/null +++ b/mex/sources/libslicot/MB03QY.f @@ -0,0 +1,164 @@ + SUBROUTINE MB03QY( N, L, A, LDA, U, LDU, E1, E2, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the eigenvalues of a selected 2-by-2 diagonal block +C of an upper quasi-triangular matrix, to reduce the selected block +C to the standard form and to split the block in the case of real +C eigenvalues by constructing an orthogonal transformation UT. +C This transformation is applied to A (by similarity) and to +C another matrix U from the right. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and UT. N >= 2. +C +C L (input) INTEGER +C Specifies the position of the block. 1 <= L < N. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the upper quasi-triangular matrix A whose +C selected 2-by-2 diagonal block is to be processed. +C On exit, the leading N-by-N part of this array contains +C the upper quasi-triangular matrix A after its selected +C block has been splitt and/or put in the LAPACK standard +C form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) +C On entry, the leading N-by-N part of this array must +C contain a transformation matrix U. +C On exit, the leading N-by-N part of this array contains +C U*UT, where UT is the transformation matrix used to +C split and/or standardize the selected block. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= N. +C +C E1, E2 (output) DOUBLE PRECISION +C E1 and E2 contain either the real eigenvalues or the real +C and positive imaginary parts, respectively, of the complex +C eigenvalues of the selected 2-by-2 diagonal block of A. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Let A1 = ( A(L,L) A(L,L+1) ) +C ( A(L+1,L) A(L+1,L+1) ) +C be the specified 2-by-2 diagonal block of matrix A. +C If the eigenvalues of A1 are complex, then they are computed and +C stored in E1 and E2, where the real part is stored in E1 and the +C positive imaginary part in E2. The 2-by-2 block is reduced if +C necessary to the standard form, such that A(L,L) = A(L+1,L+1), and +C A(L,L+1) and A(L+1,L) have oposite signs. If the eigenvalues are +C real, the 2-by-2 block is reduced to an upper triangular form such +C that ABS(A(L,L)) >= ABS(A(L+1,L+1)). +C In both cases, an orthogonal rotation U1' is constructed such that +C U1'*A1*U1 has the appropriate form. Let UT be an extension of U1 +C to an N-by-N orthogonal matrix, using identity submatrices. Then A +C is replaced by UT'*A*UT and the contents of array U is U * UT. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, +C March 1998. Based on the RASP routine SPLITB. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalues, orthogonal transformation, real Schur form, +C similarity transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, L, LDA, LDU, N + DOUBLE PRECISION E1, E2 +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), U(LDU,*) +C .. Local Scalars .. + INTEGER L1 + DOUBLE PRECISION EW1, EW2, CS, SN +C .. External Subroutines .. + EXTERNAL DLANV2, DROT, XERBLA +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.2 ) THEN + INFO = -1 + ELSE IF( L.LT.1 .OR. L.GE.N ) THEN + INFO = -2 + ELSE IF( LDA.LT.N ) THEN + INFO = -4 + ELSE IF( LDU.LT.N ) THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB03QY', -INFO ) + RETURN + END IF +C +C Compute the eigenvalues and the elements of the Givens +C transformation. +C + L1 = L + 1 + CALL DLANV2( A(L,L), A(L,L1), A(L1,L), A(L1,L1), E1, E2, + $ EW1, EW2, CS, SN ) + IF( E2.EQ.ZERO ) E2 = EW1 +C +C Apply the transformation to A. +C + IF( L1.LT.N ) + $ CALL DROT( N-L1, A(L,L1+1), LDA, A(L1,L1+1), LDA, CS, SN ) + CALL DROT( L-1, A(1,L), 1, A(1,L1), 1, CS, SN ) +C +C Accumulate the transformation in U. +C + CALL DROT( N, U(1,L), 1, U(1,L1), 1, CS, SN ) +C + RETURN +C *** Last line of MB03QY *** + END diff --git a/mex/sources/libslicot/MB03RD.f b/mex/sources/libslicot/MB03RD.f new file mode 100644 index 000000000..9d3910d11 --- /dev/null +++ b/mex/sources/libslicot/MB03RD.f @@ -0,0 +1,613 @@ + SUBROUTINE MB03RD( JOBX, SORT, N, PMAX, A, LDA, X, LDX, NBLCKS, + $ BLSIZE, WR, WI, TOL, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce a matrix A in real Schur form to a block-diagonal form +C using well-conditioned non-orthogonal similarity transformations. +C The condition numbers of the transformations used for reduction +C are roughly bounded by PMAX*PMAX, where PMAX is a given value. +C The transformations are optionally postmultiplied in a given +C matrix X. The real Schur form is optionally ordered, so that +C clustered eigenvalues are grouped in the same block. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBX CHARACTER*1 +C Specifies whether or not the transformations are +C accumulated, as follows: +C = 'N': The transformations are not accumulated; +C = 'U': The transformations are accumulated in X (the +C given matrix X is updated). +C +C SORT CHARACTER*1 +C Specifies whether or not the diagonal blocks of the real +C Schur form are reordered, as follows: +C = 'N': The diagonal blocks are not reordered; +C = 'S': The diagonal blocks are reordered before each +C step of reduction, so that clustered eigenvalues +C appear in the same block; +C = 'C': The diagonal blocks are not reordered, but the +C "closest-neighbour" strategy is used instead of +C the standard "closest to the mean" strategy +C (see METHOD); +C = 'B': The diagonal blocks are reordered before each +C step of reduction, and the "closest-neighbour" +C strategy is used (see METHOD). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and X. N >= 0. +C +C PMAX (input) DOUBLE PRECISION +C An upper bound for the infinity norm of elementary +C submatrices of the individual transformations used for +C reduction (see METHOD). PMAX >= 1.0D0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A to be block-diagonalized, in real +C Schur form. +C On exit, the leading N-by-N part of this array contains +C the computed block-diagonal matrix, in real Schur +C canonical form. The non-diagonal blocks are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, if JOBX = 'U', the leading N-by-N part of this +C array must contain a given matrix X. +C On exit, if JOBX = 'U', the leading N-by-N part of this +C array contains the product of the given matrix X and the +C transformation matrix that reduced A to block-diagonal +C form. The transformation matrix is itself a product of +C non-orthogonal similarity transformations having elements +C with magnitude less than or equal to PMAX. +C If JOBX = 'N', this array is not referenced. +C +C LDX INTEGER +C The leading dimension of array X. +C LDX >= 1, if JOBX = 'N'; +C LDX >= MAX(1,N), if JOBX = 'U'. +C +C NBLCKS (output) INTEGER +C The number of diagonal blocks of the matrix A. +C +C BLSIZE (output) INTEGER array, dimension (N) +C The first NBLCKS elements of this array contain the orders +C of the resulting diagonal blocks of the matrix A. +C +C WR, (output) DOUBLE PRECISION arrays, dimension (N) +C WI These arrays contain the real and imaginary parts, +C respectively, of the eigenvalues of the matrix A. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in the ordering of the diagonal +C blocks of the real Schur form matrix. +C If the user sets TOL > 0, then the given value of TOL is +C used as an absolute tolerance: a block i and a temporarily +C fixed block 1 (the first block of the current trailing +C submatrix to be reduced) are considered to belong to the +C same cluster if their eigenvalues satisfy +C +C | lambda_1 - lambda_i | <= TOL. +C +C If the user sets TOL < 0, then the given value of TOL is +C used as a relative tolerance: a block i and a temporarily +C fixed block 1 are considered to belong to the same cluster +C if their eigenvalues satisfy, for j = 1, ..., N, +C +C | lambda_1 - lambda_i | <= | TOL | * max | lambda_j |. +C +C If the user sets TOL = 0, then an implicitly computed, +C default tolerance, defined by TOL = SQRT( SQRT( EPS ) ) +C is used instead, as a relative tolerance, where EPS is +C the machine precision (see LAPACK Library routine DLAMCH). +C If SORT = 'N' or 'C', this parameter is not referenced. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Consider first that SORT = 'N'. Let +C +C ( A A ) +C ( 11 12 ) +C A = ( ), +C ( 0 A ) +C ( 22 ) +C +C be the given matrix in real Schur form, where initially A is the +C 11 +C first diagonal block of dimension 1-by-1 or 2-by-2. An attempt is +C made to compute a transformation matrix X of the form +C +C ( I P ) +C X = ( ) (1) +C ( 0 I ) +C +C (partitioned as A), so that +C +C ( A 0 ) +C -1 ( 11 ) +C X A X = ( ), +C ( 0 A ) +C ( 22 ) +C +C and the elements of P do not exceed the value PMAX in magnitude. +C An adaptation of the standard method for solving Sylvester +C equations [1], which controls the magnitude of the individual +C elements of the computed solution [2], is used to obtain matrix P. +C When this attempt failed, an 1-by-1 (or 2-by-2) diagonal block of +C A , whose eigenvalue(s) is (are) the closest to the mean of those +C 22 +C of A is selected, and moved by orthogonal similarity +C 11 +C transformations in the leading position of A ; the moved diagonal +C 22 +C block is then added to the block A , increasing its order by 1 +C 11 +C (or 2). Another attempt is made to compute a suitable +C transformation matrix X with the new definitions of the blocks A +C 11 +C and A . After a successful transformation matrix X has been +C 22 +C obtained, it postmultiplies the current transformation matrix +C (if JOBX = 'U'), and the whole procedure is repeated for the +C matrix A . +C 22 +C +C When SORT = 'S', the diagonal blocks of the real Schur form are +C reordered before each step of the reduction, so that each cluster +C of eigenvalues, defined as specified in the definition of TOL, +C appears in adjacent blocks. The blocks for each cluster are merged +C together, and the procedure described above is applied to the +C larger blocks. Using the option SORT = 'S' will usually provide +C better efficiency than the standard option (SORT = 'N'), proposed +C in [2], because there could be no or few unsuccessful attempts +C to compute individual transformation matrices X of the form (1). +C However, the resulting dimensions of the blocks are usually +C larger; this could make subsequent calculations less efficient. +C +C When SORT = 'C' or 'B', the procedure is similar to that for +C SORT = 'N' or 'S', respectively, but the block of A whose +C 22 +C eigenvalue(s) is (are) the closest to those of A (not to their +C 11 +C mean) is selected and moved to the leading position of A . This +C 22 +C is called the "closest-neighbour" strategy. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Bavely, C. and Stewart, G.W. +C An Algorithm for Computing Reducing Subspaces by Block +C Diagonalization. +C SIAM J. Numer. Anal., 16, pp. 359-367, 1979. +C +C [3] Demmel, J. +C The Condition Number of Equivalence Transformations that +C Block Diagonalize Matrix Pencils. +C SIAM J. Numer. Anal., 20, pp. 599-610, 1983. +C +C NUMERICAL ASPECTS +C 3 4 +C The algorithm usually requires 0(N ) operations, but 0(N ) are +C possible in the worst case, when all diagonal blocks in the real +C Schur form of A are 1-by-1, and the matrix cannot be diagonalized +C by well-conditioned transformations. +C +C FURTHER COMMENTS +C +C The individual non-orthogonal transformation matrices used in the +C reduction of A to a block-diagonal form have condition numbers +C of the order PMAX*PMAX. This does not guarantee that their product +C is well-conditioned enough. The routine can be easily modified to +C provide estimates for the condition numbers of the clusters of +C eigenvalues. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C Partly based on the RASP routine BDIAG by A. Varga, German +C Aerospace Center, DLR Oberpfaffenhofen. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003. +C +C KEYWORDS +C +C Diagonalization, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBX, SORT + INTEGER INFO, LDA, LDX, N, NBLCKS + DOUBLE PRECISION PMAX, TOL +C .. Array Arguments .. + INTEGER BLSIZE(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), WI(*), WR(*), X(LDX,*) +C .. Local Scalars .. + LOGICAL LJOBX, LSORN, LSORS, LSORT + CHARACTER JOBV + INTEGER DA11, DA22, I, IERR, J, K, L, L11, L22, L22M1 + DOUBLE PRECISION C, CAV, D, EDIF, EMAX, RAV, SAFEMN, SC, THRESH +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 + EXTERNAL DLAMCH, DLAPY2, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DLABAD, DLASET, DSCAL, MA02AD, MB03QX, + $ MB03RX, MB03RY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LJOBX = LSAME( JOBX, 'U' ) + LSORN = LSAME( SORT, 'N' ) + LSORS = LSAME( SORT, 'S' ) + LSORT = LSAME( SORT, 'B' ) .OR. LSORS + IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSORN .AND. .NOT.LSORT .AND. + $ .NOT.LSAME( SORT, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( PMAX.LT.ONE ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( ( LDX.LT.1 ) .OR. ( LJOBX .AND. LDX.LT.N ) ) THEN + INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB03RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + NBLCKS = 0 + IF( N.EQ.0 ) + $ RETURN +C +C Set the "safe" minimum positive number with representable +C reciprocal, and set JOBV parameter for MB03RX routine. +C + SAFEMN = DLAMCH( 'Safe minimum' ) + SC = ONE / SAFEMN + CALL DLABAD( SAFEMN, SC ) + SAFEMN = SAFEMN / DLAMCH( 'Precision' ) + JOBV = JOBX + IF ( LJOBX ) + $ JOBV = 'V' +C +C Compute the eigenvalues of A and set the tolerance for reordering +C the eigenvalues in clusters, if needed. +C + CALL MB03QX( N, A, LDA, WR, WI, INFO ) +C + IF ( LSORT ) THEN + THRESH = ABS( TOL ) + IF ( THRESH.EQ.ZERO ) THEN +C +C Use the default tolerance in ordering the blocks. +C + THRESH = SQRT( SQRT( DLAMCH( 'Epsilon' ) ) ) + END IF +C + IF ( TOL.LE.ZERO ) THEN +C +C Use a relative tolerance. Find max | lambda_j |, j = 1 : N. +C + EMAX = ZERO + L = 1 +C WHILE ( L.LE.N ) DO + 10 IF ( L.LE.N ) THEN + IF ( WI(L).EQ.ZERO ) THEN + EMAX = MAX( EMAX, ABS( WR(L) ) ) + L = L + 1 + ELSE + EMAX = MAX( EMAX, DLAPY2( WR(L), WI(L) ) ) + L = L + 2 + END IF + GO TO 10 + END IF +C END WHILE 10 + THRESH = THRESH * EMAX + END IF + END IF +C +C Define the following submatrices of A: +C A11, the DA11-by-DA11 block in position (L11,L11); +C A22, the DA22-by-DA22 block in position (L22,L22); +C A12, the DA11-by-DA22 block in position (L11,L22); +C A21, the DA22-by-DA11 block in position (L22,L11) (null initially +C and finally). +C The following loop uses L11 as loop variable and try to separate a +C block in position (L11,L11), with possibly clustered eigenvalues, +C separated by the other eigenvalues (in the block A22). +C + L11 = 1 +C WHILE ( L11.LE.N ) DO + 20 IF ( L11.LE.N ) THEN + NBLCKS = NBLCKS + 1 + IF ( WI(L11).EQ.ZERO ) THEN + DA11 = 1 + ELSE + DA11 = 2 + END IF +C + IF ( LSORT ) THEN +C +C The following loop, using K as loop variable, finds the +C blocks whose eigenvalues are close to those of A11 and +C moves these blocks (if any) to the leading position of A22. +C + L22 = L11 + DA11 + K = L22 +C WHILE ( K.LE.N ) DO + 30 IF ( K.LE.N ) THEN + EDIF = DLAPY2( WR(L11) - WR(K), WI(L11) - WI(K) ) + IF ( EDIF.LE.THRESH ) THEN +C +C An 1x1 or a 2x2 block of A22 has been found so that +C +C abs( lambda_1 - lambda_k ) <= THRESH +C +C where lambda_1 and lambda_k denote an eigenvalue +C of A11 and of that block in A22, respectively. +C Try to move that block to the leading position of A22. +C + CALL MB03RX( JOBV, N, L22, K, A, LDA, X, LDX, WR, WI, + $ DWORK ) +C +C Extend A11 with the leading block of A22. +C + IF ( WI(L22).EQ.ZERO ) THEN + DA11 = DA11 + 1 + ELSE + DA11 = DA11 + 2 + END IF + L22 = L11 + DA11 + END IF + IF ( WI(K).EQ.ZERO ) THEN + K = K + 1 + ELSE + K = K + 2 + END IF + GO TO 30 + END IF +C END WHILE 30 + END IF +C +C The following loop uses L22 as loop variable and forms a +C separable DA11-by-DA11 block A11 in position (L11,L11). +C + L22 = L11 + DA11 + L22M1 = L22 - 1 +C WHILE ( L22.LE.N ) DO + 40 IF ( L22.LE.N ) THEN + DA22 = N - L22M1 +C +C Try to separate the block A11 of order DA11 by using a +C well-conditioned similarity transformation. +C +C First save A12' in the block A21. +C + CALL MA02AD( 'Full', DA11, DA22, A(L11,L22), LDA, + $ A(L22,L11), LDA ) +C +C Solve -A11*P + P*A22 = A12. +C + CALL MB03RY( DA11, DA22, PMAX, A(L11,L11), LDA, A(L22,L22), + $ LDA, A(L11,L22), LDA, IERR ) +C + IF ( IERR.EQ.1 ) THEN +C +C The annihilation of A12 failed. Restore A12 and A21. +C + CALL MA02AD( 'Full', DA22, DA11, A(L22,L11), LDA, + $ A(L11,L22), LDA ) + CALL DLASET( 'Full', DA22, DA11, ZERO, ZERO, A(L22,L11), + $ LDA ) +C + IF ( LSORN .OR. LSORS ) THEN +C +C Extend A11 with an 1x1 or 2x2 block of A22 having the +C nearest eigenvalues to the mean of eigenvalues of A11 +C and resume the loop. +C First compute the mean of eigenvalues of A11. +C + RAV = ZERO + CAV = ZERO +C + DO 50 I = L11, L22M1 + RAV = RAV + WR(I) + CAV = CAV + ABS( WI(I) ) + 50 CONTINUE +C + RAV = RAV/DA11 + CAV = CAV/DA11 +C +C Loop to find the eigenvalue of A22 nearest to the +C above computed mean. +C + D = DLAPY2( RAV-WR(L22), CAV-WI(L22) ) + K = L22 + IF ( WI(L22).EQ.ZERO ) THEN + L = L22 + 1 + ELSE + L = L22 + 2 + END IF +C WHILE ( L.LE.N ) DO + 60 IF ( L.LE.N ) THEN + C = DLAPY2( RAV-WR(L), CAV-WI(L) ) + IF ( C.LT.D ) THEN + D = C + K = L + END IF + IF ( WI(L).EQ.ZERO ) THEN + L = L + 1 + ELSE + L = L + 2 + END IF + GO TO 60 + END IF +C END WHILE 60 +C + ELSE +C +C Extend A11 with an 1x1 or 2x2 block of A22 having the +C nearest eigenvalues to the cluster of eigenvalues of +C A11 and resume the loop. +C +C Loop to find the eigenvalue of A22 of minimum distance +C to the cluster. +C + D = SC + L = L22 + K = L22 +C WHILE ( L.LE.N ) DO + 70 IF ( L.LE.N ) THEN + I = L11 +C WHILE ( I.LE.L22M1 ) DO + 80 IF ( I.LE.L22M1 ) THEN + C = DLAPY2( WR(I)-WR(L), WI(I)-WI(L) ) + IF ( C.LT.D ) THEN + D = C + K = L + END IF + IF ( WI(I).EQ.ZERO ) THEN + I = I + 1 + ELSE + I = I + 2 + END IF + GO TO 80 + END IF +C END WHILE 80 + IF ( WI(L).EQ.ZERO ) THEN + L = L + 1 + ELSE + L = L + 2 + END IF + GO TO 70 + END IF +C END WHILE 70 + END IF +C +C Try to move block found to the leading position of A22. +C + CALL MB03RX( JOBV, N, L22, K, A, LDA, X, LDX, WR, WI, + $ DWORK ) +C +C Extend A11 with the leading block of A22. +C + IF ( WI(L22).EQ.ZERO ) THEN + DA11 = DA11 + 1 + ELSE + DA11 = DA11 + 2 + END IF + L22 = L11 + DA11 + L22M1 = L22 - 1 + GO TO 40 + END IF + END IF +C END WHILE 40 +C + IF ( LJOBX ) THEN +C +C Accumulate the transformation in X. +C Only columns L22, ..., N are modified. +C + IF ( L22.LE.N ) + $ CALL DGEMM( 'No transpose', 'No transpose', N, DA22, + $ DA11, ONE, X(1,L11), LDX, A(L11,L22), LDA, + $ ONE, X(1,L22), LDX ) +C +C Scale to unity the (non-zero) columns of X which will be +C no more modified and transform A11 accordingly. +C + DO 90 J = L11, L22M1 + SC = DNRM2( N, X(1,J), 1 ) + IF ( SC.GT.SAFEMN ) THEN + CALL DSCAL( DA11, SC, A(J,L11), LDA ) + SC = ONE/SC + CALL DSCAL( N, SC, X(1,J), 1 ) + CALL DSCAL( DA11, SC, A(L11,J), 1 ) + END IF + 90 CONTINUE +C + END IF + IF ( L22.LE.N ) THEN +C +C Set A12 and A21 to zero. +C + CALL DLASET( 'Full', DA11, DA22, ZERO, ZERO, A(L11,L22), + $ LDA ) + CALL DLASET( 'Full', DA22, DA11, ZERO, ZERO, A(L22,L11), + $ LDA ) + END IF +C +C Store the orders of the diagonal blocks in BLSIZE. +C + BLSIZE(NBLCKS) = DA11 + L11 = L22 + GO TO 20 + END IF +C END WHILE 20 +C + RETURN +C *** Last line of MB03RD *** + END diff --git a/mex/sources/libslicot/MB03RX.f b/mex/sources/libslicot/MB03RX.f new file mode 100644 index 000000000..d7c582db5 --- /dev/null +++ b/mex/sources/libslicot/MB03RX.f @@ -0,0 +1,226 @@ + SUBROUTINE MB03RX( JOBV, N, KL, KU, A, LDA, X, LDX, WR, WI, + $ DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reorder the diagonal blocks of the principal submatrix between +C the indices KL and KU (KU >= KL) of a real Schur form matrix A +C together with their eigenvalues, using orthogonal similarity +C transformations, such that the block specified by KU is moved in +C the position KL. The transformations are optionally postmultiplied +C in a given matrix X. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBV CHARACTER*1 +C Specifies whether or not the transformations are +C accumulated, as follows: +C = 'N': The transformations are not accumulated; +C = 'V': The transformations are accumulated in X (the +C given matrix X is updated). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and X. N >= 0. +C +C KL (input) INTEGER +C The lower boundary index for the rows and columns of the +C principal submatrix of A whose diagonal blocks are to be +C reordered, and also the target position for the block to +C be moved. 1 <= KL <= KU <= N. +C +C KU (input/output) INTEGER +C On entry, KU specifies the upper boundary index for the +C rows and columns of the principal submatrix of A whose +C diagonal blocks are to be reordered, and also the original +C position for the block to be moved. 1 <= KL <= KU <= N. +C On exit, KU specifies the upper boundary index for the +C rows and columns of the principal submatrix of A whose +C diagonal blocks have been reordered. The given value will +C be increased by 1 if the moved block was 2-by-2 and it has +C been replaced by two 1-by-1 blocks. Otherwise, its input +C value is preserved. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A in real Schur canonical form. +C On exit, the leading N-by-N part of this array contains +C the ordered real Schur canonical form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, if JOBV = 'V', the leading N-by-N part of this +C array must contain a given matrix X. +C On exit, if JOBV = 'V', the leading N-by-N part of this +C array contains the product of the given matrix X and the +C transformation matrix that performed the reordering of A. +C If JOBV = 'N', this array is not referenced. +C +C LDX INTEGER +C The leading dimension of array X. +C LDX >= 1, if JOBV = 'N'; +C LDX >= MAX(1,N), if JOBV = 'V'. +C +C WR, (input/output) DOUBLE PRECISION arrays, dimension (N) +C WI On entry, these arrays must contain the real and imaginary +C parts, respectively, of the eigenvalues of the matrix A. +C On exit, these arrays contain the real and imaginary +C parts, respectively, of the eigenvalues of the matrix A, +C possibly reordered. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C METHOD +C +C An attempt is made to move the block in the position (KU,KU) to +C the position (KL,KL) by a sequence of orthogonal similarity +C transformations, each swapping two consecutive blocks. The +C standard algorithm [1], [2] usually succeeds to perform this +C reordering. A failure of this algorithm means that two consecutive +C blocks (one of them being the desired block possibly moved) are +C too close to swap. In such a case, the leading block of the two +C is tried to be moved in the position (KL,KL) and the procedure is +C repeated. +C +C REFERENCES +C +C [1] Stewart, G.W. +C HQR3 and EXCHQZ: FORTRAN subroutines for calculating and +C ordering the eigenvalues of a real upper Hessenberg matrix. +C ACM TOMS, 2, pp. 275-280, 1976. +C +C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable. If some eigenvalues are +C ill-conditioned, their returned values could differ much from +C their input values. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalue, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBV + INTEGER KL, KU, LDA, LDX, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), WI(*), WR(*), X(LDX,*) +C .. Local Scalars .. + INTEGER IERR, IFST, ILST, L +C .. External Subroutines .. + EXTERNAL DTREXC +C .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +C .. Executable Statements .. +C + IF ( KU.GT.KL ) THEN +C +C Try to move the block in position (KU,KU) to position (KL,KL). +C + IFST = KU +C REPEAT + 10 CONTINUE + ILST = KL + CALL DTREXC( JOBV, N, A, LDA, X, LDX, IFST, ILST, DWORK, IERR ) + IF ( IERR.NE.0 ) THEN +C +C During calculations, two adjacent blocks were too close +C to swap; the desired block cannot be moved further, but the +C block above it is suitable and is tried for moving. The +C number of repeat cycles is usually 1, and at most the number +C of blocks between the current position and the position KL. +C + IFST = ILST - 1 + IF ( IFST.GT.1 ) THEN + IF ( A(IFST,IFST-1).NE.ZERO ) + $ IFST = ILST - 2 + END IF + IF ( ILST.GT.KL ) + $ GO TO 10 + END IF +C UNTIL ( ILST.EQ.KL on output from DTREXC ) +C +C Recompute the eigenvalues for the modified part of A. +C Note that KU must be incremented if the moved block was 2-by-2 +C and it has been replaced by two 1-by-1 blocks. +C + IF ( WI(KU).NE.ZERO ) THEN + IF ( A(KU+1,KU).EQ.ZERO ) + $ KU = KU + 1 + END IF +C + L = KL +C WHILE ( L.LT.KU .OR. ( L.EQ.KU .AND. L.LT.N ) ) DO + 20 IF ( L.LT.KU .OR. ( L.EQ.KU .AND. L.LT.N ) ) THEN + IF ( A(L+1,L).NE.ZERO ) THEN +C +C A 2x2 block. +C + WR(L) = A(L,L) + WR(L+1) = WR(L) + WI(L) = SQRT( ABS( A(L,L+1) ) )* + $ SQRT( ABS( A(L+1,L) ) ) + WI(L+1) = -WI(L) + L = L + 2 + ELSE +C +C An 1x1 block. +C + WR(L) = A(L,L) + WI(L) = ZERO + L = L + 1 + END IF + GO TO 20 + ELSE IF ( L.EQ.N ) THEN + WR(L) = A(L,L) + WI(L) = ZERO + END IF +C END WHILE 20 + END IF +C + RETURN +C *** Last line of MB03RX *** + END diff --git a/mex/sources/libslicot/MB03RY.f b/mex/sources/libslicot/MB03RY.f new file mode 100644 index 000000000..550083136 --- /dev/null +++ b/mex/sources/libslicot/MB03RY.f @@ -0,0 +1,261 @@ + SUBROUTINE MB03RY( M, N, PMAX, A, LDA, B, LDB, C, LDC, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the Sylvester equation -AX + XB = C, where A and B are +C M-by-M and N-by-N matrices, respectively, in real Schur form. +C +C This routine is intended to be called only by SLICOT Library +C routine MB03RD. For efficiency purposes, the computations are +C aborted when the infinity norm of an elementary submatrix of X is +C greater than a given value PMAX. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A and the number of rows of the +C matrices C and X. M >= 0. +C +C N (input) INTEGER +C The order of the matrix B and the number of columns of the +C matrices C and X. N >= 0. +C +C PMAX (input) DOUBLE PRECISION +C An upper bound for the infinity norm of an elementary +C submatrix of X (see METHOD). +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain the +C matrix A of the Sylvester equation, in real Schur form. +C The elements below the real Schur form are not referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain the +C matrix B of the Sylvester equation, in real Schur form. +C The elements below the real Schur form are not referenced. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix C of the Sylvester equation. +C On exit, if INFO = 0, the leading M-by-N part of this +C array contains the solution matrix X of the Sylvester +C equation, and each elementary submatrix of X (see METHOD) +C has the infinity norm less than or equal to PMAX. +C On exit, if INFO = 1, the solution matrix X has not been +C computed completely, because an elementary submatrix of X +C had the infinity norm greater than PMAX. Part of the +C matrix C has possibly been overwritten with the +C corresponding part of X. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: an elementary submatrix of X had the infinity norm +C greater than the given value PMAX. +C +C METHOD +C +C The routine uses an adaptation of the standard method for solving +C Sylvester equations [1], which controls the magnitude of the +C individual elements of the computed solution [2]. The equation +C -AX + XB = C can be rewritten as +C p l-1 +C -A X + X B = C + sum A X - sum X B +C kk kl kl ll kl i=k+1 ki il j=1 kj jl +C +C for l = 1:q, and k = p:-1:1, where A , B , C , and X , are +C kk ll kl kl +C block submatrices defined by the partitioning induced by the Schur +C form of A and B, and p and q are the numbers of the diagonal +C blocks of A and B, respectively. So, the elementary submatrices of +C X are found block column by block column, starting from the +C bottom. If any such elementary submatrix has the infinity norm +C greater than the given value PMAX, the calculations are ended. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Bavely, C. and Stewart, G.W. +C An Algorithm for Computing Reducing Subspaces by Block +C Diagonalization. +C SIAM J. Numer. Anal., 16, pp. 359-367, 1979. +C +C NUMERICAL ASPECTS +C 2 2 +C The algorithm requires 0(M N + MN ) operations. +C +C FURTHER COMMENTS +C +C Let +C +C ( A C ) ( I X ) +C M = ( ), Y = ( ). +C ( 0 B ) ( 0 I ) +C +C Then +C +C -1 ( A 0 ) +C Y M Y = ( ), +C ( 0 B ) +C +C hence Y is an non-orthogonal transformation matrix which performs +C the reduction of M to a block-diagonal form. Bounding a norm of +C X is equivalent to setting an upper bound to the condition number +C of the transformation matrix Y. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C Based on the RASP routine SYLSM by A. Varga, German Aerospace +C Center, DLR Oberpfaffenhofen. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Diagonalization, real Schur form, Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, M, N + DOUBLE PRECISION PMAX +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*) +C .. Local Scalars .. + INTEGER DK, DL, I, IERR, J, K, KK, KK1, L, LL, LM1 + DOUBLE PRECISION PNORM, SCALE +C .. Local Arrays .. + DOUBLE PRECISION P(4) +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL DGEMM, DGEMV, DLASY2 +C .. Executable Statements .. +C +C For efficiency reasons, this routine does not check the input +C parameters for errors. +C + INFO = 0 +C +C Column loop indexed by L. +C + L = 1 +C WHILE ( L.LE.N ) DO + 10 IF ( L.LE.N ) THEN + LM1 = L - 1 + DL = 1 + IF ( L.LT.N ) THEN + IF ( B(L+1,L).NE.ZERO ) + $ DL = 2 + ENDIF + LL = LM1 + DL + IF ( LM1.GT.0 ) THEN +C +C Update one (or two) column(s) of C. +C + IF ( DL.EQ.2 ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, DL, LM1, + $ -ONE, C, LDC, B(1,L), LDB, ONE, C(1,L), LDC ) + ELSE + CALL DGEMV( 'No transpose', M, LM1, -ONE, C, LDC, B(1,L), + $ 1, ONE, C(1,L), 1 ) + END IF + ENDIF +C +C Row loop indexed by KK. +C + KK = M +C WHILE ( KK.GE.1 ) DO + 20 IF ( KK.GE.1 ) THEN + KK1 = KK + 1 + DK = 1 + IF ( KK.GT.1 ) THEN + IF ( A(KK,KK-1).NE.ZERO ) + $ DK = 2 + ENDIF + K = KK1 - DK + IF ( K.LT.M ) THEN +C +C Update an elementary submatrix of C. +C + DO 40 J = L, LL +C + DO 30 I = K, KK + C(I,J) = C(I,J) + + $ DDOT( M-KK, A(I,KK1), LDA, C(KK1,J), 1 ) + 30 CONTINUE +C + 40 CONTINUE +C + ENDIF + CALL DLASY2( .FALSE., .FALSE., -1, DK, DL, A(K,K), LDA, + $ B(L,L), LDB, C(K,L), LDC, SCALE, P, DK, PNORM, + $ IERR ) + IF( SCALE.NE.ONE .OR. PNORM.GT.PMAX ) THEN + INFO = 1 + RETURN + END IF + C(K,L) = -P(1) + IF ( DL.EQ.1 ) THEN + IF ( DK.EQ.2 ) + $ C(KK,L) = -P(2) + ELSE + IF ( DK.EQ.1 ) THEN + C(K,LL) = -P(2) + ELSE + C(KK,L) = -P(2) + C(K,LL) = -P(3) + C(KK,LL) = -P(4) + ENDIF + ENDIF + KK = KK - DK + GO TO 20 + END IF +C END WHILE 20 + L = L + DL + GO TO 10 + END IF +C END WHILE 10 + RETURN +C *** Last line of MB03RY *** + END diff --git a/mex/sources/libslicot/MB03SD.f b/mex/sources/libslicot/MB03SD.f new file mode 100644 index 000000000..679396e77 --- /dev/null +++ b/mex/sources/libslicot/MB03SD.f @@ -0,0 +1,348 @@ + SUBROUTINE MB03SD( JOBSCL, N, A, LDA, QG, LDQG, WR, WI, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the eigenvalues of an N-by-N square-reduced Hamiltonian +C matrix +C +C ( A' G' ) +C H' = ( T ). (1) +C ( Q' -A' ) +C +C Here, A' is an N-by-N matrix, and G' and Q' are symmetric N-by-N +C matrices. It is assumed without a check that H' is square- +C reduced, i.e., that +C +C 2 ( A'' G'' ) +C H' = ( T ) with A'' upper Hessenberg. (2) +C ( 0 A'' ) +C +C T 2 +C (Equivalently, Q'A'- A' Q' = 0, A'' = A' + G'Q', and for i > j+1, +C A''(i,j) = 0.) Ordinarily, H' is the output from SLICOT Library +C routine MB04ZD. The eigenvalues of H' are computed as the square +C roots of the eigenvalues of A''. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBSCL CHARACTER*1 +C Specifies whether or not balancing operations should +C be performed by the LAPACK subroutine DGEBAL on the +C Hessenberg matrix A'' in (2), as follows: +C = 'N': do not use balancing; +C = 'S': do scaling in order to equilibrate the rows +C and columns of A''. +C See LAPACK subroutine DGEBAL and Section METHOD below. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, G, and Q. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C upper left block A' of the square-reduced Hamiltonian +C matrix H' in (1), as produced by SLICOT Library routine +C MB04ZD. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C QG (input) DOUBLE PRECISION array, dimension (LDQG,N+1) +C The leading N-by-N lower triangular part of this array +C must contain the lower triangle of the lower left +C symmetric block Q' of the square-reduced Hamiltonian +C matrix H' in (1), and the N-by-N upper triangular part of +C the submatrix in the columns 2 to N+1 of this array must +C contain the upper triangle of the upper right symmetric +C block G' of the square-reduced Hamiltonian matrix H' +C in (1), as produced by SLICOT Library routine MB04ZD. +C So, if i >= j, then Q'(i,j) is stored in QG(i,j) and +C G'(i,j) is stored in QG(j,i+1). +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= MAX(1,N). +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C The arrays WR and WI contain the real and imaginary parts, +C respectively, of the N eigenvalues of H' with non-negative +C real part. The remaining N eigenvalues are the negatives +C of these eigenvalues. +C Eigenvalues are stored in WR and WI in decreasing order of +C magnitude of the real parts, i.e., WR(I) >= WR(I+1). +C (In particular, an eigenvalue closest to the imaginary +C axis is WR(N)+WI(N)i.) +C In addition, eigenvalues with zero real part are sorted in +C decreasing order of magnitude of imaginary parts. Note +C that non-real eigenvalues with non-zero real part appear +C in complex conjugate pairs, but eigenvalues with zero real +C part do not, in general, appear in complex conjugate +C pairs. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= MAX(1,N*(N+1)). +C For good performance, LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, then the i-th argument had an illegal +C value; +C > 0: if INFO = i, i <= N, then LAPACK subroutine DHSEQR +C failed to converge while computing the i-th +C eigenvalue. +C +C METHOD +C +C The routine forms the upper Hessenberg matrix A'' in (2) and calls +C LAPACK subroutines to calculate its eigenvalues. The eigenvalues +C of H' are the square roots of the eigenvalues of A''. +C +C REFERENCES +C +C [1] Van Loan, C. F. +C A Symplectic Method for Approximating All the Eigenvalues of +C a Hamiltonian Matrix. +C Linear Algebra and its Applications, 61, pp. 233-251, 1984. +C +C [2] Byers, R. +C Hamiltonian and Symplectic Algorithms for the Algebraic +C Riccati Equation. +C Ph. D. Thesis, Cornell University, Ithaca, NY, January 1983. +C +C [3] Benner, P., Byers, R., and Barth, E. +C Fortran 77 Subroutines for Computing the Eigenvalues of +C Hamiltonian Matrices. I: The Square-Reduced Method. +C ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000. +C +C NUMERICAL ASPECTS +C +C The algorithm requires (32/3)*N**3 + O(N**2) floating point +C operations. +C Eigenvalues computed by this subroutine are exact eigenvalues +C of a perturbed Hamiltonian matrix H' + E where +C +C || E || <= c sqrt(eps) || H' ||, +C +C c is a modest constant depending on the dimension N and eps is the +C machine precision. Moreover, if the norm of H' and an eigenvalue +C are of roughly the same magnitude, the computed eigenvalue is +C essentially as accurate as the computed eigenvalue obtained by +C traditional methods. See [1] or [2]. +C +C CONTRIBUTOR +C +C P. Benner, Universitaet Bremen, Germany, and +C R. Byers, University of Kansas, Lawrence, USA. +C Aug. 1998, routine DHAEVS. +C V. Sima, Research Institute for Informatics, Bucharest, Romania, +C Oct. 1998, SLICOT Library version. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2002, +C May 2009. +C +C KEYWORDS +C +C Eigenvalues, (square-reduced) Hamiltonian matrix, symplectic +C similarity transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDQG, LDWORK, N + CHARACTER JOBSCL +C .. +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*), WI(*), WR(*) +C .. +C .. Local Scalars .. + DOUBLE PRECISION SWAP, X, Y + INTEGER BL, CHUNK, I, IGNORE, IHI, ILO, J, JW, JWORK, M, + $ N2 + LOGICAL BLAS3, BLOCK, SCALE, SORTED +C .. +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1) +C .. +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DLASET, + $ DSYMM, DSYMV, MA01AD, MA02ED, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C + INFO = 0 + N2 = N*N + SCALE = LSAME( JOBSCL, 'S' ) + IF ( .NOT. ( SCALE .OR. LSAME( JOBSCL, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDQG.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDWORK.LT.MAX( 1, N2 + N ) ) THEN + INFO = -10 + END IF +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03SD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + CHUNK = ( LDWORK - N2 ) / N + BLOCK = MIN( CHUNK, N ).GT.1 + BLAS3 = CHUNK.GE.N +C + IF ( BLAS3 ) THEN + JWORK = N2 + 1 + ELSE + JWORK = 1 + END IF +C 2 +C Form the matrix A'' = A' + G'Q'. +C + CALL DLACPY( 'Lower', N, N, QG, LDQG, DWORK(JWORK), N ) + CALL MA02ED( 'Lower', N, DWORK(JWORK), N ) +C + IF ( BLAS3 ) THEN +C +C Use BLAS 3 calculation. +C + CALL DSYMM( 'Left', 'Upper', N, N, ONE, QG(1, 2), LDQG, + $ DWORK(JWORK), N, ZERO, DWORK, N ) +C + ELSE IF ( BLOCK ) THEN + JW = N2 + 1 +C +C Use BLAS 3 for as many columns of Q' as possible. +C + DO 10 J = 1, N, CHUNK + BL = MIN( N-J+1, CHUNK ) + CALL DSYMM( 'Left', 'Upper', N, BL, ONE, QG(1, 2), LDQG, + $ DWORK(1+N*(J-1)), N, ZERO, DWORK(JW), N ) + CALL DLACPY( 'Full', N, BL, DWORK(JW), N, DWORK(1+N*(J-1)), + $ N ) + 10 CONTINUE +C + ELSE +C +C Use BLAS 2 calculation. +C + DO 20 J = 1, N + CALL DSYMV( 'Upper', N, ONE, QG(1, 2), LDQG, + $ DWORK(1+N*(J-1)), 1, ZERO, WR, 1 ) + CALL DCOPY( N, WR, 1, DWORK(1+N*(J-1)), 1 ) + 20 CONTINUE +C + END IF +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, A, LDA, A, + $ LDA, ONE, DWORK, N ) + IF ( SCALE .AND. N.GT.2 ) + $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, DWORK(3), N ) +C 2 +C Find the eigenvalues of A' + G'Q'. +C + CALL DGEBAL( JOBSCL, N, DWORK, N, ILO, IHI, DWORK(1+N2), IGNORE ) + CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI, DWORK, + $ N, WR, WI, DUMMY, 1, DWORK(1+N2), N, INFO ) + IF ( INFO.EQ.0 ) THEN +C +C Eigenvalues of H' are the square roots of those computed above. +C + DO 30 I = 1, N + X = WR(I) + Y = WI(I) + CALL MA01AD( X, Y, WR(I), WI(I) ) + 30 CONTINUE +C +C Sort eigenvalues into decreasing order by real part and, for +C eigenvalues with zero real part only, decreasing order of +C imaginary part. (This simple bubble sort preserves the +C relative order of eigenvalues with equal but nonzero real part. +C This ensures that complex conjugate pairs remain +C together.) +C + SORTED = .FALSE. +C + DO 50 M = N, 1, -1 + IF ( SORTED ) GO TO 60 + SORTED = .TRUE. +C + DO 40 I = 1, M - 1 + IF ( ( ( WR(I).LT.WR(I+1) ) .OR. + $ ( ( WR(I).EQ.ZERO ) .AND. ( WR(I+1).EQ.ZERO ) .AND. + $ ( WI(I).LT.WI(I+1) ) ) ) ) THEN + SWAP = WR(I) + WR(I) = WR(I+1) + WR(I+1) = SWAP + SWAP = WI(I) + WI(I) = WI(I+1) + WI(I+1) = SWAP +C + SORTED = .FALSE. +C + END IF + 40 CONTINUE +C + 50 CONTINUE +C + 60 CONTINUE +C + END IF +C + DWORK(1) = 2*N2 + RETURN +C *** Last line of MB03SD *** + END diff --git a/mex/sources/libslicot/MB03TD.f b/mex/sources/libslicot/MB03TD.f new file mode 100644 index 000000000..05561446d --- /dev/null +++ b/mex/sources/libslicot/MB03TD.f @@ -0,0 +1,641 @@ + SUBROUTINE MB03TD( TYP, COMPU, SELECT, LOWER, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, WR, WI, M, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reorder a matrix X in skew-Hamiltonian Schur form: +C +C [ A G ] T +C X = [ T ], G = -G, +C [ 0 A ] +C +C or in Hamiltonian Schur form: +C +C [ A G ] T +C X = [ T ], G = G, +C [ 0 -A ] +C +C where A is in upper quasi-triangular form, so that a selected +C cluster of eigenvalues appears in the leading diagonal blocks +C of the matrix A (in X) and the leading columns of [ U1; -U2 ] form +C an orthonormal basis for the corresponding right invariant +C subspace. +C +C If X is skew-Hamiltonian, then each eigenvalue appears twice; one +C copy corresponds to the j-th diagonal element and the other to the +C (n+j)-th diagonal element of X. The logical array LOWER controls +C which copy is to be reordered to the leading part of A. +C +C If X is Hamiltonian then the eigenvalues appear in pairs +C (lambda,-lambda); lambda corresponds to the j-th diagonal +C element and -lambda to the (n+j)-th diagonal element of X. +C The logical array LOWER controls whether lambda or -lambda is to +C be reordered to the leading part of A. +C +C The matrix A must be in Schur canonical form (as returned by the +C LAPACK routine DHSEQR), that is, block upper triangular with +C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has +C its diagonal elements equal and its off-diagonal elements of +C opposite sign. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYP CHARACTER*1 +C Specifies the type of the input matrix X: +C = 'S': X is skew-Hamiltonian; +C = 'H': X is Hamiltonian. +C +C COMPU CHARACTER*1 +C = 'U': update the matrices U1 and U2 containing the +C Schur vectors; +C = 'N': do not update U1 and U2. +C +C SELECT (input/output) LOGICAL array, dimension (N) +C SELECT specifies the eigenvalues in the selected cluster. +C To select a real eigenvalue w(j), SELECT(j) must be set +C to .TRUE.. To select a complex conjugate pair of +C eigenvalues w(j) and w(j+1), corresponding to a 2-by-2 +C diagonal block, both SELECT(j) and SELECT(j+1) must be set +C to .TRUE.; a complex conjugate pair of eigenvalues must be +C either both included in the cluster or both excluded. +C +C LOWER (input/output) LOGICAL array, dimension (N) +C LOWER controls which copy of a selected eigenvalue is +C included in the cluster. If SELECT(j) is set to .TRUE. +C for a real eigenvalue w(j); then LOWER(j) must be set to +C .TRUE. if the eigenvalue corresponding to the (n+j)-th +C diagonal element of X is to be reordered to the leading +C part; and LOWER(j) must be set to .FALSE. if the +C eigenvalue corresponding to the j-th diagonal element of +C X is to be reordered to the leading part. Similarly, for +C a complex conjugate pair of eigenvalues w(j) and w(j+1), +C both LOWER(j) and LOWER(j+1) must be set to .TRUE. if the +C eigenvalues corresponding to the (n+j:n+j+1,n+j:n+j+1) +C diagonal block of X are to be reordered to the leading +C part. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the upper quasi-triangular matrix A in Schur +C canonical form. +C On exit, the leading N-by-N part of this array contains +C the reordered matrix A, again in Schur canonical form, +C with the selected eigenvalues in the diagonal blocks. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) +C On entry, if TYP = 'S', the leading N-by-N part of this +C array must contain the strictly upper triangular part of +C the skew-symmetric matrix G. The rest of this array is not +C referenced. +C On entry, if TYP = 'H', the leading N-by-N part of this +C array must contain the upper triangular part of the +C symmetric matrix G. The rest of this array is not +C referenced. +C On exit, if TYP = 'S', the leading N-by-N part of this +C array contains the strictly upper triangular part of the +C skew-symmetric matrix G, updated by the orthogonal +C symplectic transformation which reorders X. +C On exit, if TYP = 'H', the leading N-by-N part of this +C array contains the upper triangular part of the symmetric +C matrix G, updated by the orthogonal symplectic +C transformation which reorders X. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= MAX(1,N). +C +C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) +C On entry, if COMPU = 'U', the leading N-by-N part of this +C array must contain U1, the (1,1) block of an orthogonal +C symplectic matrix U = [ U1, U2; -U2, U1 ]. +C On exit, if COMPU = 'U', the leading N-by-N part of this +C array contains the (1,1) block of the matrix U, +C postmultiplied by the orthogonal symplectic transformation +C which reorders X. The leading M columns of U form an +C orthonormal basis for the specified invariant subspace. +C If COMPU = 'N', this array is not referenced. +C +C LDU1 INTEGER +C The leading dimension of the array U1. +C LDU1 >= MAX(1,N), if COMPU = 'U'; +C LDU1 >= 1, otherwise. +C +C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) +C On entry, if COMPU = 'U', the leading N-by-N part of this +C array must contain U2, the (1,2) block of an orthogonal +C symplectic matrix U = [ U1, U2; -U2, U1 ]. +C On exit, if COMPU = 'U', the leading N-by-N part of this +C array contains the (1,2) block of the matrix U, +C postmultiplied by the orthogonal symplectic transformation +C which reorders X. +C If COMPU = 'N', this array is not referenced. +C +C LDU2 INTEGER +C The leading dimension of the array U2. +C LDU2 >= MAX(1,N), if COMPU = 'U'; +C LDU2 >= 1, otherwise. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C The real and imaginary parts, respectively, of the +C reordered eigenvalues of A. The eigenvalues are stored +C in the same order as on the diagonal of A, with +C WR(i) = A(i,i) and, if A(i:i+1,i:i+1) is a 2-by-2 diagonal +C block, WI(i) > 0 and WI(i+1) = -WI(i). Note that if an +C eigenvalue is sufficiently ill-conditioned, then its value +C may differ significantly from its value before reordering. +C +C M (output) INTEGER +C The dimension of the specified invariant subspace. +C 0 <= M <= N. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -18, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C = 1: reordering of X failed because some eigenvalue pairs +C are too close to separate (the problem is very +C ill-conditioned); X may have been partially +C reordered, and WR and WI contain the eigenvalues in +C the same order as in X. +C +C REFERENCES +C +C [1] Bai, Z. and Demmel, J.W. +C On Swapping Diagonal Blocks in Real Schur Form. +C Linear Algebra Appl., 186, pp. 73-95, 1993. +C +C [2] Benner, P., Kressner, D., and Mehrmann, V. +C Skew-Hamiltonian and Hamiltonian Eigenvalue Problems: Theory, +C Algorithms and Applications. Techn. Report, TU Berlin, 2003. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAORD). +C +C KEYWORDS +C +C Hamiltonian matrix, skew-Hamiltonian matrix, invariant subspace. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER COMPU, TYP + INTEGER INFO, LDA, LDG, LDU1, LDU2, LDWORK, M, N +C .. Array Arguments .. + LOGICAL LOWER(*), SELECT(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), U1(LDU1,*), + $ U2(LDU2,*), WI(*), WR(*) +C .. Local Scalars .. + LOGICAL FLOW, ISHAM, PAIR, SWAP, WANTU + INTEGER HERE, IERR, IFST, ILST, K, KS, NBF, NBL, NBNEXT, + $ WRKMIN +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL MB03TS, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C +C Decode and check input parameters. +C + ISHAM = LSAME( TYP, 'H' ) + WANTU = LSAME( COMPU, 'U' ) + WRKMIN = MAX( 1, N ) + INFO = 0 + IF ( .NOT.ISHAM .AND. .NOT.LSAME( TYP, 'S' ) ) THEN + INFO = -1 + ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( COMPU, 'N' ) ) THEN + INFO = -2 + ELSE IF ( N.LT.0 ) THEN + INFO = -5 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. LDU1.LT.N ) ) THEN + INFO = -11 + ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. LDU2.LT.N ) ) THEN + INFO = -13 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + INFO = -18 + DWORK(1) = DBLE( WRKMIN ) + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03TD', -INFO ) + RETURN + END IF +C +C Set M to the dimension of the specified invariant subspace. +C + M = 0 + PAIR = .FALSE. + DO 10 K = 1, N + IF ( PAIR ) THEN + PAIR = .FALSE. + ELSE + IF ( K.LT.N ) THEN + IF ( A(K+1,K).EQ.ZERO ) THEN + IF ( SELECT(K) ) + $ M = M + 1 + ELSE + PAIR = .TRUE. + IF ( SELECT(K) .OR. SELECT(K+1) ) + $ M = M + 2 + END IF + ELSE + IF ( SELECT(N) ) + $ M = M + 1 + END IF + END IF + 10 CONTINUE +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Collect the selected blocks at the top-left corner of X. +C + KS = 0 + PAIR = .FALSE. + DO 60 K = 1, N + IF ( PAIR ) THEN + PAIR = .FALSE. + ELSE + SWAP = SELECT(K) + FLOW = LOWER(K) + IF ( K.LT.N ) THEN + IF ( A(K+1,K).NE.ZERO ) THEN + PAIR = .TRUE. + SWAP = SWAP.OR.SELECT(K+1) + FLOW = FLOW.OR.LOWER(K+1) + END IF + END IF +C + IF ( PAIR ) THEN + NBF = 2 + ELSE + NBF = 1 + END IF +C + IF ( SWAP ) THEN + KS = KS + 1 + IF ( FLOW ) THEN +C +C Step 1: Swap the K-th block to position N. +C + IFST = K + ILST = N + NBL = 1 + IF ( ILST.GT.1 ) THEN + IF ( A(ILST,ILST-1).NE.ZERO ) THEN + ILST = ILST - 1 + NBL = 2 + END IF + END IF +C +C Update ILST. +C + IF ( NBF.EQ.2 .AND. NBL.EQ.1 ) + $ ILST = ILST - 1 + IF ( NBF.EQ.1 .AND. NBL.EQ.2 ) + $ ILST = ILST + 1 +C + IF ( ILST.EQ.IFST ) + $ GO TO 30 +C + HERE = IFST +C + 20 CONTINUE +C +C Swap block with next one below. +C + IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN +C +C Current block is either 1-by-1 or 2-by-2. +C + NBNEXT = 1 + IF ( HERE+NBF+1.LE.N ) THEN + IF ( A(HERE+NBF+1,HERE+NBF).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, + $ LDU1, U2, LDU2, HERE, NBF, NBNEXT, + $ DWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + GO TO 70 + END IF + HERE = HERE + NBNEXT +C +C Test if 2-by-2 block breaks into two 1-by-1 blocks. +C + IF ( NBF.EQ.2 ) THEN + IF ( A(HERE+1,HERE).EQ.ZERO ) + $ NBF = 3 + END IF +C + ELSE +C +C Current block consists of two 1-by-1 blocks each of +C which must be swapped individually. +C + NBNEXT = 1 + IF ( HERE+3.LE.N ) THEN + IF ( A(HERE+3,HERE+2).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, + $ LDU1, U2, LDU2, HERE+1, 1, NBNEXT, + $ DWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + GO TO 70 + END IF + IF ( NBNEXT.EQ.1 ) THEN +C +C Swap two 1-by-1 blocks, no problems possible. +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, HERE, 1, + $ NBNEXT, DWORK, IERR ) + HERE = HERE + 1 + ELSE +C +C Recompute NBNEXT in case 2 by 2 split. +C + IF ( A(HERE+2,HERE+1).EQ.ZERO ) + $ NBNEXT = 1 + IF ( NBNEXT.EQ.2 ) THEN +C +C 2-by-2 block did not split +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, HERE, 1, + $ NBNEXT, DWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + GO TO 70 + END IF + HERE = HERE + 2 + ELSE +C +C 2-by-2 block did split +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, HERE, 1, 1, + $ DWORK, IERR ) + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, HERE+1, 1, + $ 1, DWORK, IERR ) + HERE = HERE + 2 + END IF + END IF + END IF + IF ( HERE.LT.ILST ) + $ GO TO 20 +C + 30 CONTINUE +C +C Step 2: Apply an orthogonal symplectic transformation +C to swap the last blocks in A and -A' (or A'). +C + IF ( NBF.EQ.1 ) THEN +C +C Exchange columns/rows N <-> 2*N. No problems +C possible. +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, N, 1, 1, + $ DWORK, IERR ) +C + ELSE IF ( NBF.EQ.2 ) THEN +C +C Swap last block with its equivalent by an +C orthogonal symplectic transformation. +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, N-1, 2, 2, + $ DWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + GO TO 70 + END IF +C +C Test if 2-by-2 block breaks into two 1-by-1 blocks. +C + IF ( A(N-1,N).EQ.ZERO ) + $ NBF = 3 + ELSE +C +C Block did split. Swap (N-1)-th and N-th elements +C consecutively by symplectic generalized +C permutations and one rotation. +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, + $ LDU1, U2, LDU2, N, 1, 1, DWORK, IERR ) + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, + $ LDU1, U2, LDU2, N-1, 1, 1, DWORK, + $ IERR ) + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, + $ LDU1, U2, LDU2, N, 1, 1, DWORK, IERR ) + END IF + IFST = N + IF ( PAIR ) + $ IFST = N-1 + ELSE + IFST = K + END IF +C +C Step 3: Swap the K-th / N-th block to position KS. +C + ILST = KS + NBL = 1 + IF ( ILST.GT.1 ) THEN + IF ( A(ILST,ILST-1).NE.ZERO ) THEN + ILST = ILST - 1 + NBL = 2 + END IF + END IF +C + IF ( ILST.EQ.IFST ) + $ GO TO 50 +C + HERE = IFST + 40 CONTINUE +C +C Swap block with next one above. +C + IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN +C +C Current block either 1 by 1 or 2 by 2. +C + NBNEXT = 1 + IF ( HERE.GE.3 ) THEN + IF ( A(HERE-1,HERE-2).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, + $ LDU1, U2, LDU2, HERE-NBNEXT, NBNEXT, + $ NBF, DWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + GO TO 70 + END IF + HERE = HERE - NBNEXT +C +C Test if 2-by-2 block breaks into two 1-by-1 blocks. +C + IF ( NBF.EQ.2 ) THEN + IF ( A(HERE+1,HERE).EQ.ZERO ) + $ NBF = 3 + END IF +C + ELSE +C +C Current block consists of two 1 by 1 blocks each of +C which must be swapped individually. +C + NBNEXT = 1 + IF ( HERE.GE.3 ) THEN + IF ( A(HERE-1,HERE-2).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, + $ LDU1, U2, LDU2, HERE-NBNEXT, NBNEXT, + $ 1, DWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + GO TO 70 + END IF + IF ( NBNEXT.EQ.1 ) THEN +C +C Swap two 1-by-1 blocks, no problems possible. +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, + $ LDU1, U2, LDU2, HERE, NBNEXT, 1, + $ DWORK, IERR ) + + HERE = HERE - 1 + ELSE +C +C Recompute NBNEXT in case 2-by-2 split. +C + IF ( A(HERE,HERE-1).EQ.ZERO ) + $ NBNEXT = 1 + IF ( NBNEXT.EQ.2 ) THEN +C +C 2-by-2 block did not split +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, HERE-1, 2, 1, + $ DWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + GO TO 70 + END IF + HERE = HERE - 2 + ELSE +C +C 2-by-2 block did split +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, HERE, 1, 1, + $ DWORK, IERR ) + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, HERE-1, 1, 1, + $ DWORK, IERR ) + HERE = HERE - 2 + END IF + END IF + END IF +C + IF ( HERE.GT.ILST ) + $ GO TO 40 +C + 50 CONTINUE + IF ( PAIR ) + $ KS = KS + 1 + END IF + END IF + 60 CONTINUE +C + 70 CONTINUE +C +C Store eigenvalues. +C + DO 80 K = 1, N + WR(K) = A(K,K) + WI(K) = ZERO + 80 CONTINUE + DO 90 K = 1, N - 1 + IF ( A(K+1,K).NE.ZERO ) THEN + WI(K) = SQRT( ABS( A(K,K+1) ) )* + $ SQRT( ABS( A(K+1,K) ) ) + WI(K+1) = -WI(K) + END IF + 90 CONTINUE +C + DWORK(1) = DBLE( WRKMIN ) +C + RETURN +C *** Last line of MB03TD *** + END diff --git a/mex/sources/libslicot/MB03TS.f b/mex/sources/libslicot/MB03TS.f new file mode 100644 index 000000000..202e72f5b --- /dev/null +++ b/mex/sources/libslicot/MB03TS.f @@ -0,0 +1,746 @@ + SUBROUTINE MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, LDU1, U2, + $ LDU2, J1, N1, N2, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To swap diagonal blocks A11 and A22 of order 1 or 2 in the upper +C quasi-triangular matrix A contained in a skew-Hamiltonian matrix +C +C [ A G ] T +C X = [ T ], G = -G, +C [ 0 A ] +C +C or in a Hamiltonian matrix +C +C [ A G ] T +C X = [ T ], G = G. +C [ 0 -A ] +C +C This routine is a modified version of the LAPACK subroutine +C DLAEX2. +C +C The matrix A must be in Schur canonical form (as returned by the +C LAPACK routine DHSEQR), that is, block upper triangular with +C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has +C its diagonal elements equal and its off-diagonal elements of +C opposite sign. +C +C ARGUMENTS +C +C Mode Parameters +C +C ISHAM LOGIGAL +C Specifies the type of X: +C = .TRUE.: X is a Hamiltonian matrix; +C = .FALSE.: X is a skew-Hamiltonian matrix. +C +C WANTU LOGIGAL +C = .TRUE.: update the matrices U1 and U2 containing the +C Schur vectors; +C = .FALSE.: do not update U1 and U2. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the upper quasi-triangular matrix A, in Schur +C canonical form. +C On exit, the leading N-by-N part of this array contains +C the reordered matrix A, again in Schur canonical form. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) +C On entry, the leading N-by-N part of this array must +C contain the upper triangular part of the symmetric +C matrix G, if ISHAM = .TRUE., or the strictly upper +C triangular part of the skew-symmetric matrix G, otherwise. +C The rest of this array is not referenced. +C On exit, the leading N-by-N part of this array contains +C the upper or strictly upper triangular part of the +C symmetric or skew-symmetric matrix G, respectively, +C updated by the orthogonal transformation which reorders A. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= MAX(1,N). +C +C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) +C On entry, if WANTU = .TRUE., the leading N-by-N part of +C this array must contain the matrix U1. +C On exit, if WANTU = .TRUE., the leading N-by-N part of +C this array contains U1, postmultiplied by the orthogonal +C transformation which reorders A. See the description in +C the SLICOT subroutine MB03TD for further details. +C If WANTU = .FALSE., this array is not referenced. +C +C LDU1 INTEGER +C The leading dimension of the array U1. +C LDU1 >= MAX(1,N), if WANTU = .TRUE.; +C LDU1 >= 1, otherwise. +C +C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) +C On entry, if WANTU = .TRUE., the leading N-by-N part of +C this array must contain the matrix U2. +C On exit, if WANTU = .TRUE., the leading N-by-N part of +C this array contains U2, postmultiplied by the orthogonal +C transformation which reorders A. +C If WANTU = .FALSE., this array is not referenced. +C +C LDU2 INTEGER +C The leading dimension of the array U2. +C LDU2 >= MAX(1,N), if WANTU = .TRUE.; +C LDU2 >= 1, otherwise. +C +C J1 (input) INTEGER +C The index of the first row of the first block A11. +C If J1+N1 < N, then A11 is swapped with the block starting +C at (J1+N1+1)-th diagonal element. +C If J1+N1 > N, then A11 is the last block in A and swapped +C with -A11', if ISHAM = .TRUE., +C or A11', if ISHAM = .FALSE.. +C +C N1 (input) INTEGER +C The order of the first block A11. N1 = 0, 1 or 2. +C +C N2 (input) INTEGER +C The order of the second block A22. N2 = 0, 1 or 2. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: the transformed matrix A would be too far from Schur +C form; the blocks are not swapped and A, G, U1 and +C U2 are unchanged. +C +C REFERENCES +C +C [1] Bai, Z., and Demmel, J.W. +C On swapping diagonal blocks in real Schur form. +C Linear Algebra Appl., 186, pp. 73-95, 1993. +C +C [2] Benner, P., Kressner, D., and Mehrmann, V. +C Skew-Hamiltonian and Hamiltonian Eigenvalue Problems: Theory, +C Algorithms and Applications. Techn. Report, TU Berlin, 2003. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAEX2). +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, TWO, THIRTY, FORTY + PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, + $ TWO = 2.0D+0, THIRTY = 3.0D+1, + $ FORTY = 4.0D+1 ) + INTEGER LDD, LDX + PARAMETER ( LDD = 4, LDX = 2 ) +C .. Scalar Arguments .. + LOGICAL ISHAM, WANTU + INTEGER INFO, J1, LDA, LDG, LDU1, LDU2, N, N1, N2 +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), U1(LDU1,*), + $ U2(LDU2,*) +C .. Local Scalars .. + LOGICAL LBLK + INTEGER IERR, J2, J3, J4, K, ND + DOUBLE PRECISION A11, A22, A33, CS, DNORM, EPS, SCALE, SMLNUM, + $ SN, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2, + $ WR1, WR2, XNORM +C .. Local Arrays .. + DOUBLE PRECISION D(LDD,4), V(3), V1(3), V2(3), X(LDX,2) +C .. External Functions .. + DOUBLE PRECISION DDOT, DLAMCH, DLANGE + EXTERNAL DDOT, DLAMCH, DLANGE +C .. External Subroutines .. + EXTERNAL DAXPY, DLACPY, DLANV2, DLARFG, DLARFX, DLARTG, + $ DLASET, DLASY2, DROT, DSCAL, DSWAP, DSYMV, + $ DSYR2, MB01MD, MB01ND +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C +C .. Executable Statements .. +C + INFO = 0 +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 ) + $ RETURN + LBLK = ( J1+N1.GT.N ) +C + J2 = J1 + 1 + J3 = J1 + 2 + J4 = J1 + 3 +C + IF ( LBLK .AND. N1.EQ.1 ) THEN +C + IF ( ISHAM ) THEN + A11 = A(N,N) + CALL DLARTG( G(N,N), -TWO*A11, CS, SN, TEMP ) + CALL DROT( N-1, A(1,N), 1, G(1,N), 1, CS, SN ) + A(N,N) = -A11 + IF ( WANTU ) + $ CALL DROT( N, U1(1,N), 1, U2(1,N), 1, CS, SN ) + ELSE + CALL DSWAP( N-1, A(1,N), 1, G(1,N), 1 ) + CALL DSCAL( N-1, -ONE, A(1,N), 1 ) + IF ( WANTU ) THEN + CALL DSWAP( N, U1(1,N), 1, U2(1,N), 1 ) + CALL DSCAL( N, -ONE, U1(1,N), 1 ) + END IF + END IF +C + ELSE IF ( LBLK .AND. N1.EQ.2 ) THEN +C + IF ( ISHAM ) THEN +C +C Reorder Hamiltonian matrix: +C +C [ A11 G11 ] +C [ T ]. +C [ 0 -A11 ] +C + ND = 4 + CALL DLACPY( 'Full', 2, 2, A(N-1,N-1), LDA, D, LDD ) + CALL DLASET( 'All', 2, 2, ZERO, ZERO, D(3,1), LDD ) + CALL DLACPY( 'Upper', 2, 2, G(N-1,N-1), LDG, D(1,3), LDD ) + D(2,3) = D(1,4) + D(3,3) = -D(1,1) + D(4,3) = -D(1,2) + D(3,4) = -D(2,1) + D(4,4) = -D(2,2) + DNORM = DLANGE( 'Max', ND, ND, D, LDD, DWORK ) +C +C Compute machine-dependent threshold for test for accepting +C swap. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + THRESH = MAX( FORTY*EPS*DNORM, SMLNUM ) +C +C Solve A11*X + X*A11' = scale*G11 for X. +C + CALL DLASY2( .FALSE., .FALSE., -1, 2, 2, D, LDD, D(3,3), + $ LDD, D(1,3), LDD, SCALE, X, LDX, XNORM, IERR ) +C +C Compute symplectic QR decomposition of +C +C ( -X11 -X12 ) +C ( -X21 -X22 ). +C ( scale 0 ) +C ( 0 scale ) +C + TEMP = -X(1,1) + CALL DLARTG( TEMP, SCALE, V1(1), V2(1), X(1,1) ) + CALL DLARTG( X(1,1), -X(2,1), V1(2), V2(2), TEMP ) + X(1,2) = -X(1,2) + X(2,2) = -X(2,2) + X(1,1) = ZERO + X(2,1) = SCALE + CALL DROT( 1, X(1,2), 1, X(1,1), 1, V1(1), V2(1) ) + CALL DROT( 1, X(1,2), 1, X(2,2), 1, V1(2), V2(2) ) + CALL DROT( 1, X(1,1), 1, X(2,1), 1, V1(2), V2(2) ) + CALL DLARTG( X(2,2), X(2,1), V1(3), V2(3), TEMP ) +C +C Perform swap provisionally on D. +C + CALL DROT( 4, D(1,1), LDD, D(3,1), LDD, V1(1), V2(1) ) + CALL DROT( 4, D(1,1), LDD, D(2,1), LDD, V1(2), V2(2) ) + CALL DROT( 4, D(3,1), LDD, D(4,1), LDD, V1(2), V2(2) ) + CALL DROT( 4, D(2,1), LDD, D(4,1), LDD, V1(3), V2(3) ) + CALL DROT( 4, D(1,1), 1, D(1,3), 1, V1(1), V2(1) ) + CALL DROT( 4, D(1,1), 1, D(1,2), 1, V1(2), V2(2) ) + CALL DROT( 4, D(1,3), 1, D(1,4), 1, V1(2), V2(2) ) + CALL DROT( 4, D(1,2), 1, D(1,4), 1, V1(3), V2(3) ) +C +C Test whether to reject swap. +C + IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(4,1) ), + $ ABS( D(4,2) ) ).GT.THRESH ) GO TO 50 +C + CALL DLACPY( 'All', 2, 2, D(1,1), LDD, A(N-1,N-1), LDA ) + CALL DLACPY( 'Upper', 2, 2, D(1,3), LDD, G(N-1,N-1), LDG ) +C + IF ( N.GT.2 ) THEN + CALL DROT( N-2, A(1,N-1), 1, G(1,N-1), 1, V1(1), V2(1) ) + CALL DROT( N-2, A(1,N-1), 1, A(1,N), 1, V1(2), V2(2) ) + CALL DROT( N-2, G(1,N-1), 1, G(1,N), 1, V1(2), V2(2) ) + CALL DROT( N-2, A(1,N), 1, G(1,N), 1, V1(3), V2(3) ) + END IF +C + IF ( WANTU ) THEN + CALL DROT( N, U1(1,N-1), 1, U2(1,N-1), 1, V1(1), V2(1) ) + CALL DROT( N, U1(1,N-1), 1, U1(1,N), 1, V1(2), V2(2) ) + CALL DROT( N, U2(1,N-1), 1, U2(1,N), 1, V1(2), V2(2) ) + CALL DROT( N, U1(1,N), 1, U2(1,N), 1, V1(3), V2(3) ) + END IF +C + ELSE +C + IF ( ABS( A(N-1,N) ).GT.ABS( A(N,N-1) ) ) THEN + TEMP = G(N-1,N) + CALL DLARTG( TEMP, A(N-1,N), CS, SN, G(N-1,N) ) + SN = -SN + CALL DROT(N-2, A(1,N), 1, G(1,N), 1, CS, SN ) +C + A(N-1,N) = -SN*A(N,N-1) + TEMP = -CS*A(N,N-1) + A(N,N-1) = G(N-1,N) + G(N-1,N) = TEMP + IF ( WANTU ) + $ CALL DROT( N, U1(1,N), 1, U2(1,N), 1, CS, SN ) + CALL DSWAP( N-2, A(1,N-1), 1, G(1,N-1), 1 ) + CALL DSCAL( N-2, -ONE, A(1,N-1), 1 ) + IF ( WANTU ) THEN + CALL DSWAP( N, U1(1,N-1), 1, U2(1,N-1), 1 ) + CALL DSCAL( N, -ONE, U1(1,N-1), 1 ) + END IF + ELSE + TEMP = G(N-1,N) + CALL DLARTG( TEMP, A(N,N-1), CS, SN, G(N-1,N) ) + CALL DROT( N-2, A(1,N-1), 1, G(1,N-1), 1, CS, SN ) + A(N,N-1) = -SN*A(N-1,N) + A(N-1,N) = CS*A(N-1,N) + IF ( WANTU ) + $ CALL DROT( N, U1(1,N-1), 1, U2(1,N-1), 1, CS, SN ) + CALL DSWAP( N-1, A(1,N), 1, G(1,N), 1 ) + CALL DSCAL( N-1, -ONE, A(1,N), 1 ) + IF ( WANTU ) THEN + CALL DSWAP( N, U1(1,N), 1, U2(1,N), 1 ) + CALL DSCAL( N, -ONE, U1(1,N), 1 ) + END IF + END IF + END IF +C +C Standardize new 2-by-2 block. +C + CALL DLANV2( A(N-1,N-1), A(N-1,N), A(N,N-1), + $ A(N,N), WR1, WI1, WR2, WI2, CS, SN ) + CALL DROT( N-2, A(1,N-1), 1, A(1,N), 1, CS, SN ) + IF ( ISHAM ) THEN + TEMP = G(N-1,N) + CALL DROT( N-1, G(1,N-1), 1, G(1,N), 1, CS, SN ) + TAU = CS*TEMP + SN*G(N,N) + G(N,N) = CS*G(N,N) - SN*TEMP + G(N-1,N-1) = CS*G(N-1,N-1) + SN*TAU + CALL DROT( 1, G(N-1,N), LDG, G(N,N), LDG, CS, SN ) + ELSE + CALL DROT( N-2, G(1,N-1), 1, G(1,N), 1, CS, SN ) + END IF + IF ( WANTU ) THEN + CALL DROT( N, U1(1,N-1), 1, U1(1,N), 1, CS, SN ) + CALL DROT( N, U2(1,N-1), 1, U2(1,N), 1, CS, SN ) + END IF +C + ELSE IF ( N1.EQ.1 .AND. N2.EQ.1 ) THEN +C +C Swap two 1-by-1 blocks. +C + A11 = A(J1,J1) + A22 = A(J2,J2) +C +C Determine the transformation to perform the interchange. +C + CALL DLARTG( A(J1,J2), A22-A11, CS, SN, TEMP ) +C +C Apply transformation to the matrix A. +C + IF ( J3.LE.N ) + $ CALL DROT( N-J1-1, A(J1,J3), LDA, A(J2,J3), LDA, CS, SN ) + CALL DROT( J1-1, A(1,J1), 1, A(1,J2), 1, CS, SN ) +C + A(J1,J1) = A22 + A(J2,J2) = A11 +C +C Apply transformation to the matrix G. +C + IF ( ISHAM ) THEN + TEMP = G(J1,J2) + CALL DROT( J1, G(1,J1), 1, G(1,J2), 1, CS, SN ) + TAU = CS*TEMP + SN*G(J2,J2) + G(J2,J2) = CS*G(J2,J2) - SN*TEMP + G(J1,J1) = CS*G(J1,J1) + SN*TAU + CALL DROT( N-J1, G(J1,J2), LDG, G(J2,J2), LDG, CS, SN ) + ELSE + IF ( N.GT.J1+1 ) + $ CALL DROT( N-J1-1, G(J1,J1+2), LDG, G(J2,J1+2), LDG, CS, + $ SN ) + CALL DROT( J1-1, G(1,J1), 1, G(1,J2), 1, CS, SN ) + END IF + IF ( WANTU ) THEN +C +C Accumulate transformation in the matrices U1 and U2. +C + CALL DROT( N, U1(1,J1), 1, U1(1,J2), 1, CS, SN ) + CALL DROT( N, U2(1,J1), 1, U2(1,J2), 1, CS, SN ) + END IF +C + ELSE +C +C Swapping involves at least one 2-by-2 block. +C +C Copy the diagonal block of order N1+N2 to the local array D +C and compute its norm. +C + ND = N1 + N2 + CALL DLACPY( 'Full', ND, ND, A(J1,J1), LDA, D, LDD ) + DNORM = DLANGE( 'Max', ND, ND, D, LDD, DWORK ) +C +C Compute machine-dependent threshold for test for accepting +C swap. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + THRESH = MAX( THIRTY*EPS*DNORM, SMLNUM ) +C +C Solve A11*X - X*A22 = scale*A12 for X. +C + CALL DLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD, + $ D(N1+1,N1+1), LDD, D(1,N1+1), LDD, SCALE, X, LDX, + $ XNORM, IERR ) +C +C Swap the adjacent diagonal blocks. +C + K = N1 + N1 + N2 - 3 + GO TO ( 10, 20, 30 )K +C + 10 CONTINUE +C +C N1 = 1, N2 = 2: generate elementary reflector H so that: +C +C ( scale, X11, X12 ) H = ( 0, 0, * ). +C + V(1) = SCALE + V(2) = X(1,1) + V(3) = X(1,2) + CALL DLARFG( 3, V(3), V, 1, TAU ) + V(3) = ONE + A11 = A(J1,J1) +C +C Perform swap provisionally on diagonal block in D. +C + CALL DLARFX( 'Left', 3, 3, V, TAU, D, LDD, DWORK ) + CALL DLARFX( 'Right', 3, 3, V, TAU, D, LDD, DWORK ) +C +C Test whether to reject swap. +C + IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(3,3)-A11 ) ) + $ .GT.THRESH ) GO TO 50 +C +C Accept swap: apply transformation to the entire matrix A. +C + CALL DLARFX( 'Left', 3, N-J1+1, V, TAU, A(J1,J1), LDA, DWORK ) + CALL DLARFX( 'Right', J2, 3, V, TAU, A(1,J1), LDA, DWORK ) +C + A(J3,J1) = ZERO + A(J3,J2) = ZERO + A(J3,J3) = A11 +C +C Apply transformation to G. +C + IF ( ISHAM ) THEN + CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) + CALL DSYMV( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, + $ DWORK, 1 ) + TEMP = -HALF*TAU*DDOT( 3, DWORK, 1, V, 1 ) + CALL DAXPY( 3, TEMP, V, 1, DWORK, 1 ) + CALL DSYR2( 'Upper', 3, -ONE, V, 1, DWORK, 1, + $ G(J1,J1), LDG ) + IF ( N.GT.J1+2 ) + $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, + $ DWORK ) + ELSE + CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) + CALL MB01MD( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, + $ DWORK, 1 ) + CALL MB01ND( 'Upper', 3, ONE, V, 1, DWORK, 1, G(J1,J1), + $ LDG ) + IF ( N.GT.J1+2 ) + $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, + $ DWORK ) + END IF +C + IF ( WANTU ) THEN +C +C Accumulate transformation in the matrices U1 and U2. +C + CALL DLARFX( 'R', N, 3, V, TAU, U1(1,J1), LDU1, DWORK ) + CALL DLARFX( 'R', N, 3, V, TAU, U2(1,J1), LDU2, DWORK ) + END IF + GO TO 40 +C + 20 CONTINUE +C +C N1 = 2, N2 = 1: generate elementary reflector H so that: +C +C H ( -X11 ) = ( * ) +C ( -X21 ) = ( 0 ). +C ( scale ) = ( 0 ) +C + V(1) = -X(1,1) + V(2) = -X(2,1) + V(3) = SCALE + CALL DLARFG( 3, V(1), V(2), 1, TAU ) + V(1) = ONE + A33 = A(J3,J3) +C +C Perform swap provisionally on diagonal block in D. +C + CALL DLARFX( 'L', 3, 3, V, TAU, D, LDD, DWORK ) + CALL DLARFX( 'R', 3, 3, V, TAU, D, LDD, DWORK ) +C +C Test whether to reject swap. +C + IF ( MAX( ABS( D(2,1) ), ABS( D(3,1) ), ABS( D(1,1)-A33 ) ) + $ .GT. THRESH ) GO TO 50 +C +C Accept swap: apply transformation to the entire matrix A. +C + CALL DLARFX( 'Right', J3, 3, V, TAU, A(1,J1), LDA, DWORK ) + CALL DLARFX( 'Left', 3, N-J1, V, TAU, A(J1,J2), LDA, DWORK ) +C + A(J1,J1) = A33 + A(J2,J1) = ZERO + A(J3,J1) = ZERO +C +C Apply transformation to G. +C + IF ( ISHAM ) THEN + CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) + CALL DSYMV( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, + $ DWORK, 1 ) + TEMP = -HALF*TAU*DDOT( 3, DWORK, 1, V, 1 ) + CALL DAXPY( 3, TEMP, V, 1, DWORK, 1 ) + CALL DSYR2( 'Upper', 3, -ONE, V, 1, DWORK, 1, G(J1,J1), + $ LDG ) + IF ( N.GT.J1+2 ) + $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, + $ DWORK ) + ELSE + CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) + CALL MB01MD( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, + $ DWORK, 1 ) + CALL MB01ND( 'Upper', 3, ONE, V, 1, DWORK, 1, G(J1,J1), + $ LDG ) + IF ( N.GT.J1+2 ) + $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, + $ DWORK ) + END IF +C + IF ( WANTU ) THEN +C +C Accumulate transformation in the matrices U1 and U2. +C + CALL DLARFX( 'R', N, 3, V, TAU, U1(1,J1), LDU1, DWORK ) + CALL DLARFX( 'R', N, 3, V, TAU, U2(1,J1), LDU2, DWORK ) + END IF + GO TO 40 +C + 30 CONTINUE +C +C N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so +C that: +C +C H(2) H(1) ( -X11 -X12 ) = ( * * ) +C ( -X21 -X22 ) ( 0 * ). +C ( scale 0 ) ( 0 0 ) +C ( 0 scale ) ( 0 0 ) +C + V1(1) = -X(1,1) + V1(2) = -X(2,1) + V1(3) = SCALE + CALL DLARFG( 3, V1(1), V1(2), 1, TAU1 ) + V1(1) = ONE +C + TEMP = -TAU1*( X(1,2)+V1(2)*X(2,2) ) + V2(1) = -TEMP*V1(2) - X(2,2) + V2(2) = -TEMP*V1(3) + V2(3) = SCALE + CALL DLARFG( 3, V2(1), V2(2), 1, TAU2 ) + V2(1) = ONE +C +C Perform swap provisionally on diagonal block in D. +C + CALL DLARFX( 'L', 3, 4, V1, TAU1, D, LDD, DWORK ) + CALL DLARFX( 'R', 4, 3, V1, TAU1, D, LDD, DWORK ) + CALL DLARFX( 'L', 3, 4, V2, TAU2, D(2,1), LDD, DWORK ) + CALL DLARFX( 'R', 4, 3, V2, TAU2, D(1,2), LDD, DWORK ) +C +C Test whether to reject swap. +C + IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(4,1) ), + $ ABS( D(4,2) ) ).GT.THRESH ) GO TO 50 +C +C Accept swap: apply transformation to the entire matrix A. +C + CALL DLARFX( 'L', 3, N-J1+1, V1, TAU1, A(J1,J1), LDA, DWORK ) + CALL DLARFX( 'R', J4, 3, V1, TAU1, A(1,J1), LDA, DWORK ) + CALL DLARFX( 'L', 3, N-J1+1, V2, TAU2, A(J2,J1), LDA, DWORK ) + CALL DLARFX( 'R', J4, 3, V2, TAU2, A(1,J2), LDA, DWORK ) +C + A(J3,J1) = ZERO + A(J3,J2) = ZERO + A(J4,J1) = ZERO + A(J4,J2) = ZERO +C +C Apply transformation to G. +C + IF ( ISHAM ) THEN + CALL DLARFX( 'Right', J1-1, 3, V1, TAU1, G(1,J1), LDG, + $ DWORK ) + CALL DSYMV( 'Upper', 3, TAU1, G(J1,J1), LDG, V1, 1, ZERO, + $ DWORK, 1 ) + TEMP = -HALF*TAU1*DDOT( 3, DWORK, 1, V1, 1 ) + CALL DAXPY( 3, TEMP, V1, 1, DWORK, 1 ) + CALL DSYR2( 'Upper', 3, -ONE, V1, 1, DWORK, 1, + $ G(J1,J1), LDG ) + IF ( N.GT.J1+2 ) + $ CALL DLARFX( 'Left', 3, N-J1-2, V1, TAU1, G(J1,J1+3), + $ LDG, DWORK ) +C + CALL DLARFX( 'Right', J2-1, 3, V2, TAU2, G(1,J2), LDG, + $ DWORK ) + CALL DSYMV( 'Upper', 3, TAU2, G(J2,J2), LDG, V2, 1, ZERO, + $ DWORK, 1 ) + TEMP = -HALF*TAU2*DDOT( 3, DWORK, 1, V2, 1 ) + CALL DAXPY( 3, TEMP, V2, 1, DWORK, 1 ) + CALL DSYR2( 'Upper', 3, -ONE, V2, 1, DWORK, 1, G(J2,J2), + $ LDG ) + IF ( N.GT.J2+2 ) + $ CALL DLARFX( 'Left', 3, N-J2-2, V2, TAU2, G(J2,J2+3), + $ LDG, DWORK ) + ELSE + CALL DLARFX( 'Right', J1-1, 3, V1, TAU1, G(1,J1), LDG, + $ DWORK ) + CALL MB01MD( 'Upper', 3, TAU1, G(J1,J1), LDG, V1, 1, ZERO, + $ DWORK, 1 ) + CALL MB01ND( 'Upper', 3, ONE, V1, 1, DWORK, 1, G(J1,J1), + $ LDG ) + IF ( N.GT.J1+2 ) + $ CALL DLARFX( 'Left', 3, N-J1-2, V1, TAU1, G(J1,J1+3), + $ LDG, DWORK ) + CALL DLARFX( 'Right', J2-1, 3, V2, TAU2, G(1,J2), LDG, + $ DWORK ) + CALL MB01MD( 'Upper', 3, TAU2, G(J2,J2), LDG, V2, 1, ZERO, + $ DWORK, 1 ) + CALL MB01ND( 'Upper', 3, ONE, V2, 1, DWORK, 1, G(J2,J2), + $ LDG ) + IF ( N.GT.J2+2 ) + $ CALL DLARFX( 'Left', 3, N-J2-2, V2, TAU2, G(J2,J2+3), + $ LDG, DWORK ) + END IF +C + IF ( WANTU ) THEN +C +C Accumulate transformation in the matrices U1 and U2. +C + CALL DLARFX( 'R', N, 3, V1, TAU1, U1(1,J1), LDU1, DWORK ) + CALL DLARFX( 'R', N, 3, V2, TAU2, U1(1,J2), LDU1, DWORK ) + CALL DLARFX( 'R', N, 3, V1, TAU1, U2(1,J1), LDU2, DWORK ) + CALL DLARFX( 'R', N, 3, V2, TAU2, U2(1,J2), LDU2, DWORK ) + END IF +C + 40 CONTINUE +C + IF ( N2.EQ.2 ) THEN +C +C Standardize new 2-by-2 block A11. +C + CALL DLANV2( A(J1,J1), A(J1,J2), A(J2,J1), A(J2,J2), WR1, + $ WI1, WR2, WI2, CS, SN ) + CALL DROT( N-J1-1, A(J1,J1+2), LDA, A(J2,J1+2), LDA, CS, + $ SN ) + CALL DROT( J1-1, A(1,J1), 1, A(1,J2), 1, CS, SN ) + IF ( ISHAM ) THEN + TEMP = G(J1,J2) + CALL DROT( J1, G(1,J1), 1, G(1,J2), 1, CS, SN ) + TAU = CS*TEMP + SN*G(J2,J2) + G(J2,J2) = CS*G(J2,J2) - SN*TEMP + G(J1,J1) = CS*G(J1,J1) + SN*TAU + CALL DROT( N-J1, G(J1,J2), LDG, G(J2,J2), LDG, CS, SN ) + ELSE + IF ( N.GT.J1+1 ) + $ CALL DROT( N-J1-1, G(J1,J1+2), LDG, G(J2,J1+2), LDG, + $ CS, SN ) + CALL DROT( J1-1, G(1,J1), 1, G(1,J2), 1, CS, SN ) + END IF + IF ( WANTU ) THEN + CALL DROT( N, U1(1,J1), 1, U1(1,J2), 1, CS, SN ) + CALL DROT( N, U2(1,J1), 1, U2(1,J2), 1, CS, SN ) + END IF + END IF +C + IF ( N1.EQ.2 ) THEN +C +C Standardize new 2-by-2 block A22. +C + J3 = J1 + N2 + J4 = J3 + 1 + CALL DLANV2( A(J3,J3), A(J3,J4), A(J4,J3), A(J4,J4), WR1, + $ WI1, WR2, WI2, CS, SN ) + IF ( J3+2.LE.N ) + $ CALL DROT( N-J3-1, A(J3,J3+2), LDA, A(J4,J3+2), LDA, CS, + $ SN ) + CALL DROT( J3-1, A(1,J3), 1, A(1,J4), 1, CS, SN ) + IF ( ISHAM ) THEN + TEMP = G(J3,J4) + CALL DROT( J3, G(1,J3), 1, G(1,J4), 1, CS, SN ) + TAU = CS*TEMP + SN*G(J4,J4) + G(J4,J4) = CS*G(J4,J4) - SN*TEMP + G(J3,J3) = CS*G(J3,J3) + SN*TAU + CALL DROT( N-J3, G(J3,J4), LDG, G(J4,J4), LDG, CS, SN ) + ELSE + IF ( N.GT.J3+1 ) + $ CALL DROT( N-J3-1, G(J3,J3+2), LDG, G(J4,J3+2), LDG, + $ CS, SN ) + CALL DROT( J3-1, G(1,J3), 1, G(1,J4), 1, CS, SN ) + END IF + IF ( WANTU ) THEN + CALL DROT( N, U1(1,J3), 1, U1(1,J4), 1, CS, SN ) + CALL DROT( N, U2(1,J3), 1, U2(1,J4), 1, CS, SN ) + END IF + END IF +C + END IF + RETURN +C +C Exit with INFO = 1 if swap was rejected. +C + 50 CONTINUE + INFO = 1 + RETURN +C *** Last line of MB03TS *** + END diff --git a/mex/sources/libslicot/MB03UD.f b/mex/sources/libslicot/MB03UD.f new file mode 100644 index 000000000..37e6b6bcd --- /dev/null +++ b/mex/sources/libslicot/MB03UD.f @@ -0,0 +1,318 @@ + SUBROUTINE MB03UD( JOBQ, JOBP, N, A, LDA, Q, LDQ, SV, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute all, or part, of the singular value decomposition of a +C real upper triangular matrix. +C +C The N-by-N upper triangular matrix A is factored as A = Q*S*P', +C where Q and P are N-by-N orthogonal matrices and S is an +C N-by-N diagonal matrix with non-negative diagonal elements, +C SV(1), SV(2), ..., SV(N), ordered such that +C +C SV(1) >= SV(2) >= ... >= SV(N) >= 0. +C +C The columns of Q are the left singular vectors of A, the diagonal +C elements of S are the singular values of A and the columns of P +C are the right singular vectors of A. +C +C Either or both of Q and P' may be requested. +C When P' is computed, it is returned in A. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBQ CHARACTER*1 +C Specifies whether the user wishes to compute the matrix Q +C of left singular vectors as follows: +C = 'V': Left singular vectors are computed; +C = 'N': No left singular vectors are computed. +C +C JOBP CHARACTER*1 +C Specifies whether the user wishes to compute the matrix P' +C of right singular vectors as follows: +C = 'V': Right singular vectors are computed; +C = 'N': No right singular vectors are computed. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix A. +C On exit, if JOBP = 'V', the leading N-by-N part of this +C array contains the N-by-N orthogonal matrix P'; otherwise +C the N-by-N upper triangular part of A is used as internal +C workspace. The strictly lower triangular part of A is set +C internally to zero before the reduction to bidiagonal form +C is performed. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) +C If JOBQ = 'V', the leading N-by-N part of this array +C contains the orthogonal matrix Q. +C If JOBQ = 'N', Q is not referenced. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= 1, and when JOBQ = 'V', LDQ >= MAX(1,N). +C +C SV (output) DOUBLE PRECISION array, dimension (N) +C The N singular values of the matrix A, sorted in +C descending order. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK; +C if INFO > 0, DWORK(2:N) contains the unconverged +C superdiagonal elements of an upper bidiagonal matrix B +C whose diagonal is in SV (not necessarily sorted). +C B satisfies A = Q*B*P', so it has the same singular +C values as A, and singular vectors related by Q and P'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,5*N). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: the QR algorithm has failed to converge. In this +C case INFO specifies how many superdiagonals did not +C converge (see the description of DWORK). +C This failure is not likely to occur. +C +C METHOD +C +C The routine reduces A to bidiagonal form by means of elementary +C reflectors and then uses the QR algorithm on the bidiagonal form. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute of Informatics, Bucharest, and +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, +C March 1998. Based on the RASP routine DTRSVD. +C +C REVISIONS +C +C V. Sima, Feb. 2000. +C +C KEYWORDS +C +C Bidiagonalization, orthogonal transformation, singular value +C decomposition, singular values, triangular form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBP, JOBQ + INTEGER INFO, LDA, LDQ, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), Q(LDQ,*), SV(*) +C .. Local Scalars .. + LOGICAL WANTQ, WANTP + INTEGER I, IE, ISCL, ITAUP, ITAUQ, JWORK, MAXWRK, + $ MINWRK, NCOLP, NCOLQ + DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANTR + EXTERNAL DLAMCH, DLANTR, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DBDSQR, DGEBRD, DLACPY, DLASCL, DLASET, DORGBR, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +C .. Executable Statements .. +C +C Check the input scalar arguments. +C + INFO = 0 + WANTQ = LSAME( JOBQ, 'V' ) + WANTP = LSAME( JOBP, 'V' ) + MINWRK = 1 + IF( .NOT.WANTQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.WANTP .AND. .NOT.LSAME( JOBP, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.WANTQ .AND. LDQ.LT.1 ) ) THEN + INFO = -7 + END IF +C +C Compute workspace +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately following +C subroutine, as returned by ILAENV.) +C + IF( INFO.EQ.0 .AND. LDWORK.GE.1 .AND. N.GT.0 ) THEN + MAXWRK = 3*N+2*N*ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) + IF( WANTQ ) + $ MAXWRK = MAX( MAXWRK, 3*N+N* + $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) + IF( WANTP ) + $ MAXWRK = MAX( MAXWRK, 3*N+N* + $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) + MINWRK = 5*N + MAXWRK = MAX( MAXWRK, MINWRK ) + DWORK(1) = MAXWRK + END IF +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03UD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Get machine constants. +C + EPS = DLAMCH( 'P' ) + SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS + BIGNUM = ONE / SMLNUM +C +C Scale A if max entry outside range [SMLNUM,BIGNUM]. +C + ANRM = DLANTR( 'Max', 'Upper', 'Non-unit', N, N, A, LDA, DUM ) + ISCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ISCL = 1 + CALL DLASCL( 'Upper', 0, 0, ANRM, SMLNUM, N, N, A, LDA, INFO ) + ELSE IF( ANRM.GT.BIGNUM ) THEN + ISCL = 1 + CALL DLASCL( 'Upper', 0, 0, ANRM, BIGNUM, N, N, A, LDA, INFO ) + END IF +C +C Zero out below. +C + IF ( N.GT.1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, A(2,1), LDA ) +C +C Find the singular values and optionally the singular vectors +C of the upper triangular matrix A. +C + IE = 1 + ITAUQ = IE + N + ITAUP = ITAUQ + N + JWORK = ITAUP + N +C +C First reduce the matrix to bidiagonal form. The diagonal +C elements will be in SV and the superdiagonals in DWORK(IE). +C (Workspace: need 4*N, prefer 3*N+2*N*NB) +C + CALL DGEBRD( N, N, A, LDA, SV, DWORK(IE), DWORK(ITAUQ), + $ DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, INFO ) + IF( WANTQ ) THEN +C +C Generate the transformation matrix Q corresponding to the +C left singular vectors. +C (Workspace: need 4*N, prefer 3*N+N*NB) +C + NCOLQ = N + CALL DLACPY( 'Lower', N, N, A, LDA, Q, LDQ ) + CALL DORGBR( 'Q', N, N, N, Q, LDQ, DWORK(ITAUQ), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + ELSE + NCOLQ = 0 + END IF + IF( WANTP ) THEN +C +C Generate the transformation matrix P' corresponding to the +C right singular vectors. +C (Workspace: need 4*N, prefer 3*N+N*NB) +C + NCOLP = N + CALL DORGBR( 'P', N, N, N, A, LDA, DWORK(ITAUP), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + ELSE + NCOLP = 0 + END IF + JWORK = IE + N +C +C Perform bidiagonal QR iteration, to obtain all or part of the +C singular value decomposition of A. +C (Workspace: need 5*N) +C + CALL DBDSQR( 'U', N, NCOLP, NCOLQ, 0, SV, DWORK(IE), A, LDA, + $ Q, LDQ, DUM, 1, DWORK(JWORK), INFO ) +C +C If DBDSQR failed to converge, copy unconverged superdiagonals +C to DWORK(2:N). +C + IF( INFO.NE.0 ) THEN + DO 10 I = N - 1, 1, -1 + DWORK(I+1) = DWORK(I+IE-1) + 10 CONTINUE + END IF +C +C Undo scaling if necessary. +C + IF( ISCL.EQ.1 ) THEN + IF( ANRM.GT.BIGNUM ) + $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, N, 1, SV, N, INFO ) + IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) + $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, N-1, 1, DWORK(2), N, + $ INFO ) + IF( ANRM.LT.SMLNUM ) + $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, N, 1, SV, N, INFO ) + IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) + $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, N-1, 1, DWORK(2), N, + $ INFO ) + END IF +C +C Return optimal workspace in DWORK(1). +C + DWORK(1) = MAXWRK +C + RETURN +C *** Last line of MB03UD *** + END diff --git a/mex/sources/libslicot/MB03VD.f b/mex/sources/libslicot/MB03VD.f new file mode 100644 index 000000000..4cf99f6fb --- /dev/null +++ b/mex/sources/libslicot/MB03VD.f @@ -0,0 +1,306 @@ + SUBROUTINE MB03VD( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU, + $ DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce a product of p real general matrices A = A_1*A_2*...*A_p +C to upper Hessenberg form, H = H_1*H_2*...*H_p, where H_1 is +C upper Hessenberg, and H_2, ..., H_p are upper triangular, by using +C orthogonal similarity transformations on A, +C +C Q_1' * A_1 * Q_2 = H_1, +C Q_2' * A_2 * Q_3 = H_2, +C ... +C Q_p' * A_p * Q_1 = H_p. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the square matrices A_1, A_2, ..., A_p. +C N >= 0. +C +C P (input) INTEGER +C The number of matrices in the product A_1*A_2*...*A_p. +C P >= 1. +C +C ILO (input) INTEGER +C IHI (input) INTEGER +C It is assumed that all matrices A_j, j = 2, ..., p, are +C already upper triangular in rows and columns 1:ILO-1 and +C IHI+1:N, and A_1 is upper Hessenberg in rows and columns +C 1:ILO-1 and IHI+1:N, with A_1(ILO,ILO-1) = 0 (unless +C ILO = 1), and A_1(IHI+1,IHI) = 0 (unless IHI = N). +C If this is not the case, ILO and IHI should be set to 1 +C and N, respectively. +C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA1,LDA2,P) +C On entry, the leading N-by-N-by-P part of this array must +C contain the matrices of factors to be reduced; +C specifically, A(*,*,j) must contain A_j, j = 1, ..., p. +C On exit, the leading N-by-N upper triangle and the first +C subdiagonal of A(*,*,1) contain the upper Hessenberg +C matrix H_1, and the elements below the first subdiagonal, +C with the first column of the array TAU represent the +C orthogonal matrix Q_1 as a product of elementary +C reflectors. See FURTHER COMMENTS. +C For j > 1, the leading N-by-N upper triangle of A(*,*,j) +C contains the upper triangular matrix H_j, and the elements +C below the diagonal, with the j-th column of the array TAU +C represent the orthogonal matrix Q_j as a product of +C elementary reflectors. See FURTHER COMMENTS. +C +C LDA1 INTEGER +C The first leading dimension of the array A. +C LDA1 >= max(1,N). +C +C LDA2 INTEGER +C The second leading dimension of the array A. +C LDA2 >= max(1,N). +C +C TAU (output) DOUBLE PRECISION array, dimension (LDTAU,P) +C The leading N-1 elements in the j-th column contain the +C scalar factors of the elementary reflectors used to form +C the matrix Q_j, j = 1, ..., P. See FURTHER COMMENTS. +C +C LDTAU INTEGER +C The leading dimension of the array TAU. +C LDTAU >= max(1,N-1). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The algorithm consists in ihi-ilo major steps. In each such +C step i, ilo <= i <= ihi-1, the subdiagonal elements in the i-th +C column of A_j are annihilated using a Householder transformation +C from the left, which is also applied to A_(j-1) from the right, +C for j = p:-1:2. Then, the elements below the subdiagonal of the +C i-th column of A_1 are annihilated, and the Householder +C transformation is also applied to A_p from the right. +C See FURTHER COMMENTS. +C +C REFERENCES +C +C [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P. +C The periodic Schur decomposition: algorithms and applications. +C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, +C 1992. +C +C [2] Sreedhar, J. and Van Dooren, P. +C Periodic Schur form and some matrix equations. +C Proc. of the Symposium on the Mathematical Theory of Networks +C and Systems (MTNS'93), Regensburg, Germany (U. Helmke, +C R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable. +C +C FURTHER COMMENTS +C +C Each matrix Q_j is represented as a product of (ihi-ilo) +C elementary reflectors, +C +C Q_j = H_j(ilo) H_j(ilo+1) . . . H_j(ihi-1). +C +C Each H_j(i), i = ilo, ..., ihi-1, has the form +C +C H_j(i) = I - tau_j * v_j * v_j', +C +C where tau_j is a real scalar, and v_j is a real vector with +C v_j(1:i) = 0, v_j(i+1) = 1 and v_j(ihi+1:n) = 0; v_j(i+2:ihi) +C is stored on exit in A_j(i+2:ihi,i), and tau_j in TAU(i,j). +C +C The contents of A_1 are illustrated by the following example +C for n = 7, ilo = 2, and ihi = 6: +C +C on entry on exit +C +C ( a a a a a a a ) ( a h h h h h a ) +C ( 0 a a a a a a ) ( 0 h h h h h a ) +C ( 0 a a a a a a ) ( 0 h h h h h h ) +C ( 0 a a a a a a ) ( 0 v2 h h h h h ) +C ( 0 a a a a a a ) ( 0 v2 v3 h h h h ) +C ( 0 a a a a a a ) ( 0 v2 v3 v4 h h h ) +C ( 0 0 0 0 0 0 a ) ( 0 0 0 0 0 0 a ) +C +C where a denotes an element of the original matrix A_1, h denotes +C a modified element of the upper Hessenberg matrix H_1, and vi +C denotes an element of the vector defining H_1(i). +C +C The contents of A_j, j > 1, are illustrated by the following +C example for n = 7, ilo = 2, and ihi = 6: +C +C on entry on exit +C +C ( a a a a a a a ) ( a h h h h h a ) +C ( 0 a a a a a a ) ( 0 h h h h h h ) +C ( 0 a a a a a a ) ( 0 v2 h h h h h ) +C ( 0 a a a a a a ) ( 0 v2 v3 h h h h ) +C ( 0 a a a a a a ) ( 0 v2 v3 v4 h h h ) +C ( 0 a a a a a a ) ( 0 v2 v3 v4 v5 h h ) +C ( 0 0 0 0 0 0 a ) ( 0 0 0 0 0 0 a ) +C +C where a denotes an element of the original matrix A_j, h denotes +C a modified element of the upper triangular matrix H_j, and vi +C denotes an element of the vector defining H_j(i). (The element +C (1,2) in A_p is also unchanged for this example.) +C +C Note that for P = 1, the LAPACK Library routine DGEHRD could be +C more efficient on some computer architectures than this routine +C (a BLAS 2 version). +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, and A. Varga, +C German Aerospace Center, DLR Oberpfaffenhofen, February 1999. +C Partly based on the routine PSHESS by A. Varga +C (DLR Oberpfaffenhofen), November 26, 1995. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, periodic systems, +C similarity transformation, triangular form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA1, LDA2, LDTAU, N, P +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA1, LDA2, * ), DWORK( * ), TAU( LDTAU, * ) +C .. +C .. Local Scalars .. + INTEGER I, I1, I2, J, NH +C .. +C .. Local Arrays .. + DOUBLE PRECISION DUMMY( 1 ) +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DLARFG, MB04PY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( P.LT.1 ) THEN + INFO = -2 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -3 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -4 + ELSE IF( LDA1.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDA2.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDTAU.LT.MAX( 1, N-1 ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03VD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + NH = IHI - ILO + 1 + IF ( NH.LE.1 ) + $ RETURN +C + DUMMY( 1 ) = ZERO +C + DO 20 I = ILO, IHI - 1 + I1 = I + 1 + I2 = MIN( I+2, N ) +C + DO 10 J = P, 2, -1 +C +C Set the elements 1:ILO-1 and IHI:N-1 of TAU(*,J) to zero. +C + CALL DCOPY( ILO-1, DUMMY, 0, TAU( 1, J ), 1 ) + IF ( IHI.LT.N ) + $ CALL DCOPY( N-IHI, DUMMY, 0, TAU( IHI, J ), 1 ) +C +C Compute elementary reflector H_j(i) to annihilate +C A_j(i+1:ihi,i). +C + CALL DLARFG( IHI-I+1, A( I, I, J ), A( I1, I, J ), 1, + $ TAU( I, J ) ) +C +C Apply H_j(i) to A_(j-1)(1:ihi,i:ihi) from the right. +C + CALL MB04PY( 'Right', IHI, IHI-I+1, A( I1, I, J ), + $ TAU( I, J ), A( 1, I, J-1 ), LDA1, DWORK ) +C +C Apply H_j(i) to A_j(i:ihi,i+1:n) from the left. +C + CALL MB04PY( 'Left', IHI-I+1, N-I, A( I1, I, J ), + $ TAU( I, J ), A( I, I1, J ), LDA1, DWORK ) + 10 CONTINUE +C +C Compute elementary reflector H_1(i) to annihilate +C A_1(i+2:ihi,i). +C + CALL DLARFG( IHI-I, A( I1, I, 1 ), A( I2, I, 1 ), 1, + $ TAU( I, 1 ) ) +C +C Apply H_1(i) to A_p(1:ihi,i+1:ihi) from the right. +C + CALL MB04PY( 'Right', IHI, IHI-I, A( I2, I, 1 ), TAU( I, 1 ), + $ A( 1, I1, P ), LDA1, DWORK ) +C +C Apply H_1(i) to A_1(i+1:ihi,i+1:n) from the left. +C + CALL MB04PY( 'Left', IHI-I, N-I, A( I2, I, 1 ), TAU( I, 1 ), + $ A( I1, I1, 1 ), LDA1, DWORK ) + 20 CONTINUE +C + RETURN +C +C *** Last line of MB03VD *** + END diff --git a/mex/sources/libslicot/MB03VY.f b/mex/sources/libslicot/MB03VY.f new file mode 100644 index 000000000..163e77497 --- /dev/null +++ b/mex/sources/libslicot/MB03VY.f @@ -0,0 +1,216 @@ + SUBROUTINE MB03VY( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate the real orthogonal matrices Q_1, Q_2, ..., Q_p, +C which are defined as the product of ihi-ilo elementary reflectors +C of order n, as returned by SLICOT Library routine MB03VD: +C +C Q_j = H_j(ilo) H_j(ilo+1) . . . H_j(ihi-1). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices Q_1, Q_2, ..., Q_p. N >= 0. +C +C P (input) INTEGER +C The number p of transformation matrices. P >= 1. +C +C ILO (input) INTEGER +C IHI (input) INTEGER +C The values of the indices ilo and ihi, respectively, used +C in the previous call of the SLICOT Library routine MB03VD. +C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA1,LDA2,N) +C On entry, the leading N-by-N strictly lower triangular +C part of A(*,*,j) must contain the vectors which define the +C elementary reflectors used for reducing A_j, as returned +C by SLICOT Library routine MB03VD, j = 1, ..., p. +C On exit, the leading N-by-N part of A(*,*,j) contains the +C N-by-N orthogonal matrix Q_j, j = 1, ..., p. +C +C LDA1 INTEGER +C The first leading dimension of the array A. +C LDA1 >= max(1,N). +C +C LDA2 INTEGER +C The second leading dimension of the array A. +C LDA2 >= max(1,N). +C +C TAU (input) DOUBLE PRECISION array, dimension (LDTAU,P) +C The leading N-1 elements in the j-th column must contain +C the scalar factors of the elementary reflectors used to +C form the matrix Q_j, as returned by SLICOT Library routine +C MB03VD. +C +C LDTAU INTEGER +C The leading dimension of the array TAU. +C LDTAU >= max(1,N-1). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Each matrix Q_j is generated as the product of the elementary +C reflectors used for reducing A_j. Standard LAPACK routines for +C Hessenberg and QR decompositions are used. +C +C REFERENCES +C +C [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P. +C The periodic Schur decomposition: algorithms and applications. +C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, +C 1992. +C +C [2] Sreedhar, J. and Van Dooren, P. +C Periodic Schur form and some matrix equations. +C Proc. of the Symposium on the Mathematical Theory of Networks +C and Systems (MTNS'93), Regensburg, Germany (U. Helmke, +C R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, and A. Varga, +C German Aerospace Center, DLR Oberpfaffenhofen, February 1999. +C Partly based on the routine PSHTR by A. Varga +C (DLR Oberpfaffenhofen), November 26, 1995. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, periodic systems, +C similarity transformation, triangular form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C +C .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA1, LDA2, LDTAU, LDWORK, N, P +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA1, LDA2, * ), DWORK( * ), TAU( LDTAU, * ) +C .. +C .. Local Scalars .. + INTEGER J, NH + DOUBLE PRECISION WRKOPT +C .. +C .. External Subroutines .. + EXTERNAL DLASET, DORGHR, DORGQR, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( P.LT.1 ) THEN + INFO = -2 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -3 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -4 + ELSE IF( LDA1.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDA2.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDTAU.LT.MAX( 1, N-1 ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03VY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK( 1 ) = ONE + RETURN + END IF +C +C Generate the orthogonal matrix Q_1. +C + CALL DORGHR( N, ILO, IHI, A, LDA1, TAU, DWORK, LDWORK, INFO ) + WRKOPT = DWORK( 1 ) +C + NH = IHI - ILO + 1 +C + DO 20 J = 2, P +C +C Generate the orthogonal matrix Q_j. +C Set the first ILO-1 and the last N-IHI rows and columns of Q_j +C to those of the unit matrix. +C + CALL DLASET( 'Full', N, ILO-1, ZERO, ONE, A( 1, 1, J ), LDA1 ) + CALL DLASET( 'Full', ILO-1, NH, ZERO, ZERO, A( 1, ILO, J ), + $ LDA1 ) + IF ( NH.GT.1 ) + $ CALL DORGQR( NH, NH, NH-1, A( ILO, ILO, J ), LDA1, + $ TAU( ILO, J ), DWORK, LDWORK, INFO ) + IF ( IHI.LT.N ) THEN + CALL DLASET( 'Full', N-IHI, NH, ZERO, ZERO, + $ A( IHI+1, ILO, J ), LDA1 ) + CALL DLASET( 'Full', IHI, N-IHI, ZERO, ZERO, + $ A( 1, IHI+1, J ), LDA1 ) + CALL DLASET( 'Full', N-IHI, N-IHI, ZERO, ONE, + $ A( IHI+1, IHI+1, J ), LDA1 ) + END IF + 20 CONTINUE +C + DWORK( 1 ) = MAX( WRKOPT, DWORK( 1 ) ) + RETURN +C +C *** Last line of MB03VY *** + END diff --git a/mex/sources/libslicot/MB03WA.f b/mex/sources/libslicot/MB03WA.f new file mode 100644 index 000000000..0a800ae0c --- /dev/null +++ b/mex/sources/libslicot/MB03WA.f @@ -0,0 +1,538 @@ + SUBROUTINE MB03WA( WANTQ, WANTZ, N1, N2, A, LDA, B, LDB, Q, LDQ, + $ Z, LDZ, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To swap adjacent diagonal blocks A11*B11 and A22*B22 of size +C 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix product +C A*B by an orthogonal equivalence transformation. +C +C (A, B) must be in periodic real Schur canonical form (as returned +C by SLICOT Library routine MB03XP), i.e., A is block upper +C triangular with 1-by-1 and 2-by-2 diagonal blocks, and B is upper +C triangular. +C +C Optionally, the matrices Q and Z of generalized Schur vectors are +C updated. +C +C Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)', +C Z(in) * B(in) * Q(in)' = Z(out) * B(out) * Q(out)'. +C +C This routine is largely based on the LAPACK routine DTGEX2 +C developed by Bo Kagstrom and Peter Poromaa. +C +C ARGUMENTS +C +C Mode Parameters +C +C WANTQ LOGICAL +C Indicates whether or not the user wishes to accumulate +C the matrix Q as follows: +C = .TRUE. : The matrix Q is updated; +C = .FALSE.: the matrix Q is not required. +C +C WANTZ LOGICAL +C Indicates whether or not the user wishes to accumulate +C the matrix Z as follows: +C = .TRUE. : The matrix Z is updated; +C = .FALSE.: the matrix Z is not required. +C +C Input/Output Parameters +C +C N1 (input) INTEGER +C The order of the first block A11*B11. N1 = 0, 1 or 2. +C +C N2 (input) INTEGER +C The order of the second block A22*B22. N2 = 0, 1 or 2. +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA,N1+N2) +C On entry, the leading (N1+N2)-by-(N1+N2) part of this +C array must contain the matrix A. +C On exit, the leading (N1+N2)-by-(N1+N2) part of this array +C contains the matrix A of the reordered pair. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N1+N2). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,N1+N2) +C On entry, the leading (N1+N2)-by-(N1+N2) part of this +C array must contain the matrix B. +C On exit, the leading (N1+N2)-by-(N1+N2) part of this array +C contains the matrix B of the reordered pair. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N1+N2). +C +C Q (input/output) DOUBLE PRECISION array, dimension +C (LDQ,N1+N2) +C On entry, if WANTQ = .TRUE., the leading +C (N1+N2)-by-(N1+N2) part of this array must contain the +C orthogonal matrix Q. +C On exit, the leading (N1+N2)-by-(N1+N2) part of this array +C contains the updated matrix Q. Q will be a rotation +C matrix for N1=N2=1. +C This array is not referenced if WANTQ = .FALSE.. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= 1. +C If WANTQ = .TRUE., LDQ >= N1+N2. +C +C Z (input/output) DOUBLE PRECISION array, dimension +C (LDZ,N1+N2) +C On entry, if WANTZ = .TRUE., the leading +C (N1+N2)-by-(N1+N2) part of this array must contain the +C orthogonal matrix Z. +C On exit, the leading (N1+N2)-by-(N1+N2) part of this array +C contains the updated matrix Z. Z will be a rotation +C matrix for N1=N2=1. +C This array is not referenced if WANTZ = .FALSE.. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= 1. +C If WANTZ = .TRUE., LDZ >= N1+N2. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: the transformed matrix (A, B) would be +C too far from periodic Schur form; the blocks are +C not swapped and (A,B) and (Q,Z) are unchanged. +C +C METHOD +C +C In the current code both weak and strong stability tests are +C performed. The user can omit the strong stability test by changing +C the internal logical parameter WANDS to .FALSE.. See ref. [2] for +C details. +C +C REFERENCES +C +C [1] Kagstrom, B. +C A direct method for reordering eigenvalues in the generalized +C real Schur form of a regular matrix pair (A,B), in M.S. Moonen +C et al (eds.), Linear Algebra for Large Scale and Real-Time +C Applications, Kluwer Academic Publ., 1993, pp. 195-218. +C +C [2] Kagstrom, B., and Poromaa, P. +C Computing eigenspaces with specified eigenvalues of a regular +C matrix pair (A, B) and condition estimation: Theory, +C algorithms and software, Numer. Algorithms, 1996, vol. 12, +C pp. 369-407. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, May 2008 (SLICOT version of the HAPACK routine DTGPX2). +C +C KEYWORDS +C +C Eigenvalue, periodic Schur form, reordering +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION TEN + PARAMETER ( TEN = 1.0D+01 ) + INTEGER LDST + PARAMETER ( LDST = 4 ) + LOGICAL WANDS + PARAMETER ( WANDS = .TRUE. ) +C .. Scalar Arguments .. + LOGICAL WANTQ, WANTZ + INTEGER INFO, LDA, LDB, LDQ, LDZ, N1, N2 +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL DTRONG, WEAK + INTEGER I, LINFO, M + DOUBLE PRECISION BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS, + $ F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS +C .. Local Arrays .. + INTEGER IWORK( LDST ) + DOUBLE PRECISION AI(2), AR(2), BE(2), DWORK(32), IR(LDST,LDST), + $ IRCOP(LDST,LDST), LI(LDST,LDST), + $ LICOP(LDST,LDST), S(LDST,LDST), + $ SCPY(LDST,LDST), T(LDST,LDST), TAUL(LDST), + $ TAUR(LDST), TCPY(LDST,LDST) +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. External Subroutines .. + EXTERNAL DGEMM, DGEQR2, DGERQ2, DLACPY, DLARTG, DLASET, + $ DLASSQ, DORG2R, DORGR2, DORM2R, DORMR2, DROT, + $ DSCAL, MB03YT, SB04OW +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +C +C .. Executable Statements .. +C + INFO = 0 +C +C Quick return if possible. +C For efficiency, the arguments are not checked. +C + IF ( N1.LE.0 .OR. N2.LE.0 ) + $ RETURN + M = N1 + N2 +C + WEAK = .FALSE. + DTRONG = .FALSE. +C +C Make a local copy of selected block. +C + CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, LI, LDST ) + CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, IR, LDST ) + CALL DLACPY( 'Full', M, M, A, LDA, S, LDST ) + CALL DLACPY( 'Full', M, M, B, LDB, T, LDST ) +C +C Compute threshold for testing acceptance of swapping. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + DSCALE = ZERO + DSUM = ONE + CALL DLACPY( 'Full', M, M, S, LDST, DWORK, M ) + CALL DLASSQ( M*M, DWORK, 1, DSCALE, DSUM ) + CALL DLACPY( 'Full', M, M, T, LDST, DWORK, M ) + CALL DLASSQ( M*M, DWORK, 1, DSCALE, DSUM ) + DNORM = DSCALE*SQRT( DSUM ) + THRESH = MAX( TEN*EPS*DNORM, SMLNUM ) +C + IF ( M.EQ.2 ) THEN +C +C CASE 1: Swap 1-by-1 and 1-by-1 blocks. +C +C Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks +C using Givens rotations and perform the swap tentatively. +C + F = S(2,2)*T(2,2) - T(1,1)*S(1,1) + G = -S(2,2)*T(1,2) - T(1,1)*S(1,2) + SB = ABS( T(1,1) ) + SA = ABS( S(2,2) ) + CALL DLARTG( F, G, IR(1,2), IR(1,1), DDUM ) + IR(2,1) = -IR(1,2) + IR(2,2) = IR(1,1) + CALL DROT( 2, S(1,1), 1, S(1,2), 1, IR(1,1), IR(2,1) ) + CALL DROT( 2, T(1,1), LDST, T(2,1), LDST, IR(1,1), IR(2,1) ) + IF( SA.GE.SB ) THEN + CALL DLARTG( S(1,1), S(2,1), LI(1,1), LI(2,1), DDUM ) + ELSE + CALL DLARTG( T(2,2), T(2,1), LI(1,1), LI(2,1), DDUM ) + LI(2,1) = -LI(2,1) + END IF + CALL DROT( 2, S(1,1), LDST, S(2,1), LDST, LI(1,1), LI(2,1) ) + CALL DROT( 2, T(1,1), 1, T(1,2), 1, LI(1,1), LI(2,1) ) + LI(2,2) = LI(1,1) + LI(1,2) = -LI(2,1) +C +C Weak stability test: +C |S21| + |T21| <= O(EPS * F-norm((S, T))). +C + WS = ABS( S(2,1) ) + ABS( T(2,1) ) + WEAK = WS.LE.THRESH + IF ( .NOT.WEAK ) + $ GO TO 50 +C + IF ( WANDS ) THEN +C +C Strong stability test: +C F-norm((A-QL'*S*QR, B-QR'*T*QL)) <= O(EPS*F-norm((A,B))). +C + CALL DLACPY( 'Full', M, M, A, LDA, DWORK(M*M+1), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, + $ LI, LDST, S, LDST, ZERO, DWORK, M ) + CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE, + $ DWORK, M, IR, LDST, ONE, DWORK(M*M+1), M ) + DSCALE = ZERO + DSUM = ONE + CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) +C + CALL DLACPY( 'Full', M, M, B, LDB, DWORK(M*M+1), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, + $ IR, LDST, T, LDST, ZERO, DWORK, M ) + CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE, + $ DWORK, M, LI, LDST, ONE, DWORK(M*M+1), M ) + CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) + SS = DSCALE*SQRT( DSUM ) + DTRONG = SS.LE.THRESH + IF( .NOT.DTRONG ) + $ GO TO 50 + END IF +C +C Update A and B. +C + CALL DLACPY( 'All', M, M, S, LDST, A, LDA ) + CALL DLACPY( 'All', M, M, T, LDST, B, LDB ) +C +C Set N1-by-N2 (2,1) - blocks to ZERO. +C + A(2,1) = ZERO + B(2,1) = ZERO +C +C Accumulate transformations into Q and Z if requested. +C + IF ( WANTQ ) + $ CALL DROT( 2, Q(1,1), 1, Q(1,2), 1, LI(1,1), LI(2,1) ) + IF ( WANTZ ) + $ CALL DROT( 2, Z(1,1), 1, Z(1,2), 1, IR(1,1), IR(2,1) ) +C +C Exit with INFO = 0 if swap was successfully performed. +C + RETURN +C + ELSE +C +C CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 +C and 2-by-2 blocks. +C +C Solve the periodic Sylvester equation +C S11 * R - L * S22 = SCALE * S12 +C T11 * L - R * T22 = SCALE * T12 +C for R and L. Solutions in IR and LI. +C + CALL DLACPY( 'Full', N1, N2, T(1,N1+1), LDST, LI, LDST ) + CALL DLACPY( 'Full', N1, N2, S(1,N1+1), LDST, IR(N2+1,N1+1), + $ LDST ) + CALL SB04OW( N1, N2, S, LDST, S(N1+1,N1+1), LDST, + $ IR(N2+1,N1+1), LDST, T, LDST, T(N1+1,N1+1), LDST, + $ LI, LDST, SCALE, IWORK, LINFO ) + IF ( LINFO.NE.0 ) + $ GO TO 50 +C +C Compute orthogonal matrix QL: +C +C QL' * LI = [ TL ] +C [ 0 ] +C where +C LI = [ -L ]. +C [ SCALE * identity(N2) ] +C + DO 10 I = 1, N2 + CALL DSCAL( N1, -ONE, LI(1,I), 1 ) + LI(N1+I,I) = SCALE + 10 CONTINUE + CALL DGEQR2( M, N2, LI, LDST, TAUL, DWORK, LINFO ) + CALL DORG2R( M, M, N2, LI, LDST, TAUL, DWORK, LINFO ) +C +C Compute orthogonal matrix RQ: +C +C IR * RQ' = [ 0 TR], +C +C where IR = [ SCALE * identity(N1), R ]. +C + DO 20 I = 1, N1 + IR(N2+I,I) = SCALE + 20 CONTINUE + CALL DGERQ2( N1, M, IR(N2+1,1), LDST, TAUR, DWORK, LINFO ) + CALL DORGR2( M, M, N1, IR, LDST, TAUR, DWORK, LINFO ) +C +C Perform the swapping tentatively: +C + CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, LI, + $ LDST, S, LDST, ZERO, DWORK, M ) + CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, ONE, DWORK, + $ M, IR, LDST, ZERO, S, LDST ) + CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, IR, + $ LDST, T, LDST, ZERO, DWORK, M ) + CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, + $ DWORK, M, LI, LDST, ZERO, T, LDST ) + CALL DLACPY( 'All', M, M, S, LDST, SCPY, LDST ) + CALL DLACPY( 'All', M, M, T, LDST, TCPY, LDST ) + CALL DLACPY( 'All', M, M, IR, LDST, IRCOP, LDST ) + CALL DLACPY( 'All', M, M, LI, LDST, LICOP, LDST ) +C +C Triangularize the B-part by a QR factorization. +C Apply transformation (from left) to A-part, giving S. +C + CALL DGEQR2( M, M, T, LDST, TAUR, DWORK, LINFO ) + CALL DORM2R( 'Right', 'No Transpose', M, M, M, T, LDST, TAUR, + $ S, LDST, DWORK, LINFO ) + CALL DORM2R( 'Left', 'Transpose', M, M, M, T, LDST, TAUR, + $ IR, LDST, DWORK, LINFO ) +C +C Compute F-norm(S21) in BRQA21. (T21 is 0.) +C + DSCALE = ZERO + DSUM = ONE + DO 30 I = 1, N2 + CALL DLASSQ( N1, S(N2+1,I), 1, DSCALE, DSUM ) + 30 CONTINUE + BRQA21 = DSCALE*SQRT( DSUM ) +C +C Triangularize the B-part by an RQ factorization. +C Apply transformation (from right) to A-part, giving S. +C + CALL DGERQ2( M, M, TCPY, LDST, TAUL, DWORK, LINFO ) + CALL DORMR2( 'Left', 'No Transpose', M, M, M, TCPY, LDST, + $ TAUL, SCPY, LDST, DWORK, LINFO ) + CALL DORMR2( 'Right', 'Transpose', M, M, M, TCPY, LDST, + $ TAUL, LICOP, LDST, DWORK, LINFO ) +C +C Compute F-norm(S21) in BQRA21. (T21 is 0.) +C + DSCALE = ZERO + DSUM = ONE + DO 40 I = 1, N2 + CALL DLASSQ( N1, SCPY(N2+1,I), 1, DSCALE, DSUM ) + 40 CONTINUE + BQRA21 = DSCALE*SQRT( DSUM ) +C +C Decide which method to use. +C Weak stability test: +C F-norm(S21) <= O(EPS * F-norm((S, T))) +C + IF ( BQRA21.LE.BRQA21 .AND. BQRA21.LE.THRESH ) THEN + CALL DLACPY( 'All', M, M, SCPY, LDST, S, LDST ) + CALL DLACPY( 'All', M, M, TCPY, LDST, T, LDST ) + CALL DLACPY( 'All', M, M, IRCOP, LDST, IR, LDST ) + CALL DLACPY( 'All', M, M, LICOP, LDST, LI, LDST ) + ELSE IF ( BRQA21.GE.THRESH ) THEN + GO TO 50 + END IF +C +C Set lower triangle of B-part to zero +C + CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, T(2,1), LDST ) +C + IF ( WANDS ) THEN +C +C Strong stability test: +C F-norm((A-QL*S*QR', B-QR*T*QL')) <= O(EPS*F-norm((A,B))) +C + CALL DLACPY( 'All', M, M, A, LDA, DWORK(M*M+1), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, + $ LI, LDST, S, LDST, ZERO, DWORK, M ) + CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, -ONE, + $ DWORK, M, IR, LDST, ONE, DWORK(M*M+1), M ) + DSCALE = ZERO + DSUM = ONE + CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) +C + CALL DLACPY( 'All', M, M, B, LDB, DWORK(M*M+1), M ) + CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, + $ IR, LDST, T, LDST, ZERO, DWORK, M ) + CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE, + $ DWORK, M, LI, LDST, ONE, DWORK(M*M+1), M ) + CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) + SS = DSCALE*SQRT( DSUM ) + DTRONG = ( SS.LE.THRESH ) + IF( .NOT.DTRONG ) + $ GO TO 50 +C + END IF +C +C If the swap is accepted ("weakly" and "strongly"), apply the +C transformations and set N1-by-N2 (2,1)-block to zero. +C + CALL DLASET( 'All', N1, N2, ZERO, ZERO, S(N2+1,1), LDST ) +C +C Copy (S,T) to (A,B). +C + CALL DLACPY( 'All', M, M, S, LDST, A, LDA ) + CALL DLACPY( 'All', M, M, T, LDST, B, LDB ) + CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, T, LDST ) +C +C Standardize existing 2-by-2 blocks. +C + CALL DLASET( 'All', M, M, ZERO, ZERO, DWORK, M ) + DWORK(1) = ONE + T(1,1) = ONE + IF ( N2.GT.1 ) THEN + CALL MB03YT( A, LDA, B, LDB, AR, AI, BE, DWORK(1), DWORK(2), + $ T(1,1), T(2,1) ) + DWORK(M+1) = -DWORK(2) + DWORK(M+2) = DWORK(1) + T(N2,N2) = T(1,1) + T(1,2) = -T(2,1) + END IF + DWORK(M*M) = ONE + T(M,M) = ONE +C + IF ( N1.GT.1 ) THEN + CALL MB03YT( A(N2+1,N2+1), LDA, B(N2+1,N2+1), LDB, TAUR, + $ TAUL, DWORK(M*M+1), DWORK(N2*M+N2+1), + $ DWORK(N2*M+N2+2), T(N2+1,N2+1), T(M,M-1) ) + DWORK(M*M) = DWORK(N2*M+N2+1) + DWORK(M*M-1 ) = -DWORK(N2*M+N2+2) + T(M,M) = T(N2+1,N2+1) + T(M-1,M) = -T(M,M-1) + END IF +C + CALL DGEMM( 'Transpose', 'No Transpose', N2, N1, N2, ONE, + $ DWORK, M, A(1,N2+1), LDA, ZERO, DWORK(M*M+1), N2 ) + CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), N2, A(1,N2+1), LDA ) + CALL DGEMM( 'Transpose', 'No Transpose', N2, N1, N2, ONE, + $ T(1,1), LDST, B(1,N2+1), LDB, ZERO, + $ DWORK(M*M+1), N2 ) + CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), N2, B(1,N2+1), LDB ) + CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, LI, + $ LDST, DWORK, M, ZERO, DWORK(M*M+1), M ) + CALL DLACPY( 'All', M, M, DWORK(M*M+1), M, LI, LDST ) + CALL DGEMM( 'No Transpose', 'No Transpose', N2, N1, N1, ONE, + $ A(1,N2+1), LDA, T(N2+1,N2+1), LDST, ZERO, + $ DWORK(M*M+1), M ) + CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), M, A(1,N2+1), LDA ) + CALL DGEMM( 'No Transpose', 'No Transpose', N2, N1, N1, ONE, + $ B(1,N2+1), LDB, DWORK(N2*M+N2+1), M, ZERO, + $ DWORK(M*M+1), M ) + CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), M, B(1,N2+1), LDB ) + CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, T, + $ LDST, IR, LDST, ZERO, DWORK, M ) + CALL DLACPY( 'All', M, M, DWORK, M, IR, LDST ) +C +C Accumulate transformations into Q and Z if requested. +C + IF( WANTQ ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, Q, + $ LDQ, LI, LDST, ZERO, DWORK, M ) + CALL DLACPY( 'All', M, M, DWORK, M, Q, LDQ ) + END IF +C + IF( WANTZ ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, ONE, Z, + $ LDZ, IR, LDST, ZERO, DWORK, M ) + CALL DLACPY( 'Full', M, M, DWORK, M, Z, LDZ ) +C + END IF +C +C Exit with INFO = 0 if swap was successfully performed. +C + RETURN +C + END IF +C +C Exit with INFO = 1 if swap was rejected. +C + 50 CONTINUE +C + INFO = 1 + RETURN +C *** Last line of MB03WA *** + END diff --git a/mex/sources/libslicot/MB03WD.f b/mex/sources/libslicot/MB03WD.f new file mode 100644 index 000000000..76bd6780d --- /dev/null +++ b/mex/sources/libslicot/MB03WD.f @@ -0,0 +1,966 @@ + SUBROUTINE MB03WD( JOB, COMPZ, N, P, ILO, IHI, ILOZ, IHIZ, H, + $ LDH1, LDH2, Z, LDZ1, LDZ2, WR, WI, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Schur decomposition and the eigenvalues of a +C product of matrices, H = H_1*H_2*...*H_p, with H_1 an upper +C Hessenberg matrix and H_2, ..., H_p upper triangular matrices, +C without evaluating the product. Specifically, the matrices Z_i +C are computed, such that +C +C Z_1' * H_1 * Z_2 = T_1, +C Z_2' * H_2 * Z_3 = T_2, +C ... +C Z_p' * H_p * Z_1 = T_p, +C +C where T_1 is in real Schur form, and T_2, ..., T_p are upper +C triangular. +C +C The routine works primarily with the Hessenberg and triangular +C submatrices in rows and columns ILO to IHI, but optionally applies +C the transformations to all the rows and columns of the matrices +C H_i, i = 1,...,p. The transformations can be optionally +C accumulated. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Indicates whether the user wishes to compute the full +C Schur form or the eigenvalues only, as follows: +C = 'E': Compute the eigenvalues only; +C = 'S': Compute the factors T_1, ..., T_p of the full +C Schur form, T = T_1*T_2*...*T_p. +C +C COMPZ CHARACTER*1 +C Indicates whether or not the user wishes to accumulate +C the matrices Z_1, ..., Z_p, as follows: +C = 'N': The matrices Z_1, ..., Z_p are not required; +C = 'I': Z_i is initialized to the unit matrix and the +C orthogonal transformation matrix Z_i is returned, +C i = 1, ..., p; +C = 'V': Z_i must contain an orthogonal matrix Q_i on +C entry, and the product Q_i*Z_i is returned, +C i = 1, ..., p. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix H. N >= 0. +C +C P (input) INTEGER +C The number of matrices in the product H_1*H_2*...*H_p. +C P >= 1. +C +C ILO (input) INTEGER +C IHI (input) INTEGER +C It is assumed that all matrices H_j, j = 2, ..., p, are +C already upper triangular in rows and columns 1:ILO-1 and +C IHI+1:N, and H_1 is upper quasi-triangular in rows and +C columns 1:ILO-1 and IHI+1:N, with H_1(ILO,ILO-1) = 0 +C (unless ILO = 1), and H_1(IHI+1,IHI) = 0 (unless IHI = N). +C The routine works primarily with the Hessenberg submatrix +C in rows and columns ILO to IHI, but applies the +C transformations to all the rows and columns of the +C matrices H_i, i = 1,...,p, if JOB = 'S'. +C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. +C +C ILOZ (input) INTEGER +C IHIZ (input) INTEGER +C Specify the rows of Z to which the transformations must be +C applied if COMPZ = 'I' or COMPZ = 'V'. +C 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. +C +C H (input/output) DOUBLE PRECISION array, dimension +C (LDH1,LDH2,P) +C On entry, the leading N-by-N part of H(*,*,1) must contain +C the upper Hessenberg matrix H_1 and the leading N-by-N +C part of H(*,*,j) for j > 1 must contain the upper +C triangular matrix H_j, j = 2, ..., p. +C On exit, if JOB = 'S', the leading N-by-N part of H(*,*,1) +C is upper quasi-triangular in rows and columns ILO:IHI, +C with any 2-by-2 diagonal blocks corresponding to a pair of +C complex conjugated eigenvalues, and the leading N-by-N +C part of H(*,*,j) for j > 1 contains the resulting upper +C triangular matrix T_j. +C If JOB = 'E', the contents of H are unspecified on exit. +C +C LDH1 INTEGER +C The first leading dimension of the array H. +C LDH1 >= max(1,N). +C +C LDH2 INTEGER +C The second leading dimension of the array H. +C LDH2 >= max(1,N). +C +C Z (input/output) DOUBLE PRECISION array, dimension +C (LDZ1,LDZ2,P) +C On entry, if COMPZ = 'V', the leading N-by-N-by-P part of +C this array must contain the current matrix Q of +C transformations accumulated by SLICOT Library routine +C MB03VY. +C If COMPZ = 'I', Z need not be set on entry. +C On exit, if COMPZ = 'V', or COMPZ = 'I', the leading +C N-by-N-by-P part of this array contains the transformation +C matrices which produced the Schur form; the +C transformations are applied only to the submatrices +C Z_j(ILOZ:IHIZ,ILO:IHI), j = 1, ..., P. +C If COMPZ = 'N', Z is not referenced. +C +C LDZ1 INTEGER +C The first leading dimension of the array Z. +C LDZ1 >= 1, if COMPZ = 'N'; +C LDZ1 >= max(1,N), if COMPZ = 'I' or COMPZ = 'V'. +C +C LDZ2 INTEGER +C The second leading dimension of the array Z. +C LDZ2 >= 1, if COMPZ = 'N'; +C LDZ2 >= max(1,N), if COMPZ = 'I' or COMPZ = 'V'. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C The real and imaginary parts, respectively, of the +C computed eigenvalues ILO to IHI are stored in the +C corresponding elements of WR and WI. If two eigenvalues +C are computed as a complex conjugate pair, they are stored +C in consecutive elements of WR and WI, say the i-th and +C (i+1)th, with WI(i) > 0 and WI(i+1) < 0. If JOB = 'S', the +C eigenvalues are stored in the same order as on the +C diagonal of the Schur form returned in H. +C +C Workspace +C +C DWORK DOUBLE PRECISION work array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= IHI-ILO+P-1. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, ILO <= i <= IHI, the QR algorithm +C failed to compute all the eigenvalues ILO to IHI +C in a total of 30*(IHI-ILO+1) iterations; +C the elements i+1:IHI of WR and WI contain those +C eigenvalues which have been successfully computed. +C +C METHOD +C +C A refined version of the QR algorithm proposed in [1] and [2] is +C used. The elements of the subdiagonal, diagonal, and the first +C supradiagonal of current principal submatrix of H are computed +C in the process. +C +C REFERENCES +C +C [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P. +C The periodic Schur decomposition: algorithms and applications. +C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, +C 1992. +C +C [2] Sreedhar, J. and Van Dooren, P. +C Periodic Schur form and some matrix equations. +C Proc. of the Symposium on the Mathematical Theory of Networks +C and Systems (MTNS'93), Regensburg, Germany (U. Helmke, +C R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable. +C +C FURTHER COMMENTS +C +C Note that for P = 1, the LAPACK Library routine DHSEQR could be +C more efficient on some computer architectures than this routine, +C because DHSEQR uses a block multishift QR algorithm. +C When P is large and JOB = 'S', it could be more efficient to +C compute the product matrix H, and use the LAPACK Library routines. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, and A. Varga, +C German Aerospace Center, DLR Oberpfaffenhofen, February 1999. +C Partly based on the routine PSHQR by A. Varga +C (DLR Oberpfaffenhofen), January 22, 1996. +C +C REVISIONS +C +C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C Eigenvalue, eigenvalue decomposition, Hessenberg form, +C orthogonal transformation, periodic systems, (periodic) Schur +C form, real Schur form, similarity transformation, triangular form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) + DOUBLE PRECISION DAT1, DAT2 + PARAMETER ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER COMPZ, JOB + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH1, LDH2, LDWORK, + $ LDZ1, LDZ2, N, P +C .. +C .. Array Arguments .. + DOUBLE PRECISION DWORK( * ), H( LDH1, LDH2, * ), WI( * ), + $ WR( * ), Z( LDZ1, LDZ2, * ) +C .. +C .. Local Scalars .. + LOGICAL INITZ, WANTT, WANTZ + INTEGER I, I1, I2, ITN, ITS, J, JMAX, JMIN, K, L, M, + $ NH, NR, NROW, NZ + DOUBLE PRECISION AVE, CS, DISC, H11, H12, H21, H22, H33, H33S, + $ H43H34, H44, H44S, HH10, HH11, HH12, HH21, HH22, + $ HP00, HP01, HP02, HP11, HP12, HP22, OVFL, S, + $ SMLNUM, SN, TAU, TST1, ULP, UNFL, V1, V2, V3 +C .. +C .. Local Arrays .. + DOUBLE PRECISION V( 3 ) +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANHS, DLANTR + EXTERNAL DLAMCH, DLANHS, DLANTR, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DLARFX, DLARTG, + $ DLASET, DROT, MB04PY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + WANTT = LSAME( JOB, 'S' ) + INITZ = LSAME( COMPZ, 'I' ) + WANTZ = LSAME( COMPZ, 'V' ) .OR. INITZ + INFO = 0 + IF( .NOT. ( WANTT .OR. LSAME( JOB, 'E' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( WANTZ .OR. LSAME( COMPZ, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.1 ) THEN + INFO = -4 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -6 + ELSE IF( ILOZ.LT.1 .OR. ILOZ.GT.ILO ) THEN + INFO = -7 + ELSE IF( IHIZ.LT.IHI .OR. IHIZ.GT.N ) THEN + INFO = -8 + ELSE IF( LDH1.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDH2.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDZ1.LT.1 .OR. ( WANTZ .AND. LDZ1.LT.N ) ) THEN + INFO = -13 + ELSE IF( LDZ2.LT.1 .OR. ( WANTZ .AND. LDZ2.LT.N ) ) THEN + INFO = -14 + ELSE IF( LDWORK.LT.IHI - ILO + P - 1 ) THEN + INFO = -18 + END IF + IF( INFO.EQ.0 ) THEN + IF( ILO.GT.1 ) THEN + IF( H( ILO, ILO-1, 1 ).NE.ZERO ) + $ INFO = -5 + ELSE IF( IHI.LT.N ) THEN + IF( H( IHI+1, IHI, 1 ).NE.ZERO ) + $ INFO = -6 + END IF + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03WD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C +C Initialize Z, if necessary. +C + IF( INITZ ) THEN +C + DO 10 J = 1, P + CALL DLASET( 'Full', N, N, ZERO, ONE, Z( 1, 1, J ), LDZ1 ) + 10 CONTINUE +C + END IF +C + NH = IHI - ILO + 1 +C + IF( NH.EQ.1 ) THEN + HP00 = ONE +C + DO 20 J = 1, P + HP00 = HP00 * H( ILO, ILO, J ) + 20 CONTINUE +C + WR( ILO ) = HP00 + WI( ILO ) = ZERO + RETURN + END IF +C +C Set machine-dependent constants for the stopping criterion. +C If norm(H) <= sqrt(OVFL), overflow should not occur. +C + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Precision' ) + SMLNUM = UNFL*( DBLE( NH ) / ULP ) +C +C Set the elements in rows and columns ILO to IHI to zero below the +C first subdiagonal in H(*,*,1) and below the first diagonal in +C H(*,*,j), j >= 2. In the same loop, compute and store in +C DWORK(NH:NH+P-2) the 1-norms of the matrices H_2, ..., H_p, to be +C used later. +C + I = NH + S = ULP * DBLE( N ) + IF( NH.GT.2 ) + $ CALL DLASET( 'Lower', NH-2, NH-2, ZERO, ZERO, + $ H( ILO+2, ILO, 1 ), LDH1 ) +C + DO 30 J = 2, P + CALL DLASET( 'Lower', NH-1, NH-1, ZERO, ZERO, + $ H( ILO+1, ILO, J ), LDH1 ) + DWORK( I ) = S * DLANTR( '1-norm', 'Upper', 'NonUnit', NH, NH, + $ H( ILO, ILO, J ), LDH1, DWORK ) + I = I + 1 + 30 CONTINUE +C +C I1 and I2 are the indices of the first row and last column of H +C to which transformations must be applied. If eigenvalues only are +C being computed, I1 and I2 are set inside the main loop. +C + IF( WANTT ) THEN + I1 = 1 + I2 = N + END IF +C + IF( WANTZ ) + $ NZ = IHIZ - ILOZ + 1 +C +C ITN is the total number of QR iterations allowed. +C + ITN = 30*NH +C +C The main loop begins here. I is the loop index and decreases from +C IHI to ILO in steps of 1 or 2. Each iteration of the loop works +C with the active submatrix in rows and columns L to I. +C Eigenvalues I+1 to IHI have already converged. Either L = ILO or +C H(L,L-1) is negligible so that the matrix splits. +C + I = IHI +C + 40 CONTINUE + L = ILO +C +C Perform QR iterations on rows and columns ILO to I until a +C submatrix of order 1 or 2 splits off at the bottom because a +C subdiagonal element has become negligible. +C +C Let T = H_2*...*H_p, and H = H_1*T. Part of the currently +C free locations of WR and WI are temporarily used as workspace. +C +C WR(L:I): the current diagonal elements of h = H(L:I,L:I); +C WI(L+1:I): the current elements of the first subdiagonal of h; +C DWORK(NH-I+L:NH-1): the current elements of the first +C supradiagonal of h. +C + DO 160 ITS = 0, ITN +C +C Initialization: compute H(I,I) (and H(I,I-1) if I > L). +C + HP22 = ONE + IF( I.GT.L ) THEN + HP12 = ZERO + HP11 = ONE +C + DO 50 J = 2, P + HP22 = HP22*H( I, I, J ) + HP12 = HP11*H( I-1, I, J ) + HP12*H( I, I, J ) + HP11 = HP11*H( I-1, I-1, J ) + 50 CONTINUE +C + HH21 = H( I, I-1, 1 )*HP11 + HH22 = H( I, I-1, 1 )*HP12 + H( I, I, 1 )*HP22 +C + WR( I ) = HH22 + WI( I ) = HH21 + ELSE +C + DO 60 J = 1, P + HP22 = HP22*H( I, I, J ) + 60 CONTINUE +C + WR( I ) = HP22 + END IF +C +C Look for a single small subdiagonal element. +C The loop also computes the needed current elements of the +C diagonal and the first two supradiagonals of T, as well as +C the current elements of the central tridiagonal of H. +C + DO 80 K = I, L + 1, -1 +C +C Evaluate H(K-1,K-1), H(K-1,K) (and H(K-1,K-2) if K > L+1). +C + HP00 = ONE + HP01 = ZERO + IF( K.GT.L+1 ) THEN + HP02 = ZERO +C + DO 70 J = 2, P + HP02 = HP00*H( K-2, K, J ) + HP01*H( K-1, K, J ) + $ + HP02*H( K, K, J ) + HP01 = HP00*H( K-2, K-1, J ) + HP01*H( K-1, K-1, J ) + HP00 = HP00*H( K-2, K-2, J ) + 70 CONTINUE +C + HH10 = H( K-1, K-2, 1 )*HP00 + HH11 = H( K-1, K-2, 1 )*HP01 + H( K-1, K-1, 1 )*HP11 + HH12 = H( K-1, K-2, 1 )*HP02 + H( K-1, K-1, 1 )*HP12 + $ + H( K-1, K, 1 )*HP22 + WI( K-1 ) = HH10 + ELSE + HH10 = ZERO + HH11 = H( K-1, K-1, 1 )*HP11 + HH12 = H( K-1, K-1, 1 )*HP12 + H( K-1, K, 1 )*HP22 + END IF + WR( K-1 ) = HH11 + DWORK( NH-I+K-1) = HH12 +C +C Test for a negligible subdiagonal element. +C + TST1 = ABS( HH11 ) + ABS( HH22 ) + IF( TST1.EQ.ZERO ) + $ TST1 = DLANHS( '1-norm', I-L+1, H( L, L, 1 ), LDH1, + $ DWORK ) + IF( ABS( HH21 ).LE.MAX( ULP*TST1, SMLNUM ) ) + $ GO TO 90 +C +C Update the values for the next cycle. +C + HP22 = HP11 + HP11 = HP00 + HP12 = HP01 + HH22 = HH11 + HH21 = HH10 + 80 CONTINUE +C + 90 CONTINUE + L = K +C + IF( L.GT.ILO ) THEN +C +C H(L,L-1) is negligible. +C + IF( WANTT ) THEN +C +C If H(L,L-1,1) is also negligible, set it to 0; otherwise, +C annihilate the subdiagonal elements bottom-up, and +C restore the triangular form of H(*,*,j). Since H(L,L-1) +C is negligible, the second case can only appear when the +C product of H(L-1,L-1,j), j >= 2, is negligible. +C + TST1 = ABS( H( L-1, L-1, 1 ) ) + ABS( H( L, L, 1 ) ) + IF( TST1.EQ.ZERO ) + $ TST1 = DLANHS( '1-norm', I-L+1, H( L, L, 1 ), LDH1, + $ DWORK ) + IF( ABS( H( L, L-1, 1 ) ).GT.MAX( ULP*TST1, SMLNUM ) ) + $ THEN +C + DO 110 K = I, L, -1 +C + DO 100 J = 1, P - 1 +C +C Compute G to annihilate from the right the +C (K,K-1) element of the matrix H_j. +C + V( 1 ) = H( K, K-1, J ) + CALL DLARFG( 2, H( K, K, J ), V, 1, TAU ) + H( K, K-1, J ) = ZERO + V( 2 ) = ONE +C +C Apply G from the right to transform the columns +C of the matrix H_j in rows I1 to K-1. +C + CALL DLARFX( 'Right', K-I1, 2, V, TAU, + $ H( I1, K-1, J ), LDH1, DWORK ) +C +C Apply G from the left to transform the rows of +C the matrix H_(j+1) in columns K-1 to I2. +C + CALL DLARFX( 'Left', 2, I2-K+2, V, TAU, + $ H( K-1, K-1, J+1 ), LDH1, DWORK ) +C + IF( WANTZ ) THEN +C +C Accumulate transformations in the matrix +C Z_(j+1). +C + CALL DLARFX( 'Right', NZ, 2, V, TAU, + $ Z( ILOZ, K-1, J+1 ), LDZ1, + $ DWORK ) + END IF + 100 CONTINUE +C + IF( K.LT.I ) THEN +C +C Compute G to annihilate from the right the +C (K+1,K) element of the matrix H_p. +C + V( 1 ) = H( K+1, K, P ) + CALL DLARFG( 2, H( K+1, K+1, P ), V, 1, TAU ) + H( K+1, K, P ) = ZERO + V( 2 ) = ONE +C +C Apply G from the right to transform the columns +C of the matrix H_p in rows I1 to K. +C + CALL DLARFX( 'Right', K-I1+1, 2, V, TAU, + $ H( I1, K, P ), LDH1, DWORK ) +C +C Apply G from the left to transform the rows of +C the matrix H_1 in columns K to I2. +C + CALL DLARFX( 'Left', 2, I2-K+1, V, TAU, + $ H( K, K, 1 ), LDH1, DWORK ) +C + IF( WANTZ ) THEN +C +C Accumulate transformations in the matrix Z_1. +C + CALL DLARFX( 'Right', NZ, 2, V, TAU, + $ Z( ILOZ, K, 1 ), LDZ1, DWORK ) + END IF + END IF + 110 CONTINUE +C + H( L, L-1, P ) = ZERO + END IF + H( L, L-1, 1 ) = ZERO + END IF + END IF +C +C Exit from loop if a submatrix of order 1 or 2 has split off. +C + IF( L.GE.I-1 ) + $ GO TO 170 +C +C Now the active submatrix is in rows and columns L to I. If +C eigenvalues only are being computed, only the active submatrix +C need be transformed. +C + IF( .NOT.WANTT ) THEN + I1 = L + I2 = I + END IF +C + IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN +C +C Exceptional shift. +C + S = ABS( WI( I ) ) + ABS( WI( I-1 ) ) + H44 = DAT1*S + WR( I ) + H33 = H44 + H43H34 = DAT2*S*S + ELSE +C +C Prepare to use Francis' double shift (i.e., second degree +C generalized Rayleigh quotient). +C + H44 = WR( I ) + H33 = WR( I-1 ) + H43H34 = WI( I )*DWORK( NH-1 ) + DISC = ( H33 - H44 )*HALF + DISC = DISC*DISC + H43H34 + IF( DISC.GT.ZERO ) THEN +C +C Real roots: use Wilkinson's shift twice. +C + DISC = SQRT( DISC ) + AVE = HALF*( H33 + H44 ) + IF( ABS( H33 )-ABS( H44 ).GT.ZERO ) THEN + H33 = H33*H44 - H43H34 + H44 = H33 / ( SIGN( DISC, AVE ) + AVE ) + ELSE + H44 = SIGN( DISC, AVE ) + AVE + END IF + H33 = H44 + H43H34 = ZERO + END IF + END IF +C +C Look for two consecutive small subdiagonal elements. +C + DO 120 M = I - 2, L, -1 +C +C Determine the effect of starting the double-shift QR +C iteration at row M, and see if this would make H(M,M-1) +C negligible. +C + H11 = WR( M ) + H12 = DWORK( NH-I+M ) + H21 = WI( M+1 ) + H22 = WR( M+1 ) + H44S = H44 - H11 + H33S = H33 - H11 + V1 = ( H33S*H44S - H43H34 ) / H21 + H12 + V2 = H22 - H11 - H33S - H44S + V3 = WI( M+2 ) + S = ABS( V1 ) + ABS( V2 ) + ABS( V3 ) + V1 = V1 / S + V2 = V2 / S + V3 = V3 / S + V( 1 ) = V1 + V( 2 ) = V2 + V( 3 ) = V3 + IF( M.EQ.L ) + $ GO TO 130 + TST1 = ABS( V1 )*( ABS( WR( M-1 ) ) + + $ ABS( H11 ) + ABS( H22 ) ) + IF( ABS( WI( M ) )*( ABS( V2 ) + ABS( V3 ) ).LE.ULP*TST1 ) + $ GO TO 130 + 120 CONTINUE +C + 130 CONTINUE +C +C Double-shift QR step. +C + DO 150 K = M, I - 1 +C +C The first iteration of this loop determines a reflection G +C from the vector V and applies it from left and right to H, +C thus creating a nonzero bulge below the subdiagonal. +C +C Each subsequent iteration determines a reflection G to +C restore the Hessenberg form in the (K-1)th column, and thus +C chases the bulge one step toward the bottom of the active +C submatrix. NR is the order of G. +C + NR = MIN( 3, I-K+1 ) + NROW = MIN( K+NR, I ) - I1 + 1 + IF( K.GT.M ) + $ CALL DCOPY( NR, H( K, K-1, 1 ), 1, V, 1 ) + CALL DLARFG( NR, V( 1 ), V( 2 ), 1, TAU ) + IF( K.GT.M ) THEN + H( K, K-1, 1 ) = V( 1 ) + H( K+1, K-1, 1 ) = ZERO + IF( K.LT.I-1 ) + $ H( K+2, K-1, 1 ) = ZERO + ELSE IF( M.GT.L ) THEN + H( K, K-1, 1 ) = -H( K, K-1, 1 ) + END IF +C +C Apply G from the left to transform the rows of the matrix +C H_1 in columns K to I2. +C + CALL MB04PY( 'Left', NR, I2-K+1, V( 2 ), TAU, H( K, K, 1 ), + $ LDH1, DWORK ) +C +C Apply G from the right to transform the columns of the +C matrix H_p in rows I1 to min(K+NR,I). +C + CALL MB04PY( 'Right', NROW, NR, V( 2 ), TAU, H( I1, K, P ), + $ LDH1, DWORK ) +C + IF( WANTZ ) THEN +C +C Accumulate transformations in the matrix Z_1. +C + CALL MB04PY( 'Right', NZ, NR, V( 2 ), TAU, + $ Z( ILOZ, K, 1 ), LDZ1, DWORK ) + END IF +C + DO 140 J = P, 2, -1 +C +C Apply G1 (and G2, if NR = 3) from the left to transform +C the NR-by-NR submatrix of H_j in position (K,K) to upper +C triangular form. +C +C Compute G1. +C + CALL DCOPY( NR-1, H( K+1, K, J ), 1, V, 1 ) + CALL DLARFG( NR, H( K, K, J ), V, 1, TAU ) + H( K+1, K, J ) = ZERO + IF( NR.EQ.3 ) + $ H( K+2, K, J ) = ZERO +C +C Apply G1 from the left to transform the rows of the +C matrix H_j in columns K+1 to I2. +C + CALL MB04PY( 'Left', NR, I2-K, V, TAU, H( K, K+1, J ), + $ LDH1, DWORK ) +C +C Apply G1 from the right to transform the columns of the +C matrix H_(j-1) in rows I1 to min(K+NR,I). +C + CALL MB04PY( 'Right', NROW, NR, V, TAU, H( I1, K, J-1 ), + $ LDH1, DWORK ) +C + IF( WANTZ ) THEN +C +C Accumulate transformations in the matrix Z_j. +C + CALL MB04PY( 'Right', NZ, NR, V, TAU, Z( ILOZ, K, J ), + $ LDZ1, DWORK ) + END IF +C + IF( NR.EQ.3 ) THEN +C +C Compute G2. +C + V( 1 ) = H( K+2, K+1, J ) + CALL DLARFG( 2, H( K+1, K+1, J ), V, 1, TAU ) + H( K+2, K+1, J ) = ZERO +C +C Apply G2 from the left to transform the rows of the +C matrix H_j in columns K+2 to I2. +C + CALL MB04PY( 'Left', 2, I2-K-1, V, TAU, + $ H( K+1, K+2, J ), LDH1, DWORK ) +C +C Apply G2 from the right to transform the columns of +C the matrix H_(j-1) in rows I1 to min(K+3,I). +C + CALL MB04PY( 'Right', NROW, 2, V, TAU, + $ H( I1, K+1, J-1 ), LDH1, DWORK ) +C + IF( WANTZ ) THEN +C +C Accumulate transformations in the matrix Z_j. +C + CALL MB04PY( 'Right', NZ, 2, V, TAU, + $ Z( ILOZ, K+1, J ), LDZ1, DWORK ) + END IF + END IF + 140 CONTINUE +C + 150 CONTINUE +C + 160 CONTINUE +C +C Failure to converge in remaining number of iterations. +C + INFO = I + RETURN +C + 170 CONTINUE +C + IF( L.EQ.I ) THEN +C +C H(I,I-1,1) is negligible: one eigenvalue has converged. +C Note that WR(I) has already been set. +C + WI( I ) = ZERO + ELSE IF( L.EQ.I-1 ) THEN +C +C H(I-1,I-2,1) is negligible: a pair of eigenvalues have +C converged. +C +C Transform the 2-by-2 submatrix of H_1*H_2*...*H_p in position +C (I-1,I-1) to standard Schur form, and compute and store its +C eigenvalues. If the Schur form is not required, then the +C previously stored values of a similar submatrix are used. +C For real eigenvalues, a Givens transformation is used to +C triangularize the submatrix. +C + IF( WANTT ) THEN + HP22 = ONE + HP12 = ZERO + HP11 = ONE +C + DO 180 J = 2, P + HP22 = HP22*H( I, I, J ) + HP12 = HP11*H( I-1, I, J ) + HP12*H( I, I, J ) + HP11 = HP11*H( I-1, I-1, J ) + 180 CONTINUE +C + HH21 = H( I, I-1, 1 )*HP11 + HH22 = H( I, I-1, 1 )*HP12 + H( I, I, 1 )*HP22 + HH11 = H( I-1, I-1, 1 )*HP11 + HH12 = H( I-1, I-1, 1 )*HP12 + H( I-1, I, 1 )*HP22 + ELSE + HH11 = WR( I-1 ) + HH12 = DWORK( NH-1 ) + HH21 = WI( I ) + HH22 = WR( I ) + END IF +C + CALL DLANV2( HH11, HH12, HH21, HH22, WR( I-1 ), WI( I-1 ), + $ WR( I ), WI( I ), CS, SN ) +C + IF( WANTT ) THEN +C +C Detect negligible diagonal elements in positions (I-1,I-1) +C and (I,I) in H_j, J > 1. +C + JMIN = 0 + JMAX = 0 +C + DO 190 J = 2, P + IF( JMIN.EQ.0 ) THEN + IF( ABS( H( I-1, I-1, J ) ).LE.DWORK( NH+J-2 ) ) + $ JMIN = J + END IF + IF( ABS( H( I, I, J ) ).LE.DWORK( NH+J-2 ) ) JMAX = J + 190 CONTINUE +C + IF( JMIN.NE.0 .AND. JMAX.NE.0 ) THEN +C +C Choose the shorter path if zero elements in both +C (I-1,I-1) and (I,I) positions are present. +C + IF( JMIN-1.LE.P-JMAX+1 ) THEN + JMAX = 0 + ELSE + JMIN = 0 + END IF + END IF +C + IF( JMIN.NE.0 ) THEN +C + DO 200 J = 1, JMIN - 1 +C +C Compute G to annihilate from the right the (I,I-1) +C element of the matrix H_j. +C + V( 1 ) = H( I, I-1, J ) + CALL DLARFG( 2, H( I, I, J ), V, 1, TAU ) + H( I, I-1, J ) = ZERO + V( 2 ) = ONE +C +C Apply G from the right to transform the columns of the +C matrix H_j in rows I1 to I-1. +C + CALL DLARFX( 'Right', I-I1, 2, V, TAU, + $ H( I1, I-1, J ), LDH1, DWORK ) +C +C Apply G from the left to transform the rows of the +C matrix H_(j+1) in columns I-1 to I2. +C + CALL DLARFX( 'Left', 2, I2-I+2, V, TAU, + $ H( I-1, I-1, J+1 ), LDH1, DWORK ) +C + IF( WANTZ ) THEN +C +C Accumulate transformations in the matrix Z_(j+1). +C + CALL DLARFX( 'Right', NZ, 2, V, TAU, + $ Z( ILOZ, I-1, J+1 ), LDZ1, DWORK ) + END IF + 200 CONTINUE +C + H( I, I-1, JMIN ) = ZERO +C + ELSE + IF( JMAX.GT.0 .AND. WI( I-1 ).EQ.ZERO ) + $ CALL DLARTG( H( I-1, I-1, 1 ), H( I, I-1, 1 ), CS, SN, + $ TAU ) +C +C Apply the transformation to H. +C + CALL DROT( I2-I+2, H( I-1, I-1, 1 ), LDH1, + $ H( I, I-1, 1 ), LDH1, CS, SN ) + CALL DROT( I-I1+1, H( I1, I-1, P ), 1, H( I1, I, P ), 1, + $ CS, SN ) + IF( WANTZ ) THEN +C +C Apply transformation to Z_1. +C + CALL DROT( NZ, Z( ILOZ, I-1, 1 ), 1, Z( ILOZ, I, 1 ), + $ 1, CS, SN ) + END IF +C + DO 210 J = P, MAX( 2, JMAX+1 ), -1 +C +C Compute G1 to annihilate from the left the (I,I-1) +C element of the matrix H_j. +C + V( 1 ) = H( I, I-1, J ) + CALL DLARFG( 2, H( I-1, I-1, J ), V, 1, TAU ) + H( I, I-1, J ) = ZERO +C +C Apply G1 from the left to transform the rows of the +C matrix H_j in columns I to I2. +C + CALL MB04PY( 'Left', 2, I2-I+1, V, TAU, + $ H( I-1, I, J ), LDH1, DWORK ) +C +C Apply G1 from the right to transform the columns of +C the matrix H_(j-1) in rows I1 to I. +C + CALL MB04PY( 'Right', I-I1+1, 2, V, TAU, + $ H( I1, I-1, J-1 ), LDH1, DWORK ) +C + IF( WANTZ ) THEN +C +C Apply G1 to Z_j. +C + CALL MB04PY( 'Right', NZ, 2, V, TAU, + $ Z( ILOZ, I-1, J ), LDZ1, DWORK ) + END IF + 210 CONTINUE +C + IF( JMAX.GT.0 ) THEN + H( I, I-1, 1 ) = ZERO + H( I, I-1, JMAX ) = ZERO + ELSE + IF( HH21.EQ.ZERO ) + $ H( I, I-1, 1 ) = ZERO + END IF + END IF + END IF + END IF +C +C Decrement number of remaining iterations, and return to start of +C the main loop with new value of I. +C + ITN = ITN - ITS + I = L - 1 + IF( I.GE.ILO ) + $ GO TO 40 +C + RETURN +C +C *** Last line of MB03WD *** + END diff --git a/mex/sources/libslicot/MB03WX.f b/mex/sources/libslicot/MB03WX.f new file mode 100644 index 000000000..b8c3a9e28 --- /dev/null +++ b/mex/sources/libslicot/MB03WX.f @@ -0,0 +1,170 @@ + SUBROUTINE MB03WX( N, P, T, LDT1, LDT2, WR, WI, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the eigenvalues of a product of matrices, +C T = T_1*T_2*...*T_p, where T_1 is an upper quasi-triangular +C matrix and T_2, ..., T_p are upper triangular matrices. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix T. N >= 0. +C +C P (input) INTEGER +C The number of matrices in the product T_1*T_2*...*T_p. +C P >= 1. +C +C T (input) DOUBLE PRECISION array, dimension (LDT1,LDT2,P) +C The leading N-by-N part of T(*,*,1) must contain the upper +C quasi-triangular matrix T_1 and the leading N-by-N part of +C T(*,*,j) for j > 1 must contain the upper-triangular +C matrix T_j, j = 2, ..., p. +C The elements below the subdiagonal of T(*,*,1) and below +C the diagonal of T(*,*,j), j = 2, ..., p, are not +C referenced. +C +C LDT1 INTEGER +C The first leading dimension of the array T. +C LDT1 >= max(1,N). +C +C LDT2 INTEGER +C The second leading dimension of the array T. +C LDT2 >= max(1,N). +C +C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) +C The real and imaginary parts, respectively, of the +C eigenvalues of T. The eigenvalues are stored in the same +C order as on the diagonal of T_1. If T(i:i+1,i:i+1,1) is a +C 2-by-2 diagonal block with complex conjugated eigenvalues +C then WI(i) > 0 and WI(i+1) = -WI(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalue, eigenvalue decomposition, periodic systems, +C real Schur form, triangular form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDT1, LDT2, N, P +C .. Array Arguments .. + DOUBLE PRECISION T( LDT1, LDT2, * ), WI( * ), WR( * ) +C .. Local Scalars .. + INTEGER I, I1, INEXT, J + DOUBLE PRECISION A11, A12, A21, A22, CS, SN, T11, T12, T22 +C .. External Subroutines .. + EXTERNAL DLANV2, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( P.LT.1 ) THEN + INFO = -2 + ELSE IF( LDT1.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDT2.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB03WX', -INFO ) + RETURN + END IF +C + INEXT = 1 + DO 30 I = 1, N + IF( I.LT.INEXT ) + $ GO TO 30 + IF( I.NE.N ) THEN + IF( T( I+1, I, 1 ).NE.ZERO ) THEN +C +C A pair of eigenvalues. First compute the corresponding +C elements of T(I:I+1,I:I+1). +C + INEXT = I + 2 + I1 = I + 1 + T11 = ONE + T12 = ZERO + T22 = ONE +C + DO 10 J = 2, P + T22 = T22*T( I1, I1, J ) + T12 = T11*T( I, I1, J ) + T12*T( I1, I1, J ) + T11 = T11*T( I, I, J ) + 10 CONTINUE +C + A11 = T( I, I, 1 )*T11 + A12 = T( I, I, 1 )*T12 + T( I, I1, 1 )*T22 + A21 = T( I1, I, 1 )*T11 + A22 = T( I1, I, 1 )*T12 + T( I1, I1, 1 )*T22 +C + CALL DLANV2( A11, A12, A21, A22, WR( I ), WI( I ), + $ WR( I1 ), WI( I1 ), CS, SN ) + GO TO 30 + END IF + END IF +C +C Simple eigenvalue. Compute the corresponding element of T(I,I). +C + INEXT = I + 1 + T11 = ONE +C + DO 20 J = 1, P + T11 = T11*T( I, I, J ) + 20 CONTINUE +C + WR( I ) = T11 + WI( I ) = ZERO + 30 CONTINUE +C + RETURN +C *** Last line of MB03WX *** + END diff --git a/mex/sources/libslicot/MB03XD.f b/mex/sources/libslicot/MB03XD.f new file mode 100644 index 000000000..3b68a9726 --- /dev/null +++ b/mex/sources/libslicot/MB03XD.f @@ -0,0 +1,826 @@ + SUBROUTINE MB03XD( BALANC, JOB, JOBU, JOBV, N, A, LDA, QG, LDQG, + $ T, LDT, U1, LDU1, U2, LDU2, V1, LDV1, V2, LDV2, + $ WR, WI, ILO, SCALE, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the eigenvalues of a Hamiltonian matrix, +C +C [ A G ] T T +C H = [ T ], G = G, Q = Q, (1) +C [ Q -A ] +C +C where A, G and Q are real n-by-n matrices. +C +C Due to the structure of H all eigenvalues appear in pairs +C (lambda,-lambda). This routine computes the eigenvalues of H +C using an algorithm based on the symplectic URV and the periodic +C Schur decompositions as described in [1], +C +C T [ T G ] +C U H V = [ T ], (2) +C [ 0 -S ] +C +C where U and V are 2n-by-2n orthogonal symplectic matrices, +C S is in real Schur form and T is upper triangular. +C +C The algorithm is backward stable and preserves the eigenvalue +C pairings in finite precision arithmetic. +C +C Optionally, a symplectic balancing transformation to improve the +C conditioning of eigenvalues is computed (see MB04DD). In this +C case, the matrix H in decomposition (2) must be replaced by the +C balanced matrix. +C +C The SLICOT Library routine MB03ZD can be used to compute invariant +C subspaces of H from the output of this routine. +C +C ARGUMENTS +C +C Mode Parameters +C +C BALANC CHARACTER*1 +C Indicates how H should be diagonally scaled and/or +C permuted to reduce its norm. +C = 'N': Do not diagonally scale or permute; +C = 'P': Perform symplectic permutations to make the matrix +C closer to Hamiltonian Schur form. Do not diagonally +C scale; +C = 'S': Diagonally scale the matrix, i.e., replace A, G and +C Q by D*A*D**(-1), D*G*D and D**(-1)*Q*D**(-1) where +C D is a diagonal matrix chosen to make the rows and +C columns of H more equal in norm. Do not permute; +C = 'B': Both diagonally scale and permute A, G and Q. +C Permuting does not change the norm of H, but scaling does. +C +C JOB CHARACTER*1 +C Indicates whether the user wishes to compute the full +C decomposition (2) or the eigenvalues only, as follows: +C = 'E': compute the eigenvalues only; +C = 'S': compute matrices T and S of (2); +C = 'G': compute matrices T, S and G of (2). +C +C JOBU CHARACTER*1 +C Indicates whether or not the user wishes to compute the +C orthogonal symplectic matrix U of (2) as follows: +C = 'N': the matrix U is not computed; +C = 'U': the matrix U is computed. +C +C JOBV CHARACTER*1 +C Indicates whether or not the user wishes to compute the +C orthogonal symplectic matrix V of (2) as follows: +C = 'N': the matrix V is not computed; +C = 'V': the matrix V is computed. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, this array is overwritten. If JOB = 'S' or +C JOB = 'G', the leading N-by-N part of this array contains +C the matrix S in real Schur form of decomposition (2). +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C QG (input/output) DOUBLE PRECISION array, dimension +C (LDQG,N+1) +C On entry, the leading N-by-N+1 part of this array must +C contain in columns 1:N the lower triangular part of the +C matrix Q and in columns 2:N+1 the upper triangular part +C of the matrix G. +C On exit, this array is overwritten. If JOB = 'G', the +C leading N-by-N+1 part of this array contains in columns +C 2:N+1 the matrix G of decomposition (2). +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= max(1,N). +C +C T (output) DOUBLE PRECISION array, dimension (LDT,N) +C On exit, if JOB = 'S' or JOB = 'G', the leading N-by-N +C part of this array contains the upper triangular matrix T +C of the decomposition (2). Otherwise, this array is used as +C workspace. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= MAX(1,N). +C +C U1 (output) DOUBLE PRECISION array, dimension (LDU1,N) +C On exit, if JOBU = 'U', the leading N-by-N part of this +C array contains the (1,1) block of the orthogonal +C symplectic matrix U of decomposition (2). +C +C LDU1 INTEGER +C The leading dimension of the array U1. LDU1 >= 1. +C LDU1 >= N, if JOBU = 'U'. +C +C U2 (output) DOUBLE PRECISION array, dimension (LDU2,N) +C On exit, if JOBU = 'U', the leading N-by-N part of this +C array contains the (2,1) block of the orthogonal +C symplectic matrix U of decomposition (2). +C +C LDU2 INTEGER +C The leading dimension of the array U2. LDU2 >= 1. +C LDU2 >= N, if JOBU = 'U'. +C +C V1 (output) DOUBLE PRECISION array, dimension (LDV1,N) +C On exit, if JOBV = 'V', the leading N-by-N part of this +C array contains the (1,1) block of the orthogonal +C symplectic matrix V of decomposition (2). +C +C LDV1 INTEGER +C The leading dimension of the array V1. LDV1 >= 1. +C LDV1 >= N, if JOBV = 'V'. +C +C V2 (output) DOUBLE PRECISION array, dimension (LDV2,N) +C On exit, if JOBV = 'V', the leading N-by-N part of this +C array contains the (2,1) block of the orthogonal +C symplectic matrix V of decomposition (2). +C +C LDV2 INTEGER +C The leading dimension of the array V2. LDV2 >= 1. +C LDV2 >= N, if JOBV = 'V'. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C On exit, the leading N elements of WR and WI contain the +C real and imaginary parts, respectively, of N eigenvalues +C that have nonpositive real part. Complex conjugate pairs +C of eigenvalues with real part not equal to zero will +C appear consecutively with the eigenvalue having the +C positive imaginary part first. For complex conjugate pairs +C of eigenvalues on the imaginary axis only the eigenvalue +C having nonnegative imaginary part will be returned. +C +C ILO (output) INTEGER +C ILO is an integer value determined when H was balanced. +C The balanced A(i,j) = 0 if I > J and J = 1,...,ILO-1. +C The balanced Q(i,j) = 0 if J = 1,...,ILO-1 or +C I = 1,...,ILO-1. +C +C SCALE (output) DOUBLE PRECISION array, dimension (N) +C On exit, if SCALE = 'S', the leading N elements of this +C array contain details of the permutation and scaling +C factors applied when balancing H, see MB04DD. +C This array is not referenced if BALANC = 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -25, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK (input) INTEGER +C The dimension of the array DWORK. LDWORK >= max( 1, 8*N ). +C Moreover: +C If JOB = 'E' or 'S' and JOBU = 'N' and JOBV = 'N', +C LDWORK >= 7*N+N*N. +C If JOB = 'G' and JOBU = 'N' and JOBV = 'N', +C LDWORK >= max( 7*N+N*N, 2*N+3*N*N ). +C If JOB = 'G' and JOBU = 'U' and JOBV = 'N', +C LDWORK >= 7*N+2*N*N. +C If JOB = 'G' and JOBU = 'N' and JOBV = 'V', +C LDWORK >= 7*N+2*N*N. +C If JOB = 'G' and JOBU = 'U' and JOBV = 'V', +C LDWORK >= 7*N+N*N. +C For good performance, LDWORK must generally be larger. +C +C Error Indicator +C +C INFO (output) INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, the periodic QR algorithm failed to +C compute all the eigenvalues, elements i+1:N of WR +C and WI contain eigenvalues which have converged. +C +C REFERENCES +C +C [1] Benner, P., Mehrmann, V., and Xu, H. +C A numerically stable, structure preserving method for +C computing the eigenvalues of real Hamiltonian or symplectic +C pencils. +C Numer. Math., Vol. 78(3), pp. 329-358, 1998. +C +C [2] Benner, P., Mehrmann, V., and Xu, H. +C A new method for computing the stable invariant subspace of a +C real Hamiltonian matrix, J. Comput. Appl. Math., vol. 86, +C pp. 17-43, 1997. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAESU). +C +C KEYWORDS +C +C Eigenvalues, invariant subspace, Hamiltonian matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER BALANC, JOB, JOBU, JOBV + INTEGER ILO, INFO, LDA, LDQG, LDT, LDU1, LDU2, LDV1, + $ LDV2, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*), SCALE(*), + $ T(LDT,*), U1(LDU1,*), U2(LDU2,*), V1(LDV1,*), + $ V2(LDV2,*), WI(*), WR(*) +C .. Local Scalars .. + CHARACTER UCHAR, VCHAR + LOGICAL LPERM, LSCAL, SCALEH, WANTG, WANTS, WANTU, + $ WANTV + INTEGER I, IERR, ILO1, J, K, L, PBETA, PCSL, PCSR, PDW, + $ PQ, PTAUL, PTAUR, PZ, WRKMIN, WRKOPT + DOUBLE PRECISION BIGNUM, CSCALE, EPS, HNRM, SMLNUM, TEMP, TEMPI, + $ TEMPR +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, MA02ID + EXTERNAL DLAMCH, LSAME, MA02ID +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLABAD, DLACPY, DLASCL, DLASET, + $ DSCAL, MA01AD, MB03XP, MB04DD, MB04QB, MB04TB, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, SQRT +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + LPERM = LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) + LSCAL = LSAME( BALANC, 'S' ) .OR. LSAME( BALANC, 'B' ) + WANTS = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'G' ) + WANTG = LSAME( JOB, 'G' ) + WANTU = LSAME( JOBU, 'U' ) + WANTV = LSAME( JOBV, 'V' ) +C + IF ( WANTG ) THEN + IF ( WANTU ) THEN + IF ( WANTV ) THEN + WRKMIN = MAX( 1, 7*N+N*N ) + ELSE + WRKMIN = MAX( 1, 7*N+2*N*N ) + END IF + ELSE + IF ( WANTV ) THEN + WRKMIN = MAX( 1, 7*N+2*N*N ) + ELSE + WRKMIN = MAX( 1, 7*N+N*N, 2*N+3*N*N ) + END IF + END IF + ELSE + IF ( WANTU ) THEN + IF ( WANTV ) THEN + WRKMIN = MAX( 1, 8*N ) + ELSE + WRKMIN = MAX( 1, 8*N ) + END IF + ELSE + IF ( WANTV ) THEN + WRKMIN = MAX( 1, 8*N ) + ELSE + WRKMIN = MAX( 1, 7*N+N*N ) + END IF + END IF + END IF +C + WRKOPT = WRKMIN +C +C Test the scalar input parameters. +C + IF ( .NOT.LPERM .AND. .NOT.LSCAL + $ .AND. .NOT.LSAME( BALANC, 'N' ) ) THEN + INFO = -1 + ELSE IF ( .NOT.WANTS .AND. .NOT.LSAME( JOB, 'E' ) ) THEN + INFO = -2 + ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN + INFO = -3 + ELSE IF ( .NOT.WANTV .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN + INFO = -4 + ELSE IF ( N.LT.0 ) THEN + INFO = -5 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF ( LDT.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. LDU1.LT.N ) ) THEN + INFO = -13 + ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. LDU2.LT.N ) ) THEN + INFO = -15 + ELSE IF ( LDV1.LT.1 .OR. ( WANTV .AND. LDV1.LT.N ) ) THEN + INFO = -17 + ELSE IF ( LDV2.LT.1 .OR. ( WANTV .AND. LDV2.LT.N ) ) THEN + INFO = -19 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + INFO = -25 + DWORK(1) = DBLE( WRKMIN ) + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03XD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + ILO = 0 + IF( N.EQ.0 ) + $ RETURN +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +C +C Scale H if maximal element is outside range [SMLNUM,BIGNUM]. +C + HNRM = MA02ID( 'Hamiltonian', 'MaxElement', N, A, LDA, QG, LDQG, + $ DWORK ) + SCALEH = .FALSE. + IF ( HNRM.GT.ZERO .AND. HNRM.LT.SMLNUM ) THEN + SCALEH = .TRUE. + CSCALE = SMLNUM + ELSE IF( HNRM.GT.BIGNUM ) THEN + SCALEH = .TRUE. + CSCALE = BIGNUM + END IF + IF ( SCALEH ) THEN + CALL DLASCL( 'General', 0, 0, HNRM, CSCALE, N, N, A, LDA, IERR ) + CALL DLASCL( 'General', 0, 0, HNRM, CSCALE, N, N+1, QG, LDQG, + $ IERR ) + END IF +C +C Balance the matrix. +C + CALL MB04DD( BALANC, N, A, LDA, QG, LDQG, ILO, SCALE, IERR ) +C +C Copy A to T and multiply A by -1. +C + CALL DLACPY( 'All', N, N, A, LDA, T, LDT ) + CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, N, A, LDA, IERR ) +C +C --------------------------------------------- +C Step 1: Compute symplectic URV decomposition. +C --------------------------------------------- +C + PCSL = 1 + PCSR = PCSL + 2*N + PTAUL = PCSR + 2*N + PTAUR = PTAUL + N + PDW = PTAUR + N + + IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN +C +C Copy Q and Q' to workspace. +C + PQ = PDW + PDW = PDW + N*N + DO 20 J = 1, N + K = PQ + (N+1)*(J-1) + L = K + DWORK(K) = QG(J,J) + DO 10 I = J+1, N + K = K + 1 + L = L + N + TEMP = QG(I,J) + DWORK(K) = TEMP + DWORK(L) = TEMP + 10 CONTINUE + 20 CONTINUE + ELSE IF ( WANTU ) THEN +C +C Copy Q and Q' to U2. +C + DO 40 J = 1, N + U2(J,J) = QG(J,J) + DO 30 I = J+1, N + TEMP = QG(I,J) + U2(I,J) = TEMP + U2(J,I) = TEMP + 30 CONTINUE + 40 CONTINUE + ELSE +C +C Copy Q and Q' to V2. +C + DO 60 J = 1, N + V2(J,J) = QG(J,J) + DO 50 I = J+1, N + TEMP = QG(I,J) + V2(I,J) = TEMP + V2(J,I) = TEMP + 50 CONTINUE + 60 CONTINUE + END IF +C +C Transpose G. +C + DO 80 J = 1, N + DO 70 I = J+1, N + QG(I,J+1) = QG(J,I+1) + 70 CONTINUE + 80 CONTINUE +C + IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN + CALL MB04TB( 'Not Transposed', 'Transposed', N, ILO, T, LDT, A, + $ LDA, QG(1,2), LDQG, DWORK(PQ), N, DWORK(PCSL), + $ DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR), + $ DWORK(PDW), LDWORK-PDW+1, IERR ) + ELSE IF ( WANTU ) THEN + CALL MB04TB( 'Not Transposed', 'Transposed', N, ILO, T, LDT, A, + $ LDA, QG(1,2), LDQG, U2, LDU2, DWORK(PCSL), + $ DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR), + $ DWORK(PDW), LDWORK-PDW+1, IERR ) + ELSE + CALL MB04TB( 'Not Transposed', 'Transposed', N, ILO, T, LDT, A, + $ LDA, QG(1,2), LDQG, V2, LDV2, DWORK(PCSL), + $ DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR), + $ DWORK(PDW), LDWORK-PDW+1, IERR ) + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) +C + IF ( WANTU .AND. .NOT.WANTV .AND. .NOT.WANTG ) THEN + IF ( N.GT.1 ) + $ CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, QG(2,1), LDQG ) + ELSE IF ( .NOT.WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN + IF ( N.GT.1 ) THEN + CALL DLACPY( 'Lower', N-1, N-1, A(2,1), LDA, QG(2,1), LDQG ) + CALL DLACPY( 'Upper', N-1, N-1, V2(1,2), LDV2, QG(1,2), + $ LDQG ) + END IF + ELSE IF ( WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN + IF ( N.GT.1 ) THEN + CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, V2(2,1), LDV2 ) + CALL DLACPY( 'Lower', N-1, N-1, A(2,1), LDA, QG(2,1), LDQG ) + END IF + ELSE IF ( WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN + IF ( N.GT.1 ) + $ CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, + $ DWORK(PDW+N*N+N), N-1 ) + ELSE IF ( .NOT.WANTU .AND. WANTV .AND. WANTG ) THEN + IF ( N.GT.2 ) + $ CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA, + $ DWORK(PDW+N*N+N), N-2 ) + ELSE IF ( WANTU .AND. WANTV .AND. WANTG ) THEN + IF ( N.GT.1 ) + $ CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, + $ DWORK(PDW+N), N-1 ) + IF ( N.GT.2 ) + $ CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA, V2(3,1), LDV2 ) + END IF +C +C ---------------------------------------------- +C Step 2: Compute periodic Schur decomposition. +C ---------------------------------------------- +C + IF ( N.GT.2 ) + $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) + IF ( N.GT.1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) + IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN + PBETA = 1 + ELSE + PBETA = PDW + END IF +C + IF ( .NOT.WANTG ) THEN +C +C Workspace requirements: 2*N (8*N with U or V). +C + PDW = PBETA + N + IF ( WANTU ) THEN + UCHAR = 'I' + ELSE + UCHAR = 'N' + END IF + IF ( WANTV ) THEN + VCHAR = 'I' + ELSE + VCHAR = 'N' + END IF + CALL MB03XP( JOB, VCHAR, UCHAR, N, ILO, N, A, LDA, T, LDT, V1, + $ LDV1, U1, LDU1, WR, WI, DWORK(PBETA), DWORK(PDW), + $ LDWORK-PDW+1, INFO ) + IF ( INFO.NE.0 ) + $ GO TO 90 + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) +C + ELSE IF ( .NOT.WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN +C +C Workspace requirements: 3*N*N + 2*N. +C + PQ = PBETA + N + PZ = PQ + N*N + PDW = PZ + N*N + CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, + $ LDT, DWORK(PQ), N, DWORK(PZ), N, WR, WI, + $ DWORK(PBETA), DWORK(PDW), LDWORK-PDW+1, INFO ) + IF ( INFO.NE.0 ) + $ GO TO 90 + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) + CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, + $ DWORK(PZ), N, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, + $ DWORK(PDW), N, DWORK(PQ), N, ZERO, QG(1,2), LDQG ) + ELSE IF ( WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN +C +C Workspace requirements: 2*N*N + 7*N. +C + PQ = PBETA + N + PDW = PQ + N*N + CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, + $ LDT, DWORK(PQ), N, U1, LDU1, WR, WI, DWORK(PBETA), + $ DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1, + $ INFO ) + IF ( INFO.NE.0 ) + $ GO TO 90 + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW + $ + (N-1)*(N-1) - 1 ) + IF ( N.GT.1 ) + $ CALL DLACPY( 'Lower', N-1, N-1, DWORK(PDW), N-1, T(2,1), + $ LDT ) + CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, + $ U1, LDU1, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, + $ DWORK(PDW), N, DWORK(PQ), N, ZERO, QG(1,2), LDQG ) +C + ELSE IF ( .NOT.WANTU .AND. WANTV .AND. WANTG ) THEN +C +C Workspace requirements: 2*N*N + 7*N +C + PZ = PBETA + N + PDW = PZ + N*N + CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, + $ LDT, V1, LDV1, DWORK(PZ), N, WR, WI, DWORK(PBETA), + $ DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1, + $ INFO ) + IF ( INFO.NE.0 ) + $ GO TO 90 + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW + $ + (N-1)*(N-1) - 1 ) + IF ( N.GT.2 ) + $ CALL DLACPY( 'Lower', N-2, N-2, DWORK(PDW), N-2, A(3,1), + $ LDA ) + CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, + $ DWORK(PZ), N, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, + $ DWORK(PDW), N, V1, LDV1, ZERO, QG(1,2), LDQG ) +C + ELSE IF ( WANTU .AND. WANTV .AND. WANTG ) THEN +C +C Workspace requirements: N*N + 7*N. +C + PDW = PBETA + N + CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, + $ LDT, V1, LDV1, U1, LDU1, WR, WI, DWORK(PBETA), + $ DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1, + $ INFO ) + IF ( INFO.NE.0 ) + $ GO TO 90 + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW + $ + (N-1)*(N-1) - 1 ) + IF ( N.GT.1 ) + $ CALL DLACPY( 'Lower', N-1, N-1, DWORK(PDW), N-1, T(2,1), + $ LDT ) + IF ( N.GT.2 ) + $ CALL DLACPY( 'Lower', N-2, N-2, V2(3,1), LDV2, A(3,1), LDA ) + CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, + $ U1, LDU1, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, + $ DWORK(PDW), N, V1, LDV1, ZERO, QG(1,2), LDQG ) + END IF +C + 90 CONTINUE +C +C Compute square roots of eigenvalues and rescale. +C + DO 100 I = INFO + 1, N + TEMPR = WR(I) + TEMPI = WI(I) + TEMP = DWORK(PBETA + I - 1) + IF ( TEMP.GT.ZERO ) + $ TEMPR = -TEMPR + TEMP = ABS( TEMP ) + IF ( TEMPI.EQ.ZERO ) THEN + IF ( TEMPR.LT.ZERO ) THEN + WR(I) = ZERO + WI(I) = SQRT( TEMP ) * SQRT( -TEMPR ) + ELSE + WR(I) = -SQRT( TEMP ) * SQRT( TEMPR ) + WI(I) = ZERO + END IF + ELSE + CALL MA01AD( TEMPR, TEMPI, WR(I), WI(I) ) + WR(I) = -WR(I) * SQRT( TEMP ) + IF ( TEMP.GT.0 ) THEN + WI(I) = WI(I) * SQRT( TEMP ) + ELSE + WI(I) = ZERO + END IF + END IF + 100 CONTINUE +C + IF ( SCALEH ) THEN +C +C Undo scaling. +C + CALL DLASCL( 'Hessenberg', 0, 0, CSCALE, HNRM, N, N, A, LDA, + $ IERR ) + CALL DLASCL( 'Upper', 0, 0, CSCALE, HNRM, N, N, T, LDT, IERR ) + If ( WANTG ) + $ CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, N, QG(1,2), + $ LDQG, IERR ) + CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, 1, WR, N, IERR ) + CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, 1, WI, N, IERR ) + END IF +C + IF ( INFO.NE.0 ) + $ RETURN +C +C ----------------------------------------------- +C Step 3: Compute orthogonal symplectic factors. +C ----------------------------------------------- +C +C Fix CSL and CSR for MB04QB. +C + IF ( WANTU ) + $ CALL DSCAL( N, -ONE, DWORK(PCSL+1), 2 ) + IF ( WANTV ) + $ CALL DSCAL( N-1, -ONE, DWORK(PCSR+1), 2 ) + ILO1 = MIN( N, ILO + 1 ) +C + IF ( WANTU .AND. .NOT.WANTV .AND. .NOT.WANTG ) THEN +C +C Workspace requirements: 7*N. +C + PDW = PTAUR + CALL DCOPY( N, T(1,1), LDT+1, DWORK(PDW), 1 ) + CALL DLACPY( 'Lower', N, N, U2, LDU2, T, LDT ) + CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) + CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', + $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, + $ QG(ILO,ILO), LDQG, T(ILO,ILO), LDT, U1(ILO,1), + $ LDU1, U2(ILO,1), LDU2, DWORK(PCSL+2*ILO-2), + $ DWORK(PTAUL+ILO-1), DWORK(PDW+N), LDWORK-PDW-N+1, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) + CALL DCOPY( N, DWORK(PDW), 1, T(1,1), LDT+1 ) + IF ( N.GT.1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) +C + ELSE IF ( .NOT.WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN +C +C Workspace requirements: 7*N. +C + PDW = PTAUR + N + CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) + CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', + $ 'Columnwise', 'Rowwise', MAX(0,N-ILO), N, + $ MAX(0,N-ILO), QG(ILO1,ILO), LDQG, QG(ILO,ILO1), + $ LDQG, V1(ILO1,1), LDV1, V2(ILO1,1), LDV2, + $ DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1), + $ DWORK(PDW), LDWORK-PDW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) +C + ELSE IF ( WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN +C +C Workspace requirements: 8*N. +C + PDW = PTAUR + N + CALL DCOPY( N, T(1,1), LDT+1, DWORK(PDW), 1 ) + CALL DLACPY( 'Lower', N, N, V2, LDV2, T, LDT ) + CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) + CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', + $ 'Columnwise', 'Rowwise', MAX(0,N-ILO), N, + $ MAX(0,N-ILO), QG(ILO1,ILO), LDQG, U2(ILO,ILO1), + $ LDU2, V1(ILO1,1), LDV1, V2(ILO1,1), LDV2, + $ DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1), + $ DWORK(PDW+N), LDWORK-PDW-N+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) +C + CALL DLACPY( 'Lower', N, N, U2, LDU2, QG, LDQG ) + CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) + CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', + $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, + $ T(ILO,ILO), LDT, QG(ILO,ILO), LDQG, U1(ILO,1), + $ LDU1, U2(ILO,1), LDU2, DWORK(PCSL+2*ILO-2), + $ DWORK(PTAUL+ILO-1), DWORK(PDW+N), LDWORK-PDW-N+1, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) + CALL DCOPY( N, DWORK(PDW), 1, T(1,1), LDT+1 ) + IF ( N.GT.1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) +C + ELSE IF ( WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN +C +C Workspace requirements: 6*N + N*N. +C + PQ = PTAUR + PDW = PQ + N*N + CALL DLACPY( 'Lower', N, N, U2, LDU2, DWORK(PQ), N ) + CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) + CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', + $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, + $ T(ILO,ILO), LDT, DWORK(PQ+(ILO-1)*(N+1)), N, + $ U1(ILO,1), LDU1, U2(ILO,1), LDU2, + $ DWORK(PCSL+2*ILO-2), DWORK(PTAUL+ILO-1), + $ DWORK(PDW), LDWORK-PDW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) + IF ( N.GT.1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) +C + ELSE IF ( .NOT.WANTU .AND. WANTV .AND. WANTG ) THEN +C +C Workspace requirements: 7*N + N*N. +C + PQ = PTAUR+N + PDW = PQ + N*N + CALL DLACPY( 'Upper', N, N, V2, LDV2, DWORK(PQ), N ) + CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) + CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', + $ 'Columnwise', 'Rowwise', MAX(0,N-ILO), N, + $ MAX(0,N-ILO), A(ILO1,ILO), LDA, + $ DWORK(PQ+ILO*N+ILO-1), N, V1(ILO1,1), LDV1, + $ V2(ILO1,1), LDV2, DWORK(PCSR+2*ILO-2), + $ DWORK(PTAUR+ILO-1), DWORK(PDW+N), + $ LDWORK-PDW-N+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) + IF ( N.GT.2 ) + $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) +C + ELSE IF ( WANTU .AND. WANTV .AND. WANTG ) THEN +C +C Workspace requirements: 6*N + N*N. +C + PDW = PTAUR + N + CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) + CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', + $ 'Columnwise', 'Rowwise', MAX(0,N-ILO), N, + $ MAX(0,N-ILO), A(ILO1,ILO), LDA, U2(ILO,ILO1), + $ LDU2, V1(ILO1,1), LDV1, V2(ILO1,1), LDV2, + $ DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1), + $ DWORK(PDW), LDWORK-PDW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) +C + PQ = PTAUR + PDW = PQ + N*N + CALL DLACPY( 'Lower', N, N, U2, LDU2, DWORK(PQ), N ) + CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) + CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', + $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, + $ T(ILO,ILO), LDT, DWORK(PQ+(ILO-1)*(N+1)), N, + $ U1(ILO,1), LDU1, U2(ILO,1), LDU2, + $ DWORK(PCSL+2*ILO-2), DWORK(PTAUL+ILO-1), + $ DWORK(PDW), LDWORK-PDW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) + IF ( N.GT.2 ) + $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) + IF ( N.GT.1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) + END IF +C + DWORK(1) = DBLE( WRKOPT ) + RETURN +C *** Last line of MB03XD *** + END diff --git a/mex/sources/libslicot/MB03XP.f b/mex/sources/libslicot/MB03XP.f new file mode 100644 index 000000000..bf374c251 --- /dev/null +++ b/mex/sources/libslicot/MB03XP.f @@ -0,0 +1,659 @@ + SUBROUTINE MB03XP( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, + $ Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the periodic Schur decomposition and the eigenvalues of +C a product of matrices, H = A*B, with A upper Hessenberg and B +C upper triangular without evaluating any part of the product. +C Specifically, the matrices Q and Z are computed, so that +C +C Q' * A * Z = S, Z' * B * Q = T +C +C where S is in real Schur form, and T is upper triangular. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Indicates whether the user wishes to compute the full +C Schur form or the eigenvalues only, as follows: +C = 'E': Compute the eigenvalues only; +C = 'S': compute the factors S and T of the full +C Schur form. +C +C COMPQ CHARACTER*1 +C Indicates whether or not the user wishes to accumulate +C the matrix Q as follows: +C = 'N': The matrix Q is not required; +C = 'I': Q is initialized to the unit matrix and the +C orthogonal transformation matrix Q is returned; +C = 'V': Q must contain an orthogonal matrix U on entry, +C and the product U*Q is returned. +C +C COMPZ CHARACTER*1 +C Indicates whether or not the user wishes to accumulate +C the matrix Z as follows: +C = 'N': The matrix Z is not required; +C = 'I': Z is initialized to the unit matrix and the +C orthogonal transformation matrix Z is returned; +C = 'V': Z must contain an orthogonal matrix U on entry, +C and the product U*Z is returned. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and B. N >= 0. +C +C ILO (input) INTEGER +C IHI (input) INTEGER +C It is assumed that the matrices A and B are already upper +C triangular in rows and columns 1:ILO-1 and IHI+1:N. +C The routine works primarily with the submatrices in rows +C and columns ILO to IHI, but applies the transformations to +C all the rows and columns of the matrices A and B, if +C JOB = 'S'. +C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array A must +C contain the upper Hessenberg matrix A. +C On exit, if JOB = 'S', the leading N-by-N part of this +C array is upper quasi-triangular with any 2-by-2 diagonal +C blocks corresponding to a pair of complex conjugated +C eigenvalues. +C If JOB = 'E', the diagonal elements and 2-by-2 diagonal +C blocks of A will be correct, but the remaining parts of A +C are unspecified on exit. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array B must +C contain the upper triangular matrix B. +C On exit, if JOB = 'S', the leading N-by-N part of this +C array contains the transformed upper triangular matrix. +C 2-by-2 blocks in B corresponding to 2-by-2 blocks in A +C will be reduced to positive diagonal form. (I.e., if +C A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) +C and B(j+1,j+1) will be positive.) +C If JOB = 'E', the elements corresponding to diagonal +C elements and 2-by-2 diagonal blocks in A will be correct, +C but the remaining parts of B are unspecified on exit. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, if COMPQ = 'V', then the leading N-by-N part of +C this array must contain a matrix Q which is assumed to be +C equal to the unit matrix except for the submatrix +C Q(ILO:IHI,ILO:IHI). +C If COMPQ = 'I', Q need not be set on entry. +C On exit, if COMPQ = 'V' or COMPQ = 'I' the leading N-by-N +C part of this array contains the transformation matrix +C which produced the Schur form. +C If COMPQ = 'N', Q is not referenced. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= 1. +C If COMPQ <> 'N', LDQ >= MAX(1,N). +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C On entry, if COMPZ = 'V', then the leading N-by-N part of +C this array must contain a matrix Z which is assumed to be +C equal to the unit matrix except for the submatrix +C Z(ILO:IHI,ILO:IHI). +C If COMPZ = 'I', Z need not be set on entry. +C On exit, if COMPZ = 'V' or COMPZ = 'I' the leading N-by-N +C part of this array contains the transformation matrix +C which produced the Schur form. +C If COMPZ = 'N', Z is not referenced. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= 1. +C If COMPZ <> 'N', LDZ >= MAX(1,N). +C +C ALPHAR (output) DOUBLE PRECISION array, dimension (N) +C ALPHAI (output) DOUBLE PRECISION array, dimension (N) +C BETA (output) DOUBLE PRECISION array, dimension (N) +C The i-th (1 <= i <= N) computed eigenvalue is given by +C BETA(I) * ( ALPHAR(I) + sqrt(-1)*ALPHAI(I) ). If two +C eigenvalues are computed as a complex conjugate pair, +C they are stored in consecutive elements of ALPHAR, ALPHAI +C and BETA. If JOB = 'S', the eigenvalues are stored in the +C same order as on the diagonales of the Schur forms of A +C and B. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -19, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, then MB03XP failed to compute the Schur +C form in a total of 30*(IHI-ILO+1) iterations; +C elements 1:ilo-1 and i+1:n of ALPHAR, ALPHAI and +C BETA contain successfully computed eigenvalues. +C +C METHOD +C +C The implemented algorithm is a multi-shift version of the periodic +C QR algorithm described in [1,3] with some minor modifications +C proposed in [2]. +C +C REFERENCES +C +C [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P. +C The periodic Schur decomposition: Algorithms and applications. +C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, +C 1992. +C +C [2] Kressner, D. +C An efficient and reliable implementation of the periodic QZ +C algorithm. Proc. of the IFAC Workshop on Periodic Control +C Systems, pp. 187-192, 2001. +C +C [3] Van Loan, C. +C Generalized Singular Values with Algorithms and Applications. +C Ph. D. Thesis, University of Michigan, 1973. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O(N**3) floating point operations and is +C backward stable. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHGPQR). +C +C KEYWORDS +C +C Eigenvalue, eigenvalue decomposition, Hessenberg form, orthogonal +C transformation, (periodic) Schur form +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER NSMAX, LDAS, LDBS + PARAMETER ( NSMAX = 15, LDAS = NSMAX, LDBS = NSMAX ) +C .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ, JOB + INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDWORK, LDZ, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), + $ BETA(*), DWORK(*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL INITQ, INITZ, WANTQ, WANTT, WANTZ + INTEGER DUM, I, I1, I2, IERR, ITEMP, ITN, ITS, J, K, + $ KK, L, MAXB, NH, NR, NS, NV, PV2, PV3 + DOUBLE PRECISION OVFL, SMLNUM, TAUV, TAUW, TEMP, TST, ULP, UNFL +C .. Local Arrays .. + INTEGER ISEED(4) + DOUBLE PRECISION AS(LDAS,LDAS), BS(LDBS,LDBS), V(3*NSMAX+6) +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, UE01MD + DOUBLE PRECISION DLAMCH, DLANHS + EXTERNAL DLAMCH, DLANHS, IDAMAX, LSAME, UE01MD +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DLABAD, DLACPY, DLARFG, + $ DLARFX, DLARNV, DLASET, DSCAL, DTRMV, MB03YA, + $ MB03YD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + WANTT = LSAME( JOB, 'S' ) + INITQ = LSAME( COMPQ, 'I' ) + WANTQ = INITQ.OR.LSAME( COMPQ, 'V' ) + INITZ = LSAME( COMPZ, 'I' ) + WANTZ = INITZ.OR.LSAME( COMPZ, 'V' ) +C +C Check the scalar input parameters. +C + INFO = 0 + IF ( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN + INFO = -1 + ELSE IF ( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN + INFO = -2 + ELSE IF ( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN + INFO = -3 + ELSE IF ( N.LT.0 ) THEN + INFO = -4 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF ( IHI.LT.MIN( ILO,N ).OR.IHI.GT.N ) THEN + INFO = -6 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF ( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.N ) THEN + INFO = -12 + ELSE IF ( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.N ) THEN + INFO = -14 + ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN + DWORK(1) = DBLE( MAX( 1, N ) ) + INFO = -19 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03XP', -INFO ) + RETURN + END IF +C +C Initialize Q and Z, if necessary. +C + IF ( INITQ ) + $ CALL DLASET( 'All', N, N, ZERO, ONE, Q, LDQ ) + IF ( INITZ ) + $ CALL DLASET( 'All', N, N, ZERO, ONE, Z, LDZ ) +C +C Store isolated eigenvalues and standardize B. +C +C FOR I = [1:ILO-1, IHI+1:N] + I = 1 + 10 CONTINUE + IF ( I.EQ.ILO ) THEN + I = IHI+1 + END IF + IF ( I.LE.N ) THEN + IF ( B(I,I).LT.ZERO ) THEN + IF ( WANTT ) THEN + DO 20 K = ILO, I + B(K,I) = -B(K,I) + 20 CONTINUE + DO 30 K = I, IHI + A(I,K) = -A(I,K) + 30 CONTINUE + ELSE + B(I,I) = -B(I,I) + A(I,I) = -A(I,I) + END IF + IF ( WANTQ ) THEN + DO 40 K = ILO, IHI + Q(K,I) = -Q(K,I) + 40 CONTINUE + END IF + END IF + ALPHAR(I) = A(I,I) + ALPHAI(I) = ZERO + BETA(I) = B(I,I) + I = I + 1 +C END FOR + GO TO 10 + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. ILO.EQ.IHI+1 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Set rows and coloms ILO to IHI of B (A) to zero below the first +C (sub)diagonal. +C + DO 60 J = ILO, IHI - 2 + DO 50 I = J + 2, N + A(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + DO 80 J = ILO, IHI - 1 + DO 70 I = J + 1, N + B(I,J) = ZERO + 70 CONTINUE + 80 CONTINUE + NH = IHI - ILO + 1 +C +C Suboptimal choice of the number of shifts. +C + IF ( WANTQ ) THEN + NS = UE01MD( 4, 'MB03XP', JOB // COMPQ, N, ILO, IHI ) + MAXB = UE01MD( 8, 'MB03XP', JOB // COMPQ, N, ILO, IHI ) + ELSE + NS = UE01MD( 4, 'MB03XP', JOB // COMPZ, N, ILO, IHI ) + MAXB = UE01MD( 8, 'MB03XP', JOB // COMPZ, N, ILO, IHI ) + END IF +C + IF ( NS.LE.2 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN +C +C Standard double-shift product QR. +C + CALL MB03YD( WANTT, WANTQ, WANTZ, N, ILO, IHI, ILO, IHI, A, + $ LDA, B, LDB, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, + $ DWORK, LDWORK, INFO ) + RETURN + END IF + MAXB = MAX( 3, MAXB ) + NS = MIN( NS, MAXB, NSMAX ) +C +C Set machine-dependent constants for the stopping criterion. +C If max(norm(A),norm(B)) <= sqrt(OVFL), then overflow should not +C occur. +C + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Precision' ) + SMLNUM = UNFL*( DBLE( NH ) / ULP ) +C +C I1 and I2 are the indices of the first rows and last columns of +C A and B to which transformations must be applied. +C + IF ( WANTT ) THEN + I1 = 1 + I2 = N + END IF + ISEED(1) = 1 + ISEED(2) = 0 + ISEED(3) = 0 + ISEED(4) = 1 +C +C ITN is the maximal number of QR iterations. +C + ITN = 30*NH + DUM = 0 +C +C Main loop. Eigenvalues I+1:IHI have converged. Either L = ILO +C or A(L,L-1) is negligible. +C + I = IHI + 90 CONTINUE + L = ILO + IF ( I.LT.ILO ) + $ GO TO 210 +C + DO 190 ITS = 0, ITN + DUM = DUM + (IHI-ILO)*(IHI-ILO) +C +C Look for deflations in A. +C + DO 100 K = I, L + 1, -1 + TST = ABS( A(K-1,K-1) ) + ABS( A(K,K) ) + IF ( TST.EQ.ZERO ) + $ TST = DLANHS( '1', I-L+1, A(L,L), LDA, DWORK ) + IF ( ABS( A(K,K-1) ).LE.MAX( ULP*TST, SMLNUM ) ) + $ GO TO 110 + 100 CONTINUE + 110 CONTINUE +C +C Look for deflation in B if problem size is greater than 1. +C + IF ( I-K.GE.1 ) THEN + DO 120 KK = I, K, -1 + IF ( KK.EQ.I ) THEN + TST = ABS( B(KK-1,KK) ) + ELSE IF ( KK.EQ.K ) THEN + TST = ABS( B(KK,KK+1) ) + ELSE + TST = ABS( B(KK-1,KK) ) + ABS( B(KK,KK+1) ) + END IF + IF ( TST.EQ.ZERO ) + $ TST = DLANHS( '1', I-K+1, B(K,K), LDB, DWORK ) + IF ( ABS( B(KK,KK) ).LE.MAX( ULP*TST, SMLNUM ) ) + $ GO TO 130 + 120 CONTINUE + ELSE + KK = K-1 + END IF + 130 CONTINUE + IF ( KK.GE.K ) THEN +C +C B has an element close to zero at position (KK,KK). +C + B(KK,KK) = ZERO + CALL MB03YA( WANTT, WANTQ, WANTZ, N, K, I, ILO, IHI, KK, + $ A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO ) + K = KK+1 + END IF + L = K + IF( L.GT.ILO ) THEN +C +C A(L,L-1) is negligible. +C + A(L,L-1) = ZERO + END IF +C +C Exit from loop if a submatrix of order <= MAXB has split off. +C + IF ( L.GE.I-MAXB+1 ) + $ GO TO 200 +C +C The active submatrices are now in rows and columns L:I. +C + IF ( .NOT.WANTT ) THEN + I1 = L + I2 = I + END IF + IF ( ITS.EQ.10.OR.ITS.EQ.20 ) THEN +C +C Exceptional shift. The first column of the shift polynomial +C is a pseudo-random vector. +C + CALL DLARNV( 3, ISEED, NS+1, V ) + ELSE +C +C Use eigenvalues of trailing submatrix as shifts. +C + CALL DLACPY( 'Full', NS, NS, A(I-NS+1,I-NS+1), LDA, AS, + $ LDAS ) + CALL DLACPY( 'Full', NS, NS, B(I-NS+1,I-NS+1), LDB, BS, + $ LDBS ) + CALL MB03YD( .FALSE., .FALSE., .FALSE., NS, 1, NS, 1, NS, + $ AS, LDAS, BS, LDBS, Q, LDQ, Z, LDZ, + $ ALPHAR(I-NS+1), ALPHAI(I-NS+1), BETA(I-NS+1), + $ DWORK, LDWORK, IERR ) + END IF +C +C Compute the nonzero elements of the first column of +C (A*B-w(1)) (A*B-w(2)) .. (A*B-w(ns)). +C + V(1) = ONE + NV = 1 +C WHILE NV <= NS + 140 CONTINUE + IF ( NV.LE.NS ) THEN + IF ( NV.EQ.NS .OR. AS(NV+1,NV).EQ.ZERO ) THEN +C +C Real shift. +C + V(NV+1) = ZERO + PV2 = NV+2 + CALL DCOPY( NV, V, 1, V(PV2), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal', + $ NV, B(L,L), LDB, V(PV2), 1 ) + CALL DSCAL( NV, BS(NV,NV), V, 1 ) + ITEMP = IDAMAX( 2*NV+1, V, 1 ) + TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) + CALL DSCAL( 2*NV+1, TEMP, V, 1 ) + CALL DGEMV( 'No transpose', NV+1, NV, ONE, A(L,L), LDA, + $ V(PV2), 1, -AS(NV,NV), V, 1 ) + NV = NV + 1 + ELSE +C +C Double shift using a product formulation of the shift +C polynomial [2]. +C + V(NV+1) = ZERO + V(NV+2) = ZERO + PV2 = NV+3 + PV3 = 2*NV+5 + CALL DCOPY( NV+2, V, 1, V(PV2), 1 ) + CALL DCOPY( NV+1, V, 1, V(PV3), 1 ) + CALL DSCAL( NV, BS(NV+1,NV+1), V(PV2), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal', + $ NV, B(L,L), LDB, V(PV3), 1 ) + ITEMP = IDAMAX( 2*NV+3, V(PV2), 1 ) + TEMP = ONE / MAX( ABS( V(PV2+ITEMP-1) ), SMLNUM ) + CALL DSCAL( 2*NV+3, TEMP, V(PV2), 1 ) +C + CALL DCOPY( NV, V(PV2), 1, V, 1 ) + CALL DGEMV( 'No transpose', NV+1, NV, -ONE, A(L,L), LDA, + $ V(PV3), 1, AS(NV+1,NV+1), V(PV2), 1 ) + CALL DSCAL( NV, AS(NV,NV+1), V, 1 ) + ITEMP = IDAMAX( 2*NV+3, V, 1 ) + TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) + CALL DSCAL( 2*NV+3, TEMP, V, 1 ) +C + CALL DSCAL( NV, -AS(NV+1,NV), V, 1 ) + CALL DAXPY( NV+1, AS(NV,NV), V(PV2), 1, V, 1) + ITEMP = IDAMAX( 2*NV+3, V, 1 ) + TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) + CALL DSCAL( 2*NV+3, TEMP, V, 1 ) +C + CALL DSCAL( NV+1, BS(NV,NV), V, 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal', + $ NV+1, B(L,L), LDB, V(PV2), 1 ) + ITEMP = IDAMAX( 2*NV+3, V, 1 ) + TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) + CALL DSCAL( 2*NV+3, TEMP, V, 1 ) +C + CALL DGEMV( 'No transpose', NV+2, NV+1, -ONE, A(L,L), + $ LDA, V(PV2), 1, ONE, V, 1 ) + NV = NV + 2 + END IF + ITEMP = IDAMAX( NV, V, 1 ) + TEMP = ABS( V(ITEMP) ) + IF ( TEMP.EQ.ZERO ) THEN + V(1) = ONE + DO 150 K = 2, NV + V(K) = ZERO + 150 CONTINUE + ELSE + TEMP = MAX( TEMP, SMLNUM ) + CALL DSCAL( NV, ONE/TEMP, V, 1 ) + END IF + GO TO 140 +C END WHILE + END IF +C +C Multi-shift product QR step. +C + PV2 = NS+2 + DO 180 K = L,I-1 + NR = MIN( NS+1,I-K+1 ) + IF ( K.GT.L ) + $ CALL DCOPY( NR, A(K,K-1), 1, V, 1 ) + CALL DLARFG( NR, V(1), V(2), 1, TAUV ) + IF ( K.GT.L ) THEN + A(K,K-1) = V(1) + DO 160 KK = K+1,I + A(KK,K-1) = ZERO + 160 CONTINUE + END IF +C +C Apply reflector V from the right to B in rows +C I1:min(K+NS,I). +C + V(1) = ONE + CALL DLARFX( 'Right', MIN(K+NS,I)-I1+1, NR, V, TAUV, + $ B(I1,K), LDB, DWORK ) +C +C Annihilate the introduced nonzeros in the K-th column. +C + CALL DCOPY( NR, B(K,K), 1, V(PV2), 1 ) + CALL DLARFG( NR, V(PV2), V(PV2+1), 1, TAUW ) + B(K,K) = V(PV2) + DO 170 KK = K+1,I + B(KK,K) = ZERO + 170 CONTINUE + V(PV2) = ONE +C +C Apply reflector W from the left to transform the rows of the +C matrix B in columns K+1:I2. +C + CALL DLARFX( 'Left', NR, I2-K, V(PV2), TAUW, B(K,K+1), LDB, + $ DWORK ) +C +C Apply reflector V from the left to transform the rows of the +C matrix A in columns K:I2. +C + CALL DLARFX( 'Left', NR, I2-K+1, V, TAUV, A(K,K), LDA, + $ DWORK ) +C +C Apply reflector W from the right to transform the columns of +C the matrix A in rows I1:min(K+NS,I). +C + CALL DLARFX( 'Right', MIN(K+NS+1,I)-I1+1, NR, V(PV2), TAUW, + $ A(I1,K), LDA, DWORK ) +C +C Accumulate transformations in the matrices Q and Z. +C + IF ( WANTQ ) + $ CALL DLARFX( 'Right', NH, NR, V, TAUV, Q(ILO,K), LDQ, + $ DWORK ) + IF ( WANTZ ) + $ CALL DLARFX( 'Right', NH, NR, V(PV2), TAUW, Z(ILO,K), + $ LDZ, DWORK ) + 180 CONTINUE + 190 CONTINUE +C +C Failure to converge. +C + INFO = I + RETURN + 200 CONTINUE +C +C Submatrix of order <= MAXB has split off. Use double-shift +C periodic QR algorithm. +C + CALL MB03YD( WANTT, WANTQ, WANTZ, N, L, I, ILO, IHI, A, LDA, B, + $ LDB, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, + $ LDWORK, INFO ) + IF ( INFO.GT.0 ) + $ RETURN + ITN = ITN - ITS + I = L - 1 + GO TO 90 +C + 210 CONTINUE + DWORK(1) = DBLE( MAX( 1,N ) ) + RETURN +C *** Last line of MB03XP *** + END diff --git a/mex/sources/libslicot/MB03XU.f b/mex/sources/libslicot/MB03XU.f new file mode 100644 index 000000000..b25d49da3 --- /dev/null +++ b/mex/sources/libslicot/MB03XU.f @@ -0,0 +1,2338 @@ + SUBROUTINE MB03XU( LTRA, LTRB, N, K, NB, A, LDA, B, LDB, G, LDG, + $ Q, LDQ, XA, LDXA, XB, LDXB, XG, LDXG, XQ, LDXQ, + $ YA, LDYA, YB, LDYB, YG, LDYG, YQ, LDYQ, CSL, + $ CSR, TAUL, TAUR, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce 2*nb columns and rows of a real (k+2n)-by-(k+2n) +C matrix H: +C +C [ op(A) G ] +C H = [ ], +C [ Q op(B) ] +C +C so that elements in the first nb columns below the k-th +C subdiagonal of the (k+n)-by-n matrix op(A), in the first nb +C columns and rows of the n-by-n matrix Q and in the first nb rows +C above the diagonal of the n-by-(k+n) matrix op(B) are zero. +C The reduction is performed by orthogonal symplectic +C transformations UU'*H*VV and matrices U, V, YA, YB, YG, YQ, XA, +C XB, XG, and XQ are returned so that +C +C [ op(Aout)+U*YA'+XA*V' G+U*YG'+XG*V' ] +C UU' H VV = [ ]. +C [ Qout+U*YQ'+XQ*V' op(Bout)+U*YB'+XB*V' ] +C +C This is an auxiliary routine called by MB04TB. +C +C ARGUMENTS +C +C Mode Parameters +C +C LTRA LOGICAL +C Specifies the form of op( A ) as follows: +C = .FALSE.: op( A ) = A; +C = .TRUE.: op( A ) = A'. +C +C LTRB LOGICAL +C Specifies the form of op( B ) as follows: +C = .FALSE.: op( B ) = B; +C = .TRUE.: op( B ) = B'. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix Q. N >= 0. +C +C K (input) INTEGER +C The offset of the reduction. Elements below the K-th +C subdiagonal in the first NB columns of op(A) are +C reduced to zero. K >= 0. +C +C NB (input) INTEGER +C The number of columns/rows to be reduced. N > NB >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA,N) if LTRA = .FALSE. +C (LDA,K+N) if LTRA = .TRUE. +C On entry with LTRA = .FALSE., the leading (K+N)-by-N part +C of this array must contain the matrix A. +C On entry with LTRA = .TRUE., the leading N-by-(K+N) part +C of this array must contain the matrix A. +C On exit with LTRA = .FALSE., the leading (K+N)-by-N part +C of this array contains the matrix Aout and, in the zero +C parts, information about the elementary reflectors used to +C compute the reduction. +C On exit with LTRA = .TRUE., the leading N-by-(K+N) part of +C this array contains the matrix Aout and in the zero parts +C information about the elementary reflectors. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,K+N), if LTRA = .FALSE.; +C LDA >= MAX(1,N), if LTRA = .TRUE.. +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,K+N) if LTRB = .FALSE. +C (LDB,N) if LTRB = .TRUE. +C On entry with LTRB = .FALSE., the leading N-by-(K+N) part +C of this array must contain the matrix B. +C On entry with LTRB = .TRUE., the leading (K+N)-by-N part +C of this array must contain the matrix B. +C On exit with LTRB = .FALSE., the leading N-by-(K+N) part +C of this array contains the matrix Bout and, in the zero +C parts, information about the elementary reflectors used to +C compute the reduction. +C On exit with LTRB = .TRUE., the leading (K+N)-by-N part of +C this array contains the matrix Bout and in the zero parts +C information about the elementary reflectors. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,N), if LTRB = .FALSE.; +C LDB >= MAX(1,K+N), if LTRB = .TRUE.. +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix G. +C On exit, the leading N-by-N part of this array contains +C the matrix Gout. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix Q. +C On exit, the leading N-by-N part of this array contains +C the matrix Qout and in the zero parts information about +C the elementary reflectors used to compute the reduction. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= MAX(1,N). +C +C XA (output) DOUBLE PRECISION array, dimension (LDXA,2*NB) +C On exit, the leading N-by-(2*NB) part of this array +C contains the matrix XA. +C +C LDXA INTEGER +C The leading dimension of the array XA. LDXA >= MAX(1,N). +C +C XB (output) DOUBLE PRECISION array, dimension (LDXB,2*NB) +C On exit, the leading (K+N)-by-(2*NB) part of this array +C contains the matrix XB. +C +C LDXB INTEGER +C The leading dimension of the array XB. LDXB >= MAX(1,K+N). +C +C XG (output) DOUBLE PRECISION array, dimension (LDXG,2*NB) +C On exit, the leading (K+N)-by-(2*NB) part of this array +C contains the matrix XG. +C +C LDXG INTEGER +C The leading dimension of the array XG. LDXG >= MAX(1,K+N). +C +C XQ (output) DOUBLE PRECISION array, dimension (LDXQ,2*NB) +C On exit, the leading N-by-(2*NB) part of this array +C contains the matrix XQ. +C +C LDXQ INTEGER +C The leading dimension of the array XQ. LDXQ >= MAX(1,N). +C +C YA (output) DOUBLE PRECISION array, dimension (LDYA,2*NB) +C On exit, the leading (K+N)-by-(2*NB) part of this array +C contains the matrix YA. +C +C LDYA INTEGER +C The leading dimension of the array YA. LDYA >= MAX(1,K+N). +C +C YB (output) DOUBLE PRECISION array, dimension (LDYB,2*NB) +C On exit, the leading N-by-(2*NB) part of this array +C contains the matrix YB. +C +C LDYB INTEGER +C The leading dimension of the array YB. LDYB >= MAX(1,N). +C +C YG (output) DOUBLE PRECISION array, dimension (LDYG,2*NB) +C On exit, the leading (K+N)-by-(2*NB) part of this array +C contains the matrix YG. +C +C LDYG INTEGER +C The leading dimension of the array YG. LDYG >= MAX(1,K+N). +C +C YQ (output) DOUBLE PRECISION array, dimension (LDYQ,2*NB) +C On exit, the leading N-by-(2*NB) part of this array +C contains the matrix YQ. +C +C LDYQ INTEGER +C The leading dimension of the array YQ. LDYQ >= MAX(1,N). +C +C CSL (output) DOUBLE PRECISION array, dimension (2*NB) +C On exit, the first 2NB elements of this array contain the +C cosines and sines of the symplectic Givens rotations +C applied from the left-hand side used to compute the +C reduction. +C +C CSR (output) DOUBLE PRECISION array, dimension (2*NB) +C On exit, the first 2NB-2 elements of this array contain +C the cosines and sines of the symplectic Givens rotations +C applied from the right-hand side used to compute the +C reduction. +C +C TAUL (output) DOUBLE PRECISION array, dimension (NB) +C On exit, the first NB elements of this array contain the +C scalar factors of some of the elementary reflectors +C applied form the left-hand side. +C +C TAUR (output) DOUBLE PRECISION array, dimension (NB) +C On exit, the first NB-1 elements of this array contain the +C scalar factors of some of the elementary reflectors +C applied form the right-hand side. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (5*NB) +C +C METHOD +C +C For details regarding the representation of the orthogonal +C symplectic matrices UU and VV within the arrays A, B, CSL, CSR, Q, +C TAUL and TAUR see the description of MB04TB. +C +C The contents of A, B, G and Q on exit are illustrated by the +C following example with op(A) = A, op(B) = B, n = 5, k = 2 and +C nb = 2: +C +C ( a r r a a ) ( g g g r r g g ) +C ( a r r a a ) ( g g g r r g g ) +C ( r r r r r ) ( r r r r r r r ) +C A = ( u2 r r r r ), G = ( r r r r r r r ), +C ( u2 u2 r a a ) ( g g g r r g g ) +C ( u2 u2 r a a ) ( g g g r r g g ) +C ( u2 u2 r a a ) ( g g g r r g g ) +C +C ( t t v1 v1 v1 ) ( r r r r r v2 v2 ) +C ( u1 t t v1 v1 ) ( r r r r r r v2 ) +C Q = ( u1 u1 r q q ), B = ( b b b r r b b ). +C ( u1 u1 r q q ) ( b b b r r b b ) +C ( u1 u1 r q q ) ( b b b r r b b ) +C +C where a, b, g and q denote elements of the original matrices, r +C denotes a modified element, t denotes a scalar factor of an +C applied elementary reflector, ui and vi denote elements of the +C matrices U and V, respectively. +C +C NUMERICAL ASPECTS +C +C The algorithm requires ( 16*K + 32*N + 42 )*N*NB + +C ( 16*K + 112*N - 208/3*NB - 69 )*NB*NB - 29/3*NB floating point +C operations and is numerically backward stable. +C +C REFERENCES +C +C [1] Benner, P., Mehrmann, V., and Xu, H. +C A numerically stable, structure preserving method for +C computing the eigenvalues of real Hamiltonian or symplectic +C pencils. +C Numer. Math., Vol. 78 (3), pp. 329-358, 1998. +C +C [2] Kressner, D. +C Block algorithms for orthogonal symplectic factorizations. +C BIT Numerical Mathematics, 43 (4), pp. 775-790, 2003. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLASUB). +C +C KEYWORDS +C +C Elementary matrix operations, Matrix decompositions, Hamiltonian +C matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + LOGICAL LTRA, LTRB + INTEGER K, LDA, LDB, LDG, LDQ, LDXA, LDXB, LDXG, LDXQ, + $ LDYA, LDYB, LDYG, LDYQ, N, NB +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*), + $ G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*), + $ XA(LDXA,*), XB(LDXB,*), XG(LDXG,*), XQ(LDXQ,*), + $ YA(LDYA,*), YB(LDYB,*), YG(LDYG,*), YQ(LDYQ,*) +C .. Local Scalars .. + INTEGER I, J, NB1, NB2, NB3, PDW + DOUBLE PRECISION ALPHA, C, S, TAUQ, TEMP +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL DAXPY, DGEMV, DLARFG, DLARTG, DROT, DSCAL +C +C .. Executable Statements .. +C +C Quick return if possible. +C + IF ( N+K.LE.0 ) THEN + RETURN + END IF +C + NB1 = NB + 1 + NB2 = NB + NB + NB3 = NB2 + NB + PDW = NB3 + NB + 1 +C + IF ( LTRA.AND.LTRB ) THEN + DO 90 I = 1, NB +C +C Transform first row/column of A and Q. See routine MB04TS. +C + ALPHA = Q(I,I) + CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) + Q(I,I) = ONE + TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(I,K+I), LDA ) + CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(I,K+I), LDA ) + TEMP = A(I,K+I) + CALL DLARTG( TEMP, ALPHA, C, S, A(I,K+I) ) + CALL DLARFG( N-I+1, A(I,K+I), A(I,K+I+1), LDA, TAUL(I) ) + TEMP = A(I,K+I) + A(I,K+I) = ONE +C +C Update XQ with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, + $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, + $ Q(I,I), 1, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, + $ DWORK, 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A(1,K+I), LDA, + $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, + $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, + $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) +C +C Update Q(i,i+1:n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, A(1,K+I), 1, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) +C +C Update XA with first Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), + $ LDA, Q(I,I), 1, ZERO, XA(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, + $ DWORK, 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, + $ Q(I,I), 1, ZERO, XA(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, + $ Q(I,I), 1, ZERO, XA(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) +C +C Update A(i+1:n,k+i). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ Q(I,1), LDQ, ONE, A(I+1,K+I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, A(1,K+I), 1, ONE, A(I+1,K+I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YA(K+I,1), LDYA, ONE, A(I+1,K+I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ YA(K+I,NB1), LDYA, ONE, A(I+1,K+I), 1 ) +C +C Apply rotation to [ A(i+1:n,k+i)'; Q(i,i+1:n) ]. +C + CALL DROT( N-I, A(I+1,K+I), 1, Q(I,I+1), LDQ, C, S ) +C +C Update XQ with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, + $ A(I,K+I), LDA, ZERO, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ A(I,K+I+1), LDA, ZERO, DWORK(NB2+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, A(1,K+I+1), LDA, + $ A(I,K+I+1), LDA, ZERO, DWORK(NB3+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, + $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, + $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) +C +C Update Q(i,i+1:n). +C + CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) +C +C Update XA with second Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), + $ LDA, A(I,K+I), LDA, ZERO, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, + $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, + $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) +C +C Update A(i+1:n,k+i). +C + CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(I+1,K+I), 1 ) +C +C Update XG with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, + $ Q(I,I), 1, ZERO, XG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, + $ DWORK, 1, ONE, XG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) +C +C Update G(k+i,:). +C + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, A(1,K+I), 1, ONE, G(K+I,1), LDG ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) +C +C Update XB with first Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I+1, ONE, B(1,I), LDB, + $ Q(I,I), 1, ZERO, XB(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, + $ DWORK, 1, ONE, XB(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) +C +C Update B(:,i). +C + CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, + $ Q(I,1), LDQ, ONE, B(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, A(1,K+I), 1, ONE, B(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YB(I,1), LDYB, ONE, B(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ YB(I,NB1), LDYB, ONE, B(K+I+1,I), 1 ) +C +C Apply rotation to [ G(k+i,:); B(:,i)' ]. +C + CALL DROT( K+N, G(K+I,1), LDG, B(1,I), 1, C, S ) +C + DO 10 J = 1, I-1 + YG(K+I,J) = ZERO + 10 CONTINUE + DO 20 J = 1, I-1 + YG(K+I,NB+J) = ZERO + 20 CONTINUE + DO 30 J = 1, I-1 + YA(K+I,J) = ZERO + 30 CONTINUE + DO 40 J = 1, I-1 + YA(K+I,NB+J) = ZERO + 40 CONTINUE +C +C Update XG with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, + $ A(I,K+I), LDA, ZERO, XG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, + $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, + $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) +C +C Update G(k+i,:). +C + CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) +C +C Update XB with second Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I+1, ONE, B(1,I), LDB, + $ A(I,K+I), LDA, ZERO, XB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, + $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, + $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, + $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) +C +C Update B(:,i). +C + CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(1,I), 1 ) +C + A(I,K+I) = TEMP + Q(I,I) = TAUQ + CSL(2*I-1) = C + CSL(2*I) = S +C +C Transform first row/column of Q and B. +C + ALPHA = Q(I,I+1) + CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) + Q(I,I+1) = ONE + TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) + CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) + TEMP = B(K+I+1,I) + CALL DLARTG( TEMP, ALPHA, C, S, B(K+I+1,I) ) + S = -S + CALL DLARFG( N-I, B(K+I+1,I), B(K+I+2,I), 1, TAUR(I) ) + TEMP = B(K+I+1,I) + B(K+I+1,I) = ONE +C +C Update YB with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), + $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, + $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, + $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, + $ DWORK, 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) +C +C Update B(k+i+1,i+1:n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XB(K+I+1,1), LDXB, ONE, B(K+I+1,I+1), LDB ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ XB(K+I+1,NB1), LDXB, ONE, B(K+I+1,I+1), LDB ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, + $ Q(1,I+1), 1, ONE, B(K+I+1,I+1), LDB ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, B(K+I+1,1), LDB, ONE, B(K+I+1,I+1), LDB ) +C +C Update YQ with first Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, + $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, + $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, + $ DWORK, 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) +C +C Update Q(i+1:n,i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, + $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, B(K+I+1,1), LDB, ONE, Q(I+1,I+1), 1 ) +C +C Apply rotation to [ Q(i+1:n,i+1), B(k+i+1,i+1:n)' ]. +C + CALL DROT( N-I, Q(I+1,I+1), 1, B(K+I+1,I+1), LDB, C, S ) + DO 50 J = 1, I + XB(K+I+1,J) = ZERO + 50 CONTINUE + DO 60 J = 1, I + XB(K+I+1,NB+J) = ZERO + 60 CONTINUE +C +C Update YB with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), + $ LDB, B(K+I+1,I), 1, ZERO, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, + $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, + $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, + $ B(K+I+2,I), 1, ZERO, DWORK(NB2+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, + $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, B(K+I+2,1), + $ LDQ, B(K+I+2,I), 1, ZERO, DWORK(NB3+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) +C +C Update B(k+i+1,i+1:n). +C + CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(K+I+1,I+1), LDB ) +C +C Update YQ with second Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, + $ B(K+I+1,I), 1, ZERO, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, + $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, + $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, + $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) +C +C Update Q(i+1:n,i+1). +C + CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) +C +C Update YA with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, + $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, + $ DWORK, 1, ONE, YA(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) +C +C Update A(i+1,1:k+n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XA(I+1,1), LDXA, ONE, A(I+1,K+I+1), LDA ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ XA(I+1,NB1), LDXA, ONE, A(I+1,K+I+1), LDA ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ Q(1,I+1), 1, ONE, A(I+1,1), LDA ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ B(K+I+1,1), LDB, ONE, A(I+1,1), LDA ) +C +C Update YG with first Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, + $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, + $ DWORK, 1, ONE, YG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) +C +C Update G(1:k+n,k+i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, + $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ B(K+I+1,1), LDB, ONE, G(1,K+I+1), 1 ) + DO 70 J = 1, I + XG(K+I+1,J) = ZERO + 70 CONTINUE + DO 80 J = 1, I + XG(K+I+1,NB+J) = ZERO + 80 CONTINUE +C +C Apply rotation to [ A(i+1,1:k+n)', G(1:k+n,k+i+1) ]. +C + CALL DROT( K+N, A(I+1,1), LDA, G(1,K+I+1), 1, C, S ) +C +C Update YA with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, + $ B(K+I+1,I), 1, ZERO, YA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, + $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, + $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) +C +C Update A(i+1,1:k+n). +C + CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(I+1,1), LDA ) +C +C Update YG with second Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, + $ B(K+I+1,I), 1, ZERO, YG(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, + $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, + $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, + $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) +C +C Update G(1:k+n,k+i+1). +C + CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) +C + B(K+I+1,I) = TEMP + Q(I,I+1) = TAUQ + CSR(2*I-1) = C + CSR(2*I) = S + 90 CONTINUE + ELSE IF ( LTRA ) THEN + DO 180 I = 1, NB +C +C Transform first row/column of A and Q. See routine MB04TS. +C + ALPHA = Q(I,I) + CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) + Q(I,I) = ONE + TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(I,K+I), LDA ) + CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(I,K+I), LDA ) + TEMP = A(I,K+I) + CALL DLARTG( TEMP, ALPHA, C, S, A(I,K+I) ) + CALL DLARFG( N-I+1, A(I,K+I), A(I,K+I+1), LDA, TAUL(I) ) + TEMP = A(I,K+I) + A(I,K+I) = ONE +C +C Update XQ with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, + $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, + $ Q(I,I), 1, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, + $ DWORK, 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A(1,K+I), LDA, + $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, + $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, + $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) +C +C Update Q(i,i+1:n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, A(1,K+I), 1, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) +C +C Update XA with first Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), + $ LDA, Q(I,I), 1, ZERO, XA(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, + $ DWORK, 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, + $ Q(I,I), 1, ZERO, XA(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, + $ Q(I,I), 1, ZERO, XA(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) +C +C Update A(i+1:n,k+i). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ Q(I,1), LDQ, ONE, A(I+1,K+I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, A(1,K+I), 1, ONE, A(I+1,K+I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YA(K+I,1), LDYA, ONE, A(I+1,K+I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ YA(K+I,NB1), LDYA, ONE, A(I+1,K+I), 1 ) +C +C Apply rotation to [ A(i+1:n,k+i)'; Q(i,i+1:n) ]. +C + CALL DROT( N-I, A(I+1,K+I), 1, Q(I,I+1), LDQ, C, S ) +C +C Update XQ with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, + $ A(I,K+I), LDA, ZERO, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ A(I,K+I+1), LDA, ZERO, DWORK(NB2+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, A(1,K+I+1), LDA, + $ A(I,K+I+1), LDA, ZERO, DWORK(NB3+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, + $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, + $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) +C +C Update Q(i,i+1:n). +C + CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) +C +C Update XA with second Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), + $ LDA, A(I,K+I), LDA, ZERO, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, + $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, + $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) +C +C Update A(i+1:n,k+i). +C + CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(I+1,K+I), 1 ) +C +C Update XG with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, + $ Q(I,I), 1, ZERO, XG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, + $ DWORK, 1, ONE, XG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) +C +C Update G(k+i,:). +C + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, A(1,K+I), 1, ONE, G(K+I,1), LDG ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) +C +C Update XB with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, + $ Q(I,I), 1, ZERO, XB(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, + $ DWORK, 1, ONE, XB(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) +C +C Update B(i,:). +C + CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, + $ Q(I,1), LDQ, ONE, B(I,1), LDB ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, A(1,K+I), 1, ONE, B(I,1), LDB ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YB(I,1), LDYB, ONE, B(I,K+I+1), LDB ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ YB(I,NB1), LDYB, ONE, B(I,K+I+1), LDB ) +C +C Apply rotation to [ G(k+i,:); B(i,:) ]. +C + CALL DROT( K+N, G(K+I,1), LDG, B(I,1), LDB, C, S ) +C + DO 100 J = 1, I-1 + YG(K+I,J) = ZERO + 100 CONTINUE + DO 110 J = 1, I-1 + YG(K+I,NB+J) = ZERO + 110 CONTINUE + DO 120 J = 1, I-1 + YA(K+I,J) = ZERO + 120 CONTINUE + DO 130 J = 1, I-1 + YA(K+I,NB+J) = ZERO + 130 CONTINUE +C +C Update XG with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, + $ A(I,K+I), LDA, ZERO, XG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, + $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, + $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) +C +C Update G(k+i,:). +C + CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) +C +C Update XB with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, + $ A(I,K+I), LDA, ZERO, XB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, + $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, + $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, + $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) +C +C Update B(i,:). +C + CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(I,1), LDB ) +C + A(I,K+I) = TEMP + Q(I,I) = TAUQ + CSL(2*I-1) = C + CSL(2*I) = S +C +C Transform first rows of Q and B. +C + ALPHA = Q(I,I+1) + CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) + Q(I,I+1) = ONE + TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) + CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) + TEMP = B(I,K+I+1) + CALL DLARTG( TEMP, ALPHA, C, S, B(I,K+I+1) ) + S = -S + CALL DLARFG( N-I, B(I,K+I+1), B(I,K+I+2), LDB, TAUR(I) ) + TEMP = B(I,K+I+1) + B(I,K+I+1) = ONE +C +C Update YB with first Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), + $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, + $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, + $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, + $ DWORK, 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) +C +C Update B(i+1:n,k+i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XB(K+I+1,1), LDXB, ONE, B(I+1,K+I+1), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ XB(K+I+1,NB1), LDXB, ONE, B(I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, + $ Q(1,I+1), 1, ONE, B(I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, B(1,K+I+1), 1, ONE, B(I+1,K+I+1), 1 ) +C +C Update YQ with first Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, + $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, + $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, + $ DWORK, 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) +C +C Update Q(i+1:n,i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, + $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, B(1,K+I+1), 1, ONE, Q(I+1,I+1), 1 ) +C +C Apply rotation to [ Q(i+1:n,i+1), B(i+1:n,k+i+1) ]. +C + CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,K+I+1), 1, C, S ) + DO 140 J = 1, I + XB(K+I+1,J) = ZERO + 140 CONTINUE + DO 150 J = 1, I + XB(K+I+1,NB+J) = ZERO + 150 CONTINUE +C +C Update YB with second Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), + $ LDB, B(I,K+I+1), LDB, ZERO, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, + $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, + $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, + $ B(I,K+I+2), LDB, ZERO, DWORK(NB2+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, + $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I-1, ONE, B(1,K+I+2), + $ LDQ, B(I,K+I+2), LDB, ZERO, DWORK(NB3+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) +C +C Update B(i+1:n,k+i+1). +C + CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(I+1,K+I+1), 1 ) +C +C Update YQ with second Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, + $ B(I,K+I+1), LDB, ZERO, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, + $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, + $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, + $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) +C +C Update Q(i+1:n,i+1). +C + CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) +C +C Update YA with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, + $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, + $ DWORK, 1, ONE, YA(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) +C +C Update A(i+1,1:k+n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XA(I+1,1), LDXA, ONE, A(I+1,K+I+1), LDA ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ XA(I+1,NB1), LDXA, ONE, A(I+1,K+I+1), LDA ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ Q(1,I+1), 1, ONE, A(I+1,1), LDA ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ B(1,K+I+1), 1, ONE, A(I+1,1), LDA ) +C +C Update YG with first Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, + $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, + $ DWORK, 1, ONE, YG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) +C +C Update G(1:k+n,k+i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, + $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ B(1,K+I+1), 1, ONE, G(1,K+I+1), 1 ) + DO 160 J = 1, I + XG(K+I+1,J) = ZERO + 160 CONTINUE + DO 170 J = 1, I + XG(K+I+1,NB+J) = ZERO + 170 CONTINUE +C +C Apply rotation to [ A(i+1,1:k+n)', G(1:k+n,k+i+1) ]. +C + CALL DROT( K+N, A(I+1,1), LDA, G(1,K+I+1), 1, C, S ) +C +C Update YA with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, + $ B(I,K+I+1), LDB, ZERO, YA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, + $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, + $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) +C +C Update A(i+1,1:k+n). +C + CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(I+1,1), LDA ) +C +C Update YG with second Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, + $ B(I,K+I+1), LDB, ZERO, YG(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, + $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, + $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, + $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) +C +C Update G(1:k+n,k+i+1). +C + CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) +C + B(I,K+I+1) = TEMP + Q(I,I+1) = TAUQ + CSR(2*I-1) = C + CSR(2*I) = S + 180 CONTINUE +C + ELSE IF ( LTRB ) THEN + DO 270 I = 1, NB +C +C Transform first columns of A and Q. See routine MB04TS. +C + ALPHA = Q(I,I) + CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) + Q(I,I) = ONE + TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(K+I,I), 1 ) + CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(K+I,I), 1 ) + TEMP = A(K+I,I) + CALL DLARTG( TEMP, ALPHA, C, S, A(K+I,I) ) + CALL DLARFG( N-I+1, A(K+I,I), A(K+I+1,I), 1, TAUL(I) ) + TEMP = A(K+I,I) + A(K+I,I) = ONE +C +C Update XQ with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, + $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, + $ Q(I,I), 1, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, + $ DWORK, 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, A(K+I,1), LDA, + $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, + $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, + $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) +C +C Update Q(i,i+1:n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, A(K+I,1), LDA, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) +C +C Update XA with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, + $ Q(I,I), 1, ZERO, XA(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, + $ DWORK, 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, + $ Q(I,I), 1, ZERO, XA(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, + $ Q(I,I), 1, ZERO, XA(1,I), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) +C +C Update A(k+i,i+1:n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ Q(I,1), LDQ, ONE, A(K+I,I+1), LDA ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, A(K+I,1), LDA, ONE, A(K+I,I+1), LDA ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YA(K+I,1), LDYA, ONE, A(K+I,I+1), LDA ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ YA(K+I,NB1), LDYA, ONE, A(K+I,I+1), LDA ) +C +C Apply rotation to [ A(k+i,i+1:n); Q(i,i+1:n) ]. +C + CALL DROT( N-I, A(K+I,I+1), LDA, Q(I,I+1), LDQ, C, S ) +C +C Update XQ with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, + $ A(K+I,I), 1, ZERO, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ A(K+I+1,I), 1, ZERO, DWORK(NB2+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ A(K+I+1,I), 1, ZERO, DWORK(NB3+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, + $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, + $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) +C +C Update Q(i,i+1:n). +C + CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) +C +C Update XA with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, + $ A(K+I,I), 1, ZERO, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, + $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, + $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) +C +C Update A(k+i,i+1:n). +C + CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(K+I,I+1), LDA ) +C +C Update XG with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, + $ Q(I,I), 1, ZERO, XG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, + $ DWORK, 1, ONE, XG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) +C +C Update G(k+i,:). +C + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, A(K+I,1), LDA, ONE, G(K+I,1), LDG ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) +C +C Update XB with first Householder reflection. +C + CALL DGEMV( 'No Transpose', K+N, N-I+1, ONE, B(1,I), LDB, + $ Q(I,I), 1, ZERO, XB(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, + $ DWORK, 1, ONE, XB(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) +C +C Update B(:,i). +C + CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, + $ Q(I,1), LDQ, ONE, B(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, A(K+I,1), LDA, ONE, B(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YB(I,1), LDYB, ONE, B(K+I+1,I), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ YB(I,NB1), LDYB, ONE, B(K+I+1,I), 1 ) +C +C Apply rotation to [ G(k+i,:); B(:,i)' ]. +C + CALL DROT( K+N, G(K+I,1), LDG, B(1,I), 1, C, S ) +C + DO 190 J = 1, I-1 + YG(K+I,J) = ZERO + 190 CONTINUE + DO 200 J = 1, I-1 + YG(K+I,NB+J) = ZERO + 200 CONTINUE + DO 210 J = 1, I-1 + YA(K+I,J) = ZERO + 210 CONTINUE + DO 220 J = 1, I-1 + YA(K+I,NB+J) = ZERO + 220 CONTINUE +C +C Update XG with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, + $ A(K+I,I), 1, ZERO, XG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, + $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, + $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) +C +C Update G(k+i,:). +C + CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) +C +C Update XB with second Householder reflection. +C + CALL DGEMV( 'No Transpose', K+N, N-I+1, ONE, B(1,I), LDB, + $ A(K+I,I), 1, ZERO, XB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, + $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, + $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, + $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) +C +C Update B(:,i). +C + CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(1,I), 1 ) +C + A(K+I,I) = TEMP + Q(I,I) = TAUQ + CSL(2*I-1) = C + CSL(2*I) = S +C +C Transform first rows of Q and B. +C + ALPHA = Q(I,I+1) + CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) + Q(I,I+1) = ONE + TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) + CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) + TEMP = B(K+I+1,I) + CALL DLARTG( TEMP, ALPHA, C, S, B(K+I+1,I) ) + S = -S + CALL DLARFG( N-I, B(K+I+1,I), B(K+I+2,I), 1, TAUR(I) ) + TEMP = B(K+I+1,I) + B(K+I+1,I) = ONE +C +C Update YB with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), + $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, + $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, + $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, + $ DWORK, 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) +C +C Update B(k+i+1,i+1:n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XB(K+I+1,1), LDXB, ONE, B(K+I+1,I+1), LDB ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ XB(K+I+1,NB1), LDXB, ONE, B(K+I+1,I+1), LDB ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, + $ Q(1,I+1), 1, ONE, B(K+I+1,I+1), LDB ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, B(K+I+1,1), LDB, ONE, B(K+I+1,I+1), LDB ) +C +C Update YQ with first Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, + $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, + $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, + $ DWORK, 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) +C +C Update Q(i+1:n,i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, + $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, B(K+I+1,1), LDB, ONE, Q(I+1,I+1), 1 ) +C +C Apply rotation to [ Q(i+1:n,i+1), B(k+i+1,i+1:n)' ]. +C + CALL DROT( N-I, Q(I+1,I+1), 1, B(K+I+1,I+1), LDB, C, S ) + DO 230 J = 1, I + XB(K+I+1,J) = ZERO + 230 CONTINUE + DO 240 J = 1, I + XB(K+I+1,NB+J) = ZERO + 240 CONTINUE +C +C Update YB with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), + $ LDB, B(K+I+1,I), 1, ZERO, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, + $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, + $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, + $ B(K+I+2,I), 1, ZERO, DWORK(NB2+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, + $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, B(K+I+2,1), + $ LDQ, B(K+I+2,I), 1, ZERO, DWORK(NB3+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) +C +C Update B(k+i+1,i+1:n). +C + CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(K+I+1,I+1), LDB ) +C +C Update YQ with second Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, + $ B(K+I+1,I), 1, ZERO, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, + $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, + $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, + $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) +C +C Update Q(i+1:n,i+1). +C + CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) +C +C Update YA with first Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, + $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, + $ DWORK, 1, ONE, YA(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) +C +C Update A(1:k+n,i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ Q(1,I+1), 1, ONE, A(1,I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ B(K+I+1,1), LDB, ONE, A(1,I+1), 1 ) +C +C Update YG with first Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, + $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, + $ DWORK, 1, ONE, YG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) +C +C Update G(1:k+n,k+i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, + $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ B(K+I+1,1), LDB, ONE, G(1,K+I+1), 1 ) + DO 250 J = 1, I + XG(K+I+1,J) = ZERO + 250 CONTINUE + DO 260 J = 1, I + XG(K+I+1,NB+J) = ZERO + 260 CONTINUE +C +C Apply rotation to [ A(1:k+n,i+1), G(1:k+n,k+i+1) ]. +C + CALL DROT( K+N, A(1,I+1), 1, G(1,K+I+1), 1, C, S ) +C +C Update YA with second Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, + $ B(K+I+1,I), 1, ZERO, YA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, + $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, + $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) +C +C Update A(1:k+n,i+1). +C + CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(1,I+1), 1 ) +C +C Update YG with second Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, + $ B(K+I+1,I), 1, ZERO, YG(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, + $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, + $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, + $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) +C +C Update G(1:k+n,k+i+1). +C + CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) +C + B(K+I+1,I) = TEMP + Q(I,I+1) = TAUQ + CSR(2*I-1) = C + CSR(2*I) = S + 270 CONTINUE +C + ELSE + DO 360 I = 1, NB +C +C Transform first columns of A and Q. See routine MB04TS. +C + ALPHA = Q(I,I) + CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) + Q(I,I) = ONE + TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(K+I,I), 1 ) + CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(K+I,I), 1 ) + TEMP = A(K+I,I) + CALL DLARTG( TEMP, ALPHA, C, S, A(K+I,I) ) + CALL DLARFG( N-I+1, A(K+I,I), A(K+I+1,I), 1, TAUL(I) ) + TEMP = A(K+I,I) + A(K+I,I) = ONE +C +C Update XQ with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, + $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, + $ Q(I,I), 1, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, + $ DWORK, 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, A(K+I,1), LDA, + $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, + $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, + $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) +C +C Update Q(i,i+1:n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, A(K+I,1), LDA, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) +C +C Update XA with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, + $ Q(I,I), 1, ZERO, XA(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, + $ DWORK, 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, + $ Q(I,I), 1, ZERO, XA(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, + $ Q(I,I), 1, ZERO, XA(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) +C +C Update A(k+i,i+1:n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ Q(I,1), LDQ, ONE, A(K+I,I+1), LDA ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, A(K+I,1), LDA, ONE, A(K+I,I+1), LDA ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YA(K+I,1), LDYA, ONE, A(K+I,I+1), LDA ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ YA(K+I,NB1), LDYA, ONE, A(K+I,I+1), LDA ) +C +C Apply rotation to [ A(k+i,i+1:n); Q(i,i+1:n) ]. +C + CALL DROT( N-I, A(K+I,I+1), LDA, Q(I,I+1), LDQ, C, S ) +C +C Update XQ with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, + $ A(K+I,I), 1, ZERO, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ A(K+I+1,I), 1, ZERO, DWORK(NB2+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ A(K+I+1,I), 1, ZERO, DWORK(NB3+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, + $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, + $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) +C +C Update Q(i,i+1:n). +C + CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) +C +C Update XA with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, + $ A(K+I,I), 1, ZERO, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, + $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, + $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) +C +C Update A(k+i,i+1:n). +C + CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(K+I,I+1), LDA ) +C +C Update XG with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, + $ Q(I,I), 1, ZERO, XG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, + $ DWORK, 1, ONE, XG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) +C +C Update G(k+i,:). +C + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, A(K+I,1), LDA, ONE, G(K+I,1), LDG ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) +C +C Update XB with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, + $ Q(I,I), 1, ZERO, XB(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, + $ DWORK, 1, ONE, XB(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) +C +C Update B(i,:). +C + CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, + $ Q(I,1), LDQ, ONE, B(I,1), LDB ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, A(K+I,1), LDA, ONE, B(I,1), LDB ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YB(I,1), LDYB, ONE, B(I,K+I+1), LDB ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ YB(I,NB1), LDYB, ONE, B(I,K+I+1), LDB ) +C +C Apply rotation to [ G(k+i,:); B(i,:) ]. +C + CALL DROT( K+N, G(K+I,1), LDG, B(I,1), LDB, C, S ) +C + DO 280 J = 1, I-1 + YG(K+I,J) = ZERO + 280 CONTINUE + DO 290 J = 1, I-1 + YG(K+I,NB+J) = ZERO + 290 CONTINUE + DO 300 J = 1, I-1 + YA(K+I,J) = ZERO + 300 CONTINUE + DO 310 J = 1, I-1 + YA(K+I,NB+J) = ZERO + 310 CONTINUE +C +C Update XG with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, + $ A(K+I,I), 1, ZERO, XG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, + $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, + $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) +C +C Update G(k+i,:). +C + CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) +C +C Update XB with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, + $ A(K+I,I), 1, ZERO, XB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, + $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, + $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, + $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) +C +C Update B(i,:). +C + CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(I,1), LDB ) +C + A(K+I,I) = TEMP + Q(I,I) = TAUQ + CSL(2*I-1) = C + CSL(2*I) = S +C +C Transform first rows of Q and B. +C + ALPHA = Q(I,I+1) + CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) + Q(I,I+1) = ONE + TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) + CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) + TEMP = B(I,K+I+1) + CALL DLARTG( TEMP, ALPHA, C, S, B(I,K+I+1) ) + S = -S + CALL DLARFG( N-I, B(I,K+I+1), B(I,K+I+2), LDB, TAUR(I) ) + TEMP = B(I,K+I+1) + B(I,K+I+1) = ONE +C +C Update YB with first Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), + $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, + $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, + $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, + $ DWORK, 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) +C +C Update B(i+1:n,k+i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XB(K+I+1,1), LDXB, ONE, B(I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ XB(K+I+1,NB1), LDXB, ONE, B(I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, + $ Q(1,I+1), 1, ONE, B(I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, B(1,K+I+1), 1, ONE, B(I+1,K+I+1), 1 ) +C +C Update YQ with first Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, + $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, + $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, + $ DWORK, 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) +C +C Update Q(i+1:n,i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, + $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, B(1,K+I+1), 1, ONE, Q(I+1,I+1), 1 ) +C +C Apply rotation to [ Q(i+1:n,i+1), B(i+1:n,k+i+1) ]. +C + CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,K+I+1), 1, C, S ) + DO 320 J = 1, I + XB(K+I+1,J) = ZERO + 320 CONTINUE + DO 330 J = 1, I + XB(K+I+1,NB+J) = ZERO + 330 CONTINUE +C +C Update YB with second Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), + $ LDB, B(I,K+I+1), LDB, ZERO, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, + $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, + $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, + $ B(I,K+I+2), LDB, ZERO, DWORK(NB2+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, + $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I-1, ONE, B(1,K+I+2), + $ LDQ, B(I,K+I+2), LDB, ZERO, DWORK(NB3+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) +C +C Update B(i+1:n,k+i+1). +C + CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(I+1,K+I+1), 1 ) +C +C Update YQ with second Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, + $ B(I,K+I+1), LDB, ZERO, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, + $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, + $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, + $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) +C +C Update Q(i+1:n,i+1). +C + CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) +C +C Update YA with first Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, + $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, + $ DWORK, 1, ONE, YA(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) +C +C Update A(1:k+n,i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ Q(1,I+1), 1, ONE, A(1,I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ B(1,K+I+1), 1, ONE, A(1,I+1), 1 ) +C +C Update YG with first Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, + $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, + $ DWORK, 1, ONE, YG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) +C +C Update G(1:k+n,k+i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, + $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ B(1,K+I+1), 1, ONE, G(1,K+I+1), 1 ) + DO 340 J = 1, I + XG(K+I+1,J) = ZERO + 340 CONTINUE + DO 350 J = 1, I + XG(K+I+1,NB+J) = ZERO + 350 CONTINUE +C +C Apply rotation to [ A(1:k+n,i+1), G(1:k+n,k+i+1) ]. +C + CALL DROT( K+N, A(1,I+1), 1, G(1,K+I+1), 1, C, S ) +C +C Update YA with second Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, + $ B(I,K+I+1), LDB, ZERO, YA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, + $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, + $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) +C +C Update A(1:k+n,i+1). +C + CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(1,I+1), 1 ) +C +C Update YG with second Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, + $ B(I,K+I+1), LDB, ZERO, YG(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, + $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, + $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, + $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) +C +C Update G(1:k+n,k+i+1). +C + CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) +C + B(I,K+I+1) = TEMP + Q(I,I+1) = TAUQ + CSR(2*I-1) = C + CSR(2*I) = S + 360 CONTINUE + END IF +C + RETURN +C *** Last line of MB03XU *** + END diff --git a/mex/sources/libslicot/MB03YA.f b/mex/sources/libslicot/MB03YA.f new file mode 100644 index 000000000..0a87c7c30 --- /dev/null +++ b/mex/sources/libslicot/MB03YA.f @@ -0,0 +1,297 @@ + SUBROUTINE MB03YA( WANTT, WANTQ, WANTZ, N, ILO, IHI, ILOQ, IHIQ, + $ POS, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To annihilate one or two entries on the subdiagonal of the +C Hessenberg matrix A for dealing with zero elements on the diagonal +C of the triangular matrix B. +C +C MB03YA is an auxiliary routine called by SLICOT Library routines +C MB03XP and MB03YD. +C +C ARGUMENTS +C +C Mode Parameters +C +C WANTT LOGICAL +C Indicates whether the user wishes to compute the full +C Schur form or the eigenvalues only, as follows: +C = .TRUE. : Compute the full Schur form; +C = .FALSE.: compute the eigenvalues only. +C +C WANTQ LOGICAL +C Indicates whether or not the user wishes to accumulate +C the matrix Q as follows: +C = .TRUE. : The matrix Q is updated; +C = .FALSE.: the matrix Q is not required. +C +C WANTZ LOGICAL +C Indicates whether or not the user wishes to accumulate +C the matrix Z as follows: +C = .TRUE. : The matrix Z is updated; +C = .FALSE.: the matrix Z is not required. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and B. N >= 0. +C +C ILO (input) INTEGER +C IHI (input) INTEGER +C It is assumed that the matrices A and B are already +C (quasi) upper triangular in rows and columns 1:ILO-1 and +C IHI+1:N. The routine works primarily with the submatrices +C in rows and columns ILO to IHI, but applies the +C transformations to all the rows and columns of the +C matrices A and B, if WANTT = .TRUE.. +C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. +C +C ILOQ (input) INTEGER +C IHIQ (input) INTEGER +C Specify the rows of Q and Z to which transformations +C must be applied if WANTQ = .TRUE. and WANTZ = .TRUE., +C respectively. +C 1 <= ILOQ <= ILO; IHI <= IHIQ <= N. +C +C POS (input) INTEGER +C The position of the zero element on the diagonal of B. +C ILO <= POS <= IHI. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the upper Hessenberg matrix A. +C On exit, the leading N-by-N part of this array contains +C the updated matrix A where A(POS,POS-1) = 0, if POS > ILO, +C and A(POS+1,POS) = 0, if POS < IHI. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain an upper triangular matrix B with B(POS,POS) = 0. +C On exit, the leading N-by-N part of this array contains +C the updated upper triangular matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, if WANTQ = .TRUE., then the leading N-by-N part +C of this array must contain the current matrix Q of +C transformations accumulated by MB03XP. +C On exit, if WANTQ = .TRUE., then the leading N-by-N part +C of this array contains the matrix Q updated in the +C submatrix Q(ILOQ:IHIQ,ILO:IHI). +C If WANTQ = .FALSE., Q is not referenced. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= 1. +C If WANTQ = .TRUE., LDQ >= MAX(1,N). +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C On entry, if WANTZ = .TRUE., then the leading N-by-N part +C of this array must contain the current matrix Z of +C transformations accumulated by MB03XP. +C On exit, if WANTZ = .TRUE., then the leading N-by-N part +C of this array contains the matrix Z updated in the +C submatrix Z(ILOQ:IHIQ,ILO:IHI). +C If WANTZ = .FALSE., Z is not referenced. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= 1. +C If WANTZ = .TRUE., LDZ >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The method is illustrated by Wilkinson diagrams for N = 5, +C POS = 3: +C +C [ x x x x x ] [ x x x x x ] +C [ x x x x x ] [ o x x x x ] +C A = [ o x x x x ], B = [ o o o x x ]. +C [ o o x x x ] [ o o o x x ] +C [ o o o x x ] [ o o o o x ] +C +C First, a QR factorization is applied to A(1:3,1:3) and the +C resulting nonzero in the updated matrix B is immediately +C annihilated by a Givens rotation acting on columns 1 and 2: +C +C [ x x x x x ] [ x x x x x ] +C [ x x x x x ] [ o x x x x ] +C A = [ o o x x x ], B = [ o o o x x ]. +C [ o o x x x ] [ o o o x x ] +C [ o o o x x ] [ o o o o x ] +C +C Secondly, an RQ factorization is applied to A(4:5,4:5) and the +C resulting nonzero in the updated matrix B is immediately +C annihilated by a Givens rotation acting on rows 4 and 5: +C +C [ x x x x x ] [ x x x x x ] +C [ x x x x x ] [ o x x x x ] +C A = [ o o x x x ], B = [ o o o x x ]. +C [ o o o x x ] [ o o o x x ] +C [ o o o x x ] [ o o o o x ] +C +C REFERENCES +C +C [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P. +C The periodic Schur decomposition: Algorithms and applications. +C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, +C 1992. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O(N**2) floating point operations and is +C backward stable. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLADFB). +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + LOGICAL WANTQ, WANTT, WANTZ + INTEGER IHI, IHIQ, ILO, ILOQ, INFO, LDA, LDB, LDQ, LDZ, + $ N, POS +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER I1, I2, J, NQ + DOUBLE PRECISION CS, SN, TEMP +C .. External Subroutines .. + EXTERNAL DLARTG, DROT, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + NQ = IHIQ - ILOQ + 1 + IF ( N.LT.0 ) THEN + INFO = -4 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF ( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -6 + ELSE IF ( ILOQ.LT.1 .OR. ILOQ.GT.ILO ) THEN + INFO = -7 + ELSE IF ( IHIQ.LT.IHI .OR. IHIQ.GT.N ) THEN + INFO = -8 + ELSE IF ( POS.LT.ILO .OR. POS.GT.IHI ) THEN + INFO = -9 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF ( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.N ) THEN + INFO = -15 + ELSE IF ( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.N ) THEN + INFO = -17 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03YA', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + IF ( WANTT ) THEN + I1 = 1 + I2 = N + ELSE + I1 = ILO + I2 = IHI + END IF +C +C Apply a zero-shifted QR step. +C + DO 10 J = ILO, POS-1 + TEMP = A(J,J) + CALL DLARTG( TEMP, A(J+1,J), CS, SN, A(J,J) ) + A(J+1,J) = ZERO + CALL DROT( I2-J, A(J,J+1), LDA, A(J+1,J+1), LDA, CS, SN ) + CALL DROT( MIN(J,POS-2)-I1+2, B(I1,J), 1, B(I1,J+1), 1, CS, + $ SN ) + IF ( WANTQ ) + $ CALL DROT( NQ, Q(ILOQ,J), 1, Q(ILOQ,J+1), 1, CS, SN ) + 10 CONTINUE + DO 20 J = ILO, POS-2 + TEMP = B(J,J) + CALL DLARTG( TEMP, B(J+1,J), CS, SN, B(J,J) ) + B(J+1,J) = ZERO + CALL DROT( I2-J, B(J,J+1), LDB, B(J+1,J+1), LDB, CS, SN ) + CALL DROT( J-I1+2, A(I1,J), 1, A(I1,J+1), 1, CS, SN ) + IF ( WANTZ ) + $ CALL DROT( NQ, Z(ILOQ,J), 1, Z(ILOQ,J+1), 1, CS, SN ) + 20 CONTINUE +C +C Apply a zero-shifted RQ step. +C + DO 30 J = IHI, POS+1, -1 + TEMP = A(J,J) + CALL DLARTG( TEMP, A(J,J-1), CS, SN, A(J,J) ) + A(J,J-1) = ZERO + SN = -SN + CALL DROT( J-I1, A(I1,J-1), 1, A(I1,J), 1, CS, SN ) + CALL DROT( I2 - MAX( J-1,POS+1 ) + 1, B(J-1,MAX( J-1,POS+1 )), + $ LDB, B(J,MAX(J-1,POS+1)), LDB, CS, SN ) + IF ( WANTZ ) + $ CALL DROT( NQ, Z(ILOQ,J-1), 1, Z(ILOQ,J), 1, CS, SN ) + 30 CONTINUE + DO 40 J = IHI, POS+2, -1 + TEMP = B(J,J) + CALL DLARTG( TEMP, B(J,J-1), CS, SN, B(J,J) ) + B(J,J-1) = ZERO + SN = -SN + CALL DROT( J-I1, B(I1,J-1), 1, B(I1,J), 1, CS, SN ) + CALL DROT( I2-J+2, A(J-1,J-1), LDA, A(J,J-1), LDA, CS, SN ) + IF ( WANTQ ) + $ CALL DROT( NQ, Q(ILOQ,J-1), 1, Q(ILOQ,J), 1, CS, SN ) + 40 CONTINUE + RETURN +C *** Last line of MB03YA *** + END diff --git a/mex/sources/libslicot/MB03YD.f b/mex/sources/libslicot/MB03YD.f new file mode 100644 index 000000000..e99078cdb --- /dev/null +++ b/mex/sources/libslicot/MB03YD.f @@ -0,0 +1,540 @@ + SUBROUTINE MB03YD( WANTT, WANTQ, WANTZ, N, ILO, IHI, ILOQ, IHIQ, + $ A, LDA, B, LDB, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, + $ BETA, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To deal with small subtasks of the product eigenvalue problem. +C +C MB03YD is an auxiliary routine called by SLICOT Library routine +C MB03XP. +C +C ARGUMENTS +C +C Mode Parameters +C +C WANTT LOGICAL +C Indicates whether the user wishes to compute the full +C Schur form or the eigenvalues only, as follows: +C = .TRUE. : Compute the full Schur form; +C = .FALSE.: compute the eigenvalues only. +C +C WANTQ LOGICAL +C Indicates whether or not the user wishes to accumulate +C the matrix Q as follows: +C = .TRUE. : The matrix Q is updated; +C = .FALSE.: the matrix Q is not required. +C +C WANTZ LOGICAL +C Indicates whether or not the user wishes to accumulate +C the matrix Z as follows: +C = .TRUE. : The matrix Z is updated; +C = .FALSE.: the matrix Z is not required. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and B. N >= 0. +C +C ILO (input) INTEGER +C IHI (input) INTEGER +C It is assumed that the matrices A and B are already +C (quasi) upper triangular in rows and columns 1:ILO-1 and +C IHI+1:N. The routine works primarily with the submatrices +C in rows and columns ILO to IHI, but applies the +C transformations to all the rows and columns of the +C matrices A and B, if WANTT = .TRUE.. +C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. +C +C ILOQ (input) INTEGER +C IHIQ (input) INTEGER +C Specify the rows of Q and Z to which transformations +C must be applied if WANTQ = .TRUE. and WANTZ = .TRUE., +C respectively. +C 1 <= ILOQ <= ILO; IHI <= IHIQ <= N. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the upper Hessenberg matrix A. +C On exit, if WANTT = .TRUE., the leading N-by-N part of +C this array is upper quasi-triangular in rows and columns +C ILO:IHI. +C If WANTT = .FALSE., the diagonal elements and 2-by-2 +C diagonal blocks of A will be correct, but the remaining +C parts of A are unspecified on exit. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain the upper triangular matrix B. +C On exit, if WANTT = .TRUE., the leading N-by-N part of +C this array contains the transformed upper triangular +C matrix. 2-by-2 blocks in B corresponding to 2-by-2 blocks +C in A will be reduced to positive diagonal form. (I.e., if +C A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) +C and B(j+1,j+1) will be positive.) +C If WANTT = .FALSE., the elements corresponding to diagonal +C elements and 2-by-2 diagonal blocks in A will be correct, +C but the remaining parts of B are unspecified on exit. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, if WANTQ = .TRUE., then the leading N-by-N part +C of this array must contain the current matrix Q of +C transformations accumulated by MB03XP. +C On exit, if WANTQ = .TRUE., then the leading N-by-N part +C of this array contains the matrix Q updated in the +C submatrix Q(ILOQ:IHIQ,ILO:IHI). +C If WANTQ = .FALSE., Q is not referenced. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= 1. +C If WANTQ = .TRUE., LDQ >= MAX(1,N). +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C On entry, if WANTZ = .TRUE., then the leading N-by-N part +C of this array must contain the current matrix Z of +C transformations accumulated by MB03XP. +C On exit, if WANTZ = .TRUE., then the leading N-by-N part +C of this array contains the matrix Z updated in the +C submatrix Z(ILOQ:IHIQ,ILO:IHI). +C If WANTZ = .FALSE., Z is not referenced. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= 1. +C If WANTZ = .TRUE., LDZ >= MAX(1,N). +C +C ALPHAR (output) DOUBLE PRECISION array, dimension (N) +C ALPHAI (output) DOUBLE PRECISION array, dimension (N) +C BETA (output) DOUBLE PRECISION array, dimension (N) +C The i-th (ILO <= i <= IHI) computed eigenvalue is given +C by BETA(I) * ( ALPHAR(I) + sqrt(-1)*ALPHAI(I) ). If two +C eigenvalues are computed as a complex conjugate pair, +C they are stored in consecutive elements of ALPHAR, ALPHAI +C and BETA. If WANTT = .TRUE., the eigenvalues are stored in +C the same order as on the diagonals of the Schur forms of +C A and B. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = -19, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, then MB03YD failed to compute the Schur +C form in a total of 30*(IHI-ILO+1) iterations; +C elements i+1:n of ALPHAR, ALPHAI and BETA contain +C successfully computed eigenvalues. +C +C METHOD +C +C The implemented algorithm is a double-shift version of the +C periodic QR algorithm described in [1,3] with some minor +C modifications [2]. The eigenvalues are computed via an implicit +C complex single shift algorithm. +C +C REFERENCES +C +C [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P. +C The periodic Schur decomposition: Algorithms and applications. +C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, +C 1992. +C +C [2] Kressner, D. +C An efficient and reliable implementation of the periodic QZ +C algorithm. Proc. of the IFAC Workshop on Periodic Control +C Systems, pp. 187-192, 2001. +C +C [3] Van Loan, C. +C Generalized Singular Values with Algorithms and Applications. +C Ph. D. Thesis, University of Michigan, 1973. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O(N**3) floating point operations and is +C backward stable. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAPQR). +C +C KEYWORDS +C +C Eigenvalue, eigenvalue decomposition, Hessenberg form, orthogonal +C transformation, (periodic) Schur form +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + LOGICAL WANTQ, WANTT, WANTZ + INTEGER IHI, IHIQ, ILO, ILOQ, INFO, LDA, LDB, LDQ, + $ LDWORK, LDZ, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), + $ BETA(*), DWORK(*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER I, I1, I2, ITN, ITS, K, KK, L, NH, NQ, NR + DOUBLE PRECISION ALPHA, BETAX, CS1, CS2, CS3, DELTA, GAMMA, + $ OVFL, SMLNUM, SN1, SN2, SN3, TAUV, TAUW, + $ TEMP, TST, ULP, UNFL +C .. Local Arrays .. + INTEGER ISEED(4) + DOUBLE PRECISION V(3), W(3) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANHS + EXTERNAL DLAMCH, DLANHS +C .. External Subroutines .. + EXTERNAL DCOPY, DLABAD, DLARFG, DLARFX, DLARNV, DLARTG, + $ DROT, MB03YA, MB03YT, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + NH = IHI - ILO + 1 + NQ = IHIQ - ILOQ + 1 + IF ( N.LT.0 ) THEN + INFO = -4 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF ( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -6 + ELSE IF ( ILOQ.LT.1 .OR. ILOQ.GT.ILO ) THEN + INFO = -7 + ELSE IF ( IHIQ.LT.IHI .OR. IHIQ.GT.N ) THEN + INFO = -8 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF ( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.N ) THEN + INFO = -14 + ELSE IF ( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.N ) THEN + INFO = -16 + ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN + DWORK(1) = DBLE( MAX( 1, N ) ) + INFO = -21 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03YD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C +C Set machine-dependent constants for the stopping criterion. +C + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Precision' ) + SMLNUM = UNFL*( NH / ULP ) +C +C I1 and I2 are the indices of the first rows and last columns of +C A and B to which transformations must be applied. +C + I1 = 1 + I2 = N + ISEED(1) = 1 + ISEED(2) = 0 + ISEED(3) = 0 + ISEED(4) = 1 +C +C ITN is the maximal number of QR iterations. +C + ITN = 30*NH +C +C Main loop. Eigenvalues I+1:IHI have converged. Either L = ILO +C or A(L,L-1) is negligible. +C + I = IHI + 10 CONTINUE + L = ILO + IF ( I.LT.ILO ) + $ GO TO 120 +C +C Perform periodic QR iteration on rows and columns ILO to I of A +C and B until a submatrix of order 1 or 2 splits off at the bottom. +C + DO 70 ITS = 0, ITN +C +C Look for deflations in A. +C + DO 20 K = I, L + 1, -1 + TST = ABS( A(K-1,K-1) ) + ABS( A(K,K) ) + IF ( TST.EQ.ZERO ) + $ TST = DLANHS( '1', I-L+1, A(L,L), LDA, DWORK ) + IF ( ABS( A(K,K-1) ).LE.MAX( ULP*TST, SMLNUM ) ) + $ GO TO 30 + 20 CONTINUE + 30 CONTINUE +C +C Look for deflation in B if problem size is greater than 1. +C + IF ( I-K.GE.1 ) THEN + DO 40 KK = I, K, -1 + IF ( KK.EQ.I ) THEN + TST = ABS( B(KK-1,KK) ) + ELSE IF ( KK.EQ.K ) THEN + TST = ABS( B(KK,KK+1) ) + ELSE + TST = ABS( B(KK-1,KK) ) + ABS( B(KK,KK+1) ) + END IF + IF ( TST.EQ.ZERO ) + $ TST = DLANHS( '1', I-K+1, B(K,K), LDB, DWORK ) + IF ( ABS( B(KK,KK) ).LE.MAX( ULP*TST, SMLNUM ) ) + $ GO TO 50 + 40 CONTINUE + ELSE + KK = K-1 + END IF + 50 CONTINUE + IF ( KK.GE.K ) THEN +C +C B has an element close to zero at position (KK,KK). +C + B(KK,KK) = ZERO + CALL MB03YA( WANTT, WANTQ, WANTZ, N, K, I, ILOQ, IHIQ, KK, + $ A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO ) + K = KK+1 + END IF + L = K + IF( L.GT.ILO ) THEN +C +C A(L,L-1) is negligible. +C + A(L,L-1) = ZERO + END IF +C +C Exit from loop if a submatrix of order 1 or 2 has split off. +C + IF ( L.GE.I-1 ) + $ GO TO 80 +C +C The active submatrices are now in rows and columns L:I. +C + IF ( .NOT.WANTT ) THEN + I1 = L + I2 = I + END IF + IF ( ITS.EQ.10.OR.ITS.EQ.20 ) THEN +C +C Exceptional shift. The first column of the shift polynomial +C is a pseudo-random vector. +C + CALL DLARNV( 3, ISEED, 3, V ) + ELSE +C +C The implicit double shift is constructed via a partial +C product QR factorization [2]. +C + CALL DLARTG( B(L,L), B(I,I), CS2, SN2, TEMP ) + CALL DLARTG( TEMP, B(I-1,I), CS1, SN1, ALPHA ) +C + ALPHA = A(L,L)*CS2 - A(I,I)*SN2 + BETAX = CS1*( CS2*A(L+1,L) ) + GAMMA = CS1*( SN2*A(I-1,I) ) + SN1*A(I-1,I-1) + ALPHA = ALPHA*CS1 - A(I,I-1)*SN1 + CALL DLARTG( ALPHA, BETAX, CS1, SN1, TEMP ) +C + CALL DLARTG( TEMP, GAMMA, CS2, SN2, ALPHA ) + ALPHA = CS2 + GAMMA = ( A(I-1,I-1)*CS1 )*CS2 + A(I,I-1)*SN2 + DELTA = ( A(I-1,I-1)*SN1 )*CS2 + CALL DLARTG( GAMMA, DELTA, CS3, SN3, TEMP ) + CALL DLARTG( ALPHA, TEMP, CS2, SN2, ALPHA ) +C + ALPHA = ( B(L,L)*CS1 + B(L,L+1)*SN1 )*CS2 + BETAX = ( B(L+1,L+1)*SN1 )*CS2 + GAMMA = B(I-1,I-1)*SN2 + CALL DLARTG( ALPHA, BETAX, CS1, SN1, TEMP ) + CALL DLARTG( TEMP, GAMMA, CS2, SN2, ALPHA ) +C + ALPHA = CS1*A(L,L) + SN1*A(L,L+1) + BETAX = CS1*A(L+1,L) + SN1*A(L+1,L+1) + GAMMA = SN1*A(L+2,L+1) +C + V(1) = CS2*ALPHA - SN2*CS3 + V(2) = CS2*BETAX - SN2*SN3 + V(3) = GAMMA*CS2 + END IF +C +C Double-shift QR step +C + DO 60 K = L, I-1 +C + NR = MIN( 3,I-K+1 ) + IF ( K.GT.L ) + $ CALL DCOPY( NR, A(K,K-1), 1, V, 1 ) + CALL DLARFG( NR, V(1), V(2), 1, TAUV ) + IF ( K.GT.L ) THEN + A(K,K-1) = V(1) + A(K+1,K-1) = ZERO + IF ( K.LT.I-1 ) + $ A(K+2,K-1) = ZERO + END IF +C +C Apply reflector V from the right to B in rows I1:min(K+2,I). +C + V(1) = ONE + CALL DLARFX( 'Right', MIN(K+2,I)-I1+1, NR, V, TAUV, B(I1,K), + $ LDB, DWORK ) +C +C Annihilate the introduced nonzeros in the K-th column. +C + CALL DCOPY( NR, B(K,K), 1, W, 1 ) + CALL DLARFG( NR, W(1), W(2), 1, TAUW ) + B(K,K) = W(1) + B(K+1,K) = ZERO + IF ( K.LT.I-1 ) + $ B(K+2,K) = ZERO +C +C Apply reflector W from the left to transform the rows of the +C matrix B in columns K+1:I2. +C + W(1) = ONE + CALL DLARFX( 'Left', NR, I2-K, W, TAUW, B(K,K+1), LDB, + $ DWORK ) +C +C Apply reflector V from the left to transform the rows of the +C matrix A in columns K:I2. +C + CALL DLARFX( 'Left', NR, I2-K+1, V, TAUV, A(K,K), LDA, + $ DWORK ) +C +C Apply reflector W from the right to transform the columns of +C the matrix A in rows I1:min(K+3,I). +C + CALL DLARFX( 'Right', MIN(K+3,I)-I1+1, NR, W, TAUW, A(I1,K), + $ LDA, DWORK ) +C +C Accumulate transformations in the matrices Q and Z. +C + IF ( WANTQ ) + $ CALL DLARFX( 'Right', NQ, NR, V, TAUV, Q(ILOQ,K), LDQ, + $ DWORK ) + IF ( WANTZ ) + $ CALL DLARFX( 'Right', NQ, NR, W, TAUW, Z(ILOQ,K), LDZ, + $ DWORK ) + 60 CONTINUE + 70 CONTINUE +C +C Failure to converge. +C + INFO = I + RETURN +C + 80 CONTINUE +C +C Compute 1-by-1 or 2-by-2 subproblem. +C + IF ( L.EQ.I ) THEN +C +C Standardize B, set ALPHAR, ALPHAI and BETA. +C + IF ( B(I,I).LT.ZERO ) THEN + IF ( WANTT ) THEN + DO 90 K = I1, I + B(K,I) = -B(K,I) + 90 CONTINUE + DO 100 K = I, I2 + A(I,K) = -A(I,K) + 100 CONTINUE + ELSE + B(I,I) = -B(I,I) + A(I,I) = -A(I,I) + END IF + IF ( WANTQ ) THEN + DO 110 K = ILOQ, IHIQ + Q(K,I) = -Q(K,I) + 110 CONTINUE + END IF + END IF + ALPHAR(I) = A(I,I) + ALPHAI(I) = ZERO + BETA(I) = B(I,I) + ELSE IF( L.EQ.I-1 ) THEN +C +C A double block has converged. +C Compute eigenvalues and standardize double block. +C + CALL MB03YT( A(I-1,I-1), LDA, B(I-1,I-1), LDB, ALPHAR(I-1), + $ ALPHAI(I-1), BETA(I-1), CS1, SN1, CS2, SN2 ) +C +C Apply transformation to rest of A and B. +C + IF ( I2.GT.I ) + $ CALL DROT( I2-I, A(I-1,I+1), LDA, A(I,I+1), LDA, CS1, SN1 ) + CALL DROT( I-I1-1, A(I1,I-1), 1, A(I1,I), 1, CS2, SN2 ) + IF ( I2.GT.I ) + $ CALL DROT( I2-I, B(I-1,I+1), LDB, B(I,I+1), LDB, CS2, SN2 ) + CALL DROT( I-I1-1, B(I1,I-1), 1, B(I1,I), 1, CS1, SN1 ) +C +C Apply transformation to rest of Q and Z if desired. +C + IF ( WANTQ ) + $ CALL DROT( NQ, Q(ILOQ,I-1), 1, Q(ILOQ,I), 1, CS1, SN1 ) + IF ( WANTZ ) + $ CALL DROT( NQ, Z(ILOQ,I-1), 1, Z(ILOQ,I), 1, CS2, SN2 ) + END IF +C +C Decrement number of remaining iterations, and return to start of +C the main loop with new value of I. +C + ITN = ITN - ITS + I = L - 1 + GO TO 10 +C + 120 CONTINUE + DWORK(1) = DBLE( MAX( 1, N ) ) + RETURN +C *** Last line of MB03YD *** + END diff --git a/mex/sources/libslicot/MB03YT.f b/mex/sources/libslicot/MB03YT.f new file mode 100644 index 000000000..774b0bdda --- /dev/null +++ b/mex/sources/libslicot/MB03YT.f @@ -0,0 +1,331 @@ + SUBROUTINE MB03YT( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, + $ CSR, SNR ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the periodic Schur factorization of a real 2-by-2 +C matrix pair (A,B) where B is upper triangular. This routine +C computes orthogonal (rotation) matrices given by CSL, SNL and CSR, +C SNR such that +C +C 1) if the pair (A,B) has two real eigenvalues, then +C +C [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] +C [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] +C +C [ b11 b12 ] := [ CSR SNR ] [ b11 b12 ] [ CSL -SNL ] +C [ 0 b22 ] [ -SNR CSR ] [ 0 b22 ] [ SNL CSL ], +C +C 2) if the pair (A,B) has a pair of complex conjugate eigenvalues, +C then +C +C [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] +C [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] +C +C [ b11 0 ] := [ CSR SNR ] [ b11 b12 ] [ CSL -SNL ] +C [ 0 b22 ] [ -SNR CSR ] [ 0 b22 ] [ SNL CSL ]. +C +C This is a modified version of the LAPACK routine DLAGV2 for +C computing the real, generalized Schur decomposition of a +C two-by-two matrix pencil. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,2) +C On entry, the leading 2-by-2 part of this array must +C contain the matrix A. +C On exit, the leading 2-by-2 part of this array contains +C the matrix A of the pair in periodic Schur form. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= 2. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,2) +C On entry, the leading 2-by-2 part of this array must +C contain the upper triangular matrix B. +C On exit, the leading 2-by-2 part of this array contains +C the matrix B of the pair in periodic Schur form. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= 2. +C +C ALPHAR (output) DOUBLE PRECISION array, dimension (2) +C ALPHAI (output) DOUBLE PRECISION array, dimension (2) +C BETA (output) DOUBLE PRECISION array, dimension (2) +C (ALPHAR(k)+i*ALPHAI(k))*BETA(k) are the eigenvalues of the +C pair (A,B), k=1,2, i = sqrt(-1). ALPHAI(1) >= 0. +C +C CSL (output) DOUBLE PRECISION +C The cosine of the first rotation matrix. +C +C SNL (output) DOUBLE PRECISION +C The sine of the first rotation matrix. +C +C CSR (output) DOUBLE PRECISION +C The cosine of the second rotation matrix. +C +C SNR (output) DOUBLE PRECISION +C The sine of the second rotation matrix. +C +C REFERENCES +C +C [1] Van Loan, C. +C Generalized Singular Values with Algorithms and Applications. +C Ph. D. Thesis, University of Michigan, 1973. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAPV2). +C V. Sima, July 2008, May 2009. +C +C KEYWORDS +C +C Eigenvalue, periodic Schur form +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER LDA, LDB + DOUBLE PRECISION CSL, CSR, SNL, SNR +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ALPHAI(2), ALPHAR(2), B(LDB,*), + $ BETA(2) +C .. Local Scalars .. + DOUBLE PRECISION ANORM, BNORM, H1, H2, H3, QQ, R, RR, SAFMIN, + $ SCALE1, SCALE2, T, ULP, WI, WR1, WR2 +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 +C .. External Subroutines .. + EXTERNAL DLAG2, DLARTG, DLASV2, DROT +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C +C .. Executable Statements .. +C + SAFMIN = DLAMCH( 'S' ) + ULP = DLAMCH( 'P' ) +C +C Scale A. +C + ANORM = MAX( ABS( A(1,1) ) + ABS( A(2,1) ), + $ ABS( A(1,2) ) + ABS( A(2,2) ), SAFMIN ) + A(1,1) = A(1,1) / ANORM + A(1,2) = A(1,2) / ANORM + A(2,1) = A(2,1) / ANORM + A(2,2) = A(2,2) / ANORM +C +C Scale B. +C + BNORM = MAX( ABS( B(1,1) ), ABS( B(1,2) ) + ABS( B(2,2) ), SAFMIN) + B(1,1) = B(1,1) / BNORM + B(1,2) = B(1,2) / BNORM + B(2,2) = B(2,2) / BNORM +C +C Check if A can be deflated. +C + IF ( ABS( A(2,1) ).LE.ULP ) THEN + CSL = ONE + SNL = ZERO + CSR = ONE + SNR = ZERO + WI = ZERO + A(2,1) = ZERO + B(2,1) = ZERO +C +C Check if B is singular. +C + ELSE IF ( ABS( B(1,1) ).LE.ULP ) THEN + CALL DLARTG( A(2,2), A(2,1), CSR, SNR, T ) + SNR = -SNR + CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR ) + CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSR, SNR ) + CSL = ONE + SNL = ZERO + WI = ZERO + A(2,1) = ZERO + B(1,1) = ZERO + B(2,1) = ZERO + ELSE IF( ABS( B(2,2) ).LE.ULP ) THEN + CALL DLARTG( A(1,1), A(2,1), CSL, SNL, R ) + CSR = ONE + SNR = ZERO + WI = ZERO + CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL ) + CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSL, SNL ) + A(2,1) = ZERO + B(2,1) = ZERO + B(2,2) = ZERO + ELSE +C +C B is nonsingular, first compute the eigenvalues of A / adj(B). +C + R = B(1,1) + B(1,1) = B(2,2) + B(2,2) = R + B(1,2) = -B(1,2) + CALL DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, + $ WI ) +C + IF( WI.EQ.ZERO ) THEN +C +C Two real eigenvalues, compute s*A-w*B. +C + H1 = SCALE1*A(1,1) - WR1*B(1,1) + H2 = SCALE1*A(1,2) - WR1*B(1,2) + H3 = SCALE1*A(2,2) - WR1*B(2,2) +C + RR = DLAPY2( H1, H2 ) + QQ = DLAPY2( SCALE1*A(2,1), H3 ) +C + IF ( RR.GT.QQ ) THEN +C +C Find right rotation matrix to zero 1,1 element of +C (sA - wB). +C + CALL DLARTG( H2, H1, CSR, SNR, T ) +C + ELSE +C +C Find right rotation matrix to zero 2,1 element of +C (sA - wB). +C + CALL DLARTG( H3, SCALE1*A(2,1), CSR, SNR, T ) +C + END IF +C + SNR = -SNR + CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR ) + CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSR, SNR ) +C +C Compute inf norms of A and B. +C + H1 = MAX( ABS( A(1,1) ) + ABS( A(1,2) ), + $ ABS( A(2,1) ) + ABS( A(2,2) ) ) + H2 = MAX( ABS( B(1,1) ) + ABS( B(1,2) ), + $ ABS( B(2,1) ) + ABS( B(2,2) ) ) +C + IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN +C +C Find left rotation matrix Q to zero out B(2,1). +C + CALL DLARTG( B(1,1), B(2,1), CSL, SNL, R ) +C + ELSE +C +C Find left rotation matrix Q to zero out A(2,1). +C + CALL DLARTG( A(1,1), A(2,1), CSL, SNL, R ) +C + END IF +C + CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL ) + CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSL, SNL ) +C + A(2,1) = ZERO + B(2,1) = ZERO +C +C Re-adjoint B. +C + R = B(1,1) + B(1,1) = B(2,2) + B(2,2) = R + B(1,2) = -B(1,2) +C + ELSE +C +C A pair of complex conjugate eigenvalues: +C first compute the SVD of the matrix adj(B). +C + R = B(1,1) + B(1,1) = B(2,2) + B(2,2) = R + B(1,2) = -B(1,2) + CALL DLASV2( B(1,1), B(1,2), B(2,2), R, T, SNL, CSL, + $ SNR, CSR ) +C +C Form (A,B) := Q(A,adj(B))Z' where Q is left rotation matrix +C and Z is right rotation matrix computed from DLASV2. +C + CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL ) + CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSR, SNR ) + CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR ) + CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSL, SNL ) +C + B(2,1) = ZERO + B(1,2) = ZERO + END IF +C + END IF +C +C Unscaling +C + R = B(1,1) + T = B(2,2) + A(1,1) = ANORM*A(1,1) + A(2,1) = ANORM*A(2,1) + A(1,2) = ANORM*A(1,2) + A(2,2) = ANORM*A(2,2) + B(1,1) = BNORM*B(1,1) + B(2,1) = BNORM*B(2,1) + B(1,2) = BNORM*B(1,2) + B(2,2) = BNORM*B(2,2) +C + IF( WI.EQ.ZERO ) THEN + ALPHAR(1) = A(1,1) + ALPHAR(2) = A(2,2) + ALPHAI(1) = ZERO + ALPHAI(2) = ZERO + BETA(1) = B(1,1) + BETA(2) = B(2,2) + ELSE + WR1 = ANORM*WR1 + WI = ANORM*WI + IF ( ABS( WR1 ).GT.ONE .OR. WI.GT.ONE ) THEN + WR1 = WR1*R + WI = WI*R + R = ONE + END IF + IF ( ABS( WR1 ).GT.ONE .OR. ABS( WI ).GT.ONE ) THEN + WR1 = WR1*T + WI = WI*T + T = ONE + END IF + ALPHAR(1) = ( WR1 / SCALE1 )*R*T + ALPHAI(1) = ABS( ( WI / SCALE1 )*R*T ) + ALPHAR(2) = ALPHAR(1) + ALPHAI(2) = -ALPHAI(1) + BETA(1) = BNORM + BETA(2) = BNORM + END IF + RETURN +C *** Last line of MB03YT *** + END diff --git a/mex/sources/libslicot/MB03ZA.f b/mex/sources/libslicot/MB03ZA.f new file mode 100644 index 000000000..814525200 --- /dev/null +++ b/mex/sources/libslicot/MB03ZA.f @@ -0,0 +1,1371 @@ + SUBROUTINE MB03ZA( COMPC, COMPU, COMPV, COMPW, WHICH, SELECT, N, + $ A, LDA, B, LDB, C, LDC, U1, LDU1, U2, LDU2, V1, + $ LDV1, V2, LDV2, W, LDW, WR, WI, M, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C 1. To compute, for a given matrix pair (A,B) in periodic Schur +C form, orthogonal matrices Ur and Vr so that +C +C T [ A11 A12 ] T [ B11 B12 ] +C Vr * A * Ur = [ ], Ur * B * Vr = [ ], (1) +C [ 0 A22 ] [ 0 B22 ] +C +C is in periodic Schur form, and the eigenvalues of A11*B11 +C form a selected cluster of eigenvalues. +C +C 2. To compute an orthogonal matrix W so that +C +C T [ 0 -A11 ] [ R11 R12 ] +C W * [ ] * W = [ ], (2) +C [ B11 0 ] [ 0 R22 ] +C +C where the eigenvalues of R11 and -R22 coincide and have +C positive real part. +C +C Optionally, the matrix C is overwritten by Ur'*C*Vr. +C +C All eigenvalues of A11*B11 must either be complex or real and +C negative. +C +C ARGUMENTS +C +C Mode Parameters +C +C COMPC CHARACTER*1 +C = 'U': update the matrix C; +C = 'N': do not update C. +C +C COMPU CHARACTER*1 +C = 'U': update the matrices U1 and U2; +C = 'N': do not update U1 and U2. +C See the description of U1 and U2. +C +C COMPV CHARACTER*1 +C = 'U': update the matrices V1 and V2; +C = 'N': do not update V1 and V2. +C See the description of V1 and V2. +C +C COMPW CHARACTER*1 +C Indicates whether or not the user wishes to accumulate +C the matrix W as follows: +C = 'N': the matrix W is not required; +C = 'I': W is initialized to the unit matrix and the +C orthogonal transformation matrix W is returned; +C = 'V': W must contain an orthogonal matrix Q on entry, +C and the product Q*W is returned. +C +C WHICH CHARACTER*1 +C = 'A': select all eigenvalues, this effectively means +C that Ur and Vr are identity matrices and A11 = A, +C B11 = B; +C = 'S': select a cluster of eigenvalues specified by +C SELECT. +C +C SELECT LOGICAL array, dimension (N) +C If WHICH = 'S', then SELECT specifies the eigenvalues of +C A*B in the selected cluster. To select a real eigenvalue +C w(j), SELECT(j) must be set to .TRUE.. To select a complex +C conjugate pair of eigenvalues w(j) and w(j+1), +C corresponding to a 2-by-2 diagonal block in A, both +C SELECT(j) and SELECT(j+1) must be set to .TRUE.; a complex +C conjugate pair of eigenvalues must be either both included +C in the cluster or both excluded. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the upper quasi-triangular matrix A of the matrix +C pair (A,B) in periodic Schur form. +C On exit, the leading M-by-M part of this array contains +C the matrix R22 in (2). +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain the upper triangular matrix B of the matrix pair +C (A,B) in periodic Schur form. +C On exit, the leading N-by-N part of this array is +C overwritten. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, if COMPC = 'U', the leading N-by-N part of this +C array must contain a general matrix C. +C On exit, if COMPC = 'U', the leading N-by-N part of this +C array contains the updated matrix Ur'*C*Vr. +C If COMPC = 'N' or WHICH = 'A', this array is not +C referenced. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= 1. +C LDC >= N, if COMPC = 'U' and WHICH = 'S'. +C +C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) +C On entry, if COMPU = 'U' and WHICH = 'S', the leading +C N-by-N part of this array must contain U1, the (1,1) +C block of an orthogonal symplectic matrix +C U = [ U1, U2; -U2, U1 ]. +C On exit, if COMPU = 'U' and WHICH = 'S', the leading +C N-by-N part of this array contains U1*Ur. +C If COMPU = 'N' or WHICH = 'A', this array is not +C referenced. +C +C LDU1 INTEGER +C The leading dimension of the array U1. LDU1 >= 1. +C LDU1 >= N, if COMPU = 'U' and WHICH = 'S'. +C +C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) +C On entry, if COMPU = 'U' and WHICH = 'S', the leading +C N-by-N part of this array must contain U2, the (1,2) +C block of an orthogonal symplectic matrix +C U = [ U1, U2; -U2, U1 ]. +C On exit, if COMPU = 'U' and WHICH = 'S', the leading +C N-by-N part of this array contains U2*Ur. +C If COMPU = 'N' or WHICH = 'A', this array is not +C referenced. +C +C LDU2 INTEGER +C The leading dimension of the array U2. LDU2 >= 1. +C LDU2 >= N, if COMPU = 'U' and WHICH = 'S'. +C +C V1 (input/output) DOUBLE PRECISION array, dimension (LDV1,N) +C On entry, if COMPV = 'U' and WHICH = 'S', the leading +C N-by-N part of this array must contain V1, the (1,1) +C block of an orthogonal symplectic matrix +C V = [ V1, V2; -V2, V1 ]. +C On exit, if COMPV = 'U' and WHICH = 'S', the leading +C N-by-N part of this array contains V1*Vr. +C If COMPV = 'N' or WHICH = 'A', this array is not +C referenced. +C +C LDV1 INTEGER +C The leading dimension of the array V1. LDV1 >= 1. +C LDV1 >= N, if COMPV = 'U' and WHICH = 'S'. +C +C V2 (input/output) DOUBLE PRECISION array, dimension (LDV2,N) +C On entry, if COMPV = 'U' and WHICH = 'S', the leading +C N-by-N part of this array must contain V2, the (1,2) +C block of an orthogonal symplectic matrix +C V = [ V1, V2; -V2, V1 ]. +C On exit, if COMPV = 'U' and WHICH = 'S', the leading +C N-by-N part of this array contains V2*Vr. +C If COMPV = 'N' or WHICH = 'A', this array is not +C referenced. +C +C LDV2 INTEGER +C The leading dimension of the array V2. LDV2 >= 1. +C LDV2 >= N, if COMPV = 'U' and WHICH = 'S'. +C +C W (input/output) DOUBLE PRECISION array, dimension (LDW,2*M) +C On entry, if COMPW = 'V', then the leading 2*M-by-2*M part +C of this array must contain a matrix W. +C If COMPW = 'I', then W need not be set on entry, W is set +C to the identity matrix. +C On exit, if COMPW = 'I' or 'V' the leading 2*M-by-2*M part +C of this array is post-multiplied by the transformation +C matrix that produced (2). +C If COMPW = 'N', this array is not referenced. +C +C LDW INTEGER +C The leading dimension of the array W. LDW >= 1. +C LDW >= 2*M, if COMPW = 'I' or COMPW = 'V'. +C +C WR (output) DOUBLE PRECISION array, dimension (M) +C WI (output) DOUBLE PRECISION array, dimension (M) +C The real and imaginary parts, respectively, of the +C eigenvalues of R22. The eigenvalues are stored in the same +C order as on the diagonal of R22, with +C WR(i) = R22(i,i) and, if R22(i:i+1,i:i+1) is a 2-by-2 +C diagonal block, WI(i) > 0 and WI(i+1) = -WI(i). +C In exact arithmetic, these eigenvalue are the positive +C square roots of the selected eigenvalues of the product +C A*B. However, if an eigenvalue is sufficiently +C ill-conditioned, then its value may differ significantly. +C +C M (output) INTEGER +C The number of selected eigenvalues. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = -28, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, 4*N, 8*M ). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: reordering of the product A*B in Step 1 failed +C because some eigenvalues are too close to separate; +C = 2: reordering of some submatrix in Step 2 failed +C because some eigenvalues are too close to separate; +C = 3: the QR algorithm failed to compute the Schur form +C of some submatrix in Step 2; +C = 4: the condition that all eigenvalues of A11*B11 must +C either be complex or real and negative is +C numerically violated. +C +C METHOD +C +C Step 1 is performed using a reordering technique analogous to the +C LAPACK routine DTGSEN for reordering matrix pencils [1,2]. Step 2 +C is an implementation of Algorithm 2 in [3]. It requires O(M*N*N) +C floating point operations. +C +C REFERENCES +C +C [1] Kagstrom, B. +C A direct method for reordering eigenvalues in the generalized +C real Schur form of a regular matrix pair (A,B), in M.S. Moonen +C et al (eds), Linear Algebra for Large Scale and Real-Time +C Applications, Kluwer Academic Publ., 1993, pp. 195-218. +C +C [2] Kagstrom, B. and Poromaa P.: +C Computing eigenspaces with specified eigenvalues of a regular +C matrix pair (A, B) and condition estimation: Theory, +C algorithms and software, Numer. Algorithms, 1996, vol. 12, +C pp. 369-407. +C +C [3] Benner, P., Mehrmann, V., and Xu, H. +C A new method for computing the stable invariant subspace of a +C real Hamiltonian matrix, J. Comput. Appl. Math., 86, +C pp. 17-43, 1997. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLABMX). +C +C KEYWORDS +C +C Hamiltonian matrix, invariant subspace. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER LDQZ + PARAMETER ( LDQZ = 4 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER COMPC, COMPU, COMPV, COMPW, WHICH + INTEGER INFO, LDA, LDB, LDC, LDU1, LDU2, LDV1, LDV2, + $ LDW, LDWORK, M, N +C .. Array Arguments .. + LOGICAL SELECT(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ U1(LDU1,*), U2(LDU2,*), V1(LDV1,*), V2(LDV2,*), + $ W(LDW,*), WI(*), WR(*) +C .. Local Scalars .. + LOGICAL CMPALL, INITW, PAIR, SWAP, WANTC, WANTU, WANTV, + $ WANTW + INTEGER HERE, I, IERR, IFST, ILST, K, KS, L, LEN, MM, + $ NB, NBF, NBL, NBNEXT, POS, PW, PWC, PWCK, PWD, + $ PWDL, WRKMIN + DOUBLE PRECISION TEMP +C .. Local Arrays .. + LOGICAL LDUM(1), SELNEW(4) + DOUBLE PRECISION DW12(12), Q(LDQZ,LDQZ), T(LDQZ,LDQZ), WINEW(4), + $ WRNEW(4), Z(LDQZ,LDQZ) + INTEGER IDUM(1) +C .. External Functions .. + LOGICAL LFDUM, LSAME + EXTERNAL LFDUM, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEMM, DLACPY, DLASET, DSCAL, + $ DTRSEN, MB03WA, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C +C Decode and check input parameters +C + WANTC = LSAME( COMPC, 'U' ) + WANTU = LSAME( COMPU, 'U' ) + WANTV = LSAME( COMPV, 'U' ) + INITW = LSAME( COMPW, 'I' ) + WANTW = INITW .OR. LSAME( COMPW, 'V' ) + CMPALL = LSAME( WHICH, 'A' ) + WRKMIN = MAX( 1, 4*N ) +C + INFO = 0 + IF ( .NOT.WANTC .AND. .NOT.LSAME( COMPC, 'N' ) ) THEN + INFO = -1 + ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( COMPU, 'N' ) ) THEN + INFO = -2 + ELSE IF ( .NOT.WANTV .AND. .NOT.LSAME( COMPV, 'N' ) ) THEN + INFO = -3 + ELSE IF ( .NOT.WANTW .AND. .NOT.LSAME( COMPW, 'N' ) ) THEN + INFO = -4 + ELSE IF ( .NOT.CMPALL .AND. .NOT.LSAME( WHICH, 'S' ) ) THEN + INFO = -5 + ELSE + IF ( CMPALL ) THEN + M = N + ELSE +C +C Set M to the dimension of the specified invariant subspace. +C + M = 0 + PAIR = .FALSE. + DO 10 K = 1, N + IF ( PAIR ) THEN + PAIR = .FALSE. + ELSE + IF ( K.LT.N ) THEN + IF ( A(K+1,K).EQ.ZERO ) THEN + IF ( SELECT(K) ) + $ M = M + 1 + ELSE + PAIR = .TRUE. + IF ( SELECT(K) .OR. SELECT(K+1) ) + $ M = M + 2 + END IF + ELSE + IF ( SELECT(N) ) + $ M = M + 1 + END IF + END IF + 10 CONTINUE + END IF +C +C Compute workspace requirements. +C + WRKMIN = MAX( WRKMIN, 8*M ) +C + IF ( N.LT.0 ) THEN + INFO = -7 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF ( LDC.LT.1 .OR. ( WANTC .AND. .NOT.CMPALL .AND. + $ LDC.LT.N ) ) THEN + INFO = -13 + ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. .NOT.CMPALL .AND. + $ LDU1.LT.N ) ) THEN + INFO = -15 + ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. .NOT.CMPALL .AND. + $ LDU2.LT.N ) ) THEN + INFO = -17 + ELSE IF ( LDV1.LT.1 .OR. ( WANTV .AND. .NOT.CMPALL .AND. + $ LDV1.LT.N ) ) THEN + INFO = -19 + ELSE IF ( LDV2.LT.1 .OR. ( WANTV .AND. .NOT.CMPALL .AND. + $ LDV2.LT.N ) ) THEN + INFO = -21 + ELSE IF ( LDW.LT.1 .OR. ( WANTW .AND. LDW.LT.2*M ) ) THEN + INFO = -23 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + INFO = -28 + DWORK(1) = DBLE( WRKMIN ) + END IF + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03ZA', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Jump immediately to Step 2, if all eigenvalues are requested. +C + IF ( CMPALL ) + $ GO TO 50 +C +C Step 1: Collect the selected blocks at the top-left corner of A*B. +C + KS = 0 + PAIR = .FALSE. + DO 40 K = 1, N + IF ( PAIR ) THEN + PAIR = .FALSE. + ELSE + SWAP = SELECT(K) + IF ( K.LT.N ) THEN + IF ( A(K+1,K).NE.ZERO ) THEN + PAIR = .TRUE. + SWAP = SWAP .OR. SELECT(K+1) + END IF + END IF +C + IF ( PAIR ) THEN + NBF = 2 + ELSE + NBF = 1 + END IF +C + IF ( SWAP ) THEN + KS = KS + 1 + IFST = K +C +C Swap the K-th block to position KS. +C + ILST = KS + NBL = 1 + IF ( ILST.GT.1 ) THEN + IF ( A(ILST,ILST-1).NE.ZERO ) THEN + ILST = ILST - 1 + NBL = 2 + END IF + END IF +C + IF ( ILST.EQ.IFST ) + $ GO TO 30 +C + HERE = IFST + 20 CONTINUE +C +C Swap block with next one above. +C + IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN +C +C Current block either 1-by-1 or 2-by-2. +C + NBNEXT = 1 + IF ( HERE.GE.3 ) THEN + IF ( A(HERE-1,HERE-2).NE.ZERO ) + $ NBNEXT = 2 + END IF + POS = HERE - NBNEXT + NB = NBNEXT + NBF + CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) + CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) +C + CALL MB03WA( .TRUE., .TRUE., NBNEXT, NBF, A(POS,POS), + $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, LDQZ, + $ IERR ) +C + IF ( IERR.NE.0 ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 1 + RETURN + END IF +C +C Update rest of A. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, + $ NB, NB, ONE, A(1,POS), LDA, Z, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, A(1,POS), + $ LDA ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Q, LDQZ, + $ A(POS,POS+NB), LDA, ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, + $ A(POS,POS+NB), LDA ) + END IF +C +C Update rest of B. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, + $ NB, NB, ONE, B(1,POS), LDB, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, B(1,POS), + $ LDB ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Z, LDQZ, + $ B(POS,POS+NB), LDB, ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, + $ B(POS,POS+NB), LDB ) + END IF +C +C Update C. +C + IF ( WANTC ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, C(1,POS), LDC, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS), + $ LDC ) + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N, NB, ONE, Z, LDQZ, C(POS,1), LDC, + $ ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1), + $ LDC ) + END IF +C +C Update U. +C + IF ( WANTU ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, U1(1,POS), LDU1, Z, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS), + $ LDU1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, U2(1,POS), LDU2, Z, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS), + $ LDU2 ) + END IF +C +C Update V. +C + IF ( WANTV ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, V1(1,POS), LDV1, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS), + $ LDV1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, V2(1,POS), LDV2, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS), + $ LDV2 ) + END IF +C + HERE = HERE - NBNEXT +C +C Test if 2-by-2 block breaks into two 1-by-1 blocks. +C + IF ( NBF.EQ.2 ) THEN + IF ( A(HERE+1,HERE).EQ.ZERO ) + $ NBF = 3 + END IF +C + ELSE +C +C Current block consists of two 1 by 1 blocks each of +C which must be swapped individually. +C + NBNEXT = 1 + IF ( HERE.GE.3 ) THEN + IF ( A(HERE-1,HERE-2).NE.ZERO ) + $ NBNEXT = 2 + END IF + POS = HERE - NBNEXT + NB = NBNEXT + 1 + CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) + CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) +C + CALL MB03WA( .TRUE., .TRUE., NBNEXT, 1, A(POS,POS), + $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, LDQZ, + $ IERR ) +C + IF ( IERR.NE.0 ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 1 + RETURN + END IF +C +C Update rest of A. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, + $ NB, NB, ONE, A(1,POS), LDA, Z, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, A(1,POS), + $ LDA ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Q, LDQZ, + $ A(POS,POS+NB), LDA, ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, + $ A(POS,POS+NB), LDA ) + END IF +C +C Update rest of B. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, + $ NB, NB, ONE, B(1,POS), LDB, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, B(1,POS), + $ LDB ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Z, LDQZ, + $ B(POS,POS+NB), LDB, ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, + $ B(POS,POS+NB), LDB ) + END IF +C +C Update C. +C + IF ( WANTC ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, C(1,POS), LDC, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS), + $ LDC ) + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N, NB, ONE, Z, LDQZ, C(POS,1), LDC, + $ ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1), + $ LDC ) + END IF +C +C Update U. +C + IF ( WANTU ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, U1(1,POS), LDU1, Z, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS), + $ LDU1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, U2(1,POS), LDU2, Z, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS), + $ LDU2 ) + END IF +C +C Update V. +C + IF ( WANTV ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, V1(1,POS), LDV1, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS), + $ LDV1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, V2(1,POS), LDV2, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS), + $ LDV2 ) + END IF +C + IF ( NBNEXT.EQ.1 ) THEN +C +C Swap two 1-by-1 blocks. +C + POS = HERE + NB = NBNEXT + 1 + CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) + CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) +C + CALL MB03WA( .TRUE., .TRUE., NBNEXT, 1, A(POS,POS), + $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, + $ LDQZ, IERR ) +C + IF ( IERR.NE.0 ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 1 + RETURN + END IF +C +C Update rest of A. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ POS-1, NB, NB, ONE, A(1,POS), LDA, + $ Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, + $ A(1,POS), LDA ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Q, LDQZ, + $ A(POS,POS+NB), LDA, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, + $ A(POS,POS+NB), LDA ) + END IF +C +C Update rest of B. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ POS-1, NB, NB, ONE, B(1,POS), LDB, + $ Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, + $ B(1,POS), LDB ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Z, LDQZ, + $ B(POS,POS+NB), LDB, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, + $ B(POS,POS+NB), LDB ) + END IF +C +C Update C. +C + IF ( WANTC ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, C(1,POS), LDC, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS), + $ LDC ) + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N, NB, ONE, Z, LDQZ, C(POS,1), LDC, + $ ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1), + $ LDC ) + END IF +C +C Update U. +C + IF ( WANTU ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, U1(1,POS), LDU1, Z, + $ LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS), + $ LDU1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, U2(1,POS), LDU2, Z, + $ LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS), + $ LDU2 ) + END IF +C +C Update V. +C + IF ( WANTV ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, V1(1,POS), LDV1, Q, + $ LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS), + $ LDV1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, V2(1,POS), LDV2, Q, + $ LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS), + $ LDV2 ) + END IF +C + HERE = HERE - 1 + ELSE +C +C Recompute NBNEXT in case 2-by-2 split. +C + IF ( A(HERE,HERE-1).EQ.ZERO ) + $ NBNEXT = 1 +C + IF ( NBNEXT.EQ.2 ) THEN +C +C 2-by-2 block did not split. +C + POS = HERE - 1 + NB = 3 + CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) + CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) +C + CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS), + $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, + $ LDQZ, IERR ) +C + IF ( IERR.NE.0 ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 1 + RETURN + END IF +C +C Update rest of A. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ POS-1, NB, NB, ONE, A(1,POS), + $ LDA, Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, + $ A(1,POS), LDA ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Q, LDQZ, + $ A(POS,POS+NB), LDA, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, + $ NB, A(POS,POS+NB), LDA ) + END IF +C +C Update rest of B. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ POS-1, NB, NB, ONE, B(1,POS), + $ LDB, Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, + $ B(1,POS), LDB ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Z, LDQZ, + $ B(POS,POS+NB), LDB, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, + $ NB, B(POS,POS+NB), LDB ) + END IF +C +C Update C. +C + IF ( WANTC ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, C(1,POS), LDC, Q, + $ LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ C(1,POS), LDC ) + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N, NB, ONE, Z, LDQZ, C(POS,1), + $ LDC, ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N, DWORK, NB, + $ C(POS,1), LDC ) + END IF +C +C Update U. +C + IF ( WANTU ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, U1(1,POS), LDU1, + $ Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ U1(1,POS), LDU1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, U2(1,POS), LDU2, + $ Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ U2(1,POS), LDU2 ) + END IF +C +C Update V. +C + IF ( WANTV ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, V1(1,POS), LDV1, + $ Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ V1(1,POS), LDV1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, V2(1,POS), LDV2, + $ Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ V2(1,POS), LDV2 ) + END IF +C + HERE = HERE - 2 + ELSE +C +C 2-by-2 block did split. +C + POS = HERE + NB = 2 + CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) + CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) +C + CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS), + $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, + $ LDQZ, IERR ) +C + IF ( IERR.NE.0 ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 1 + RETURN + END IF +C +C Update rest of A. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ POS-1, NB, NB, ONE, A(1,POS), + $ LDA, Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, + $ A(1,POS), LDA ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Q, LDQZ, + $ A(POS,POS+NB), LDA, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, + $ NB, A(POS,POS+NB), LDA ) + END IF +C +C Update rest of B. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ POS-1, NB, NB, ONE, B(1,POS), + $ LDB, Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, + $ B(1,POS), LDB ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Z, LDQZ, + $ B(POS,POS+NB), LDB, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, + $ NB, B(POS,POS+NB), LDB ) + END IF +C +C Update C. +C + IF ( WANTC ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, C(1,POS), LDC, Q, + $ LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ C(1,POS), LDC ) + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N, NB, ONE, Z, LDQZ, C(POS,1), + $ LDC, ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N, DWORK, NB, + $ C(POS,1), LDC ) + END IF +C +C Update U. +C + IF ( WANTU ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, U1(1,POS), LDU1, + $ Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ U1(1,POS), LDU1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, U2(1,POS), LDU2, + $ Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ U2(1,POS), LDU2 ) + END IF +C +C Update V. +C + IF ( WANTV ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, V1(1,POS), LDV1, + $ Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ V1(1,POS), LDV1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, V2(1,POS), LDV2, + $ Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ V2(1,POS), LDV2 ) + END IF +C + POS = HERE - 1 + NB = 2 + CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) + CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) +C + CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS), + $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, + $ LDQZ, IERR ) +C + IF ( IERR.NE.0 ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 1 + RETURN + END IF +C +C Update rest of A. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ POS-1, NB, NB, ONE, A(1,POS), + $ LDA, Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, + $ A(1,POS), LDA ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Q, LDQZ, + $ A(POS,POS+NB), LDA, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, + $ NB, A(POS,POS+NB), LDA ) + END IF +C +C Update rest of B. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ POS-1, NB, NB, ONE, B(1,POS), + $ LDB, Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, + $ B(1,POS), LDB ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Z, LDQZ, + $ B(POS,POS+NB), LDB, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, + $ NB, B(POS,POS+NB), LDB ) + END IF +C +C Update C. +C + IF ( WANTC ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, C(1,POS), LDC, Q, + $ LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ C(1,POS), LDC ) + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N, NB, ONE, Z, LDQZ, C(POS,1), + $ LDC, ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N, DWORK, NB, + $ C(POS,1), LDC ) + END IF +C +C Update U. +C + IF ( WANTU ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, U1(1,POS), LDU1, + $ Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ U1(1,POS), LDU1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, U2(1,POS), LDU2, + $ Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ U2(1,POS), LDU2 ) + END IF +C +C Update V. +C + IF ( WANTV ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, V1(1,POS), LDV1, + $ Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ V1(1,POS), LDV1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, V2(1,POS), LDV2, + $ Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ V2(1,POS), LDV2 ) + END IF +C + HERE = HERE - 2 + END IF + END IF + END IF +C + IF ( HERE.GT.ILST ) + $ GO TO 20 +C + 30 CONTINUE + IF ( PAIR ) + $ KS = KS + 1 + END IF + END IF + 40 CONTINUE +C + 50 CONTINUE +C +C Step 2: Compute an ordered Schur decomposition of +C [ 0, -A11; B11, 0 ]. +C + IF ( INITW ) + $ CALL DLASET( 'All', 2*M, 2*M, ZERO, ONE, W, LDW ) + PWC = 1 + PWD = PWC + 2*M + PW = PWD + 2*M + PAIR = .FALSE. + NB = 1 +C + DO 80 K = 1, M + IF ( PAIR ) THEN + PAIR = .FALSE. + NB = 1 + ELSE + IF ( K.LT.N ) THEN + IF ( A(K+1,K).NE.ZERO ) THEN + PAIR = .TRUE. + NB = 2 + END IF + END IF + PWCK = PWC + 2*( K - 1 ) + PWDL = PWD + 2*( K - 1 ) + CALL DLASET( 'All', NB, M-K+1, ZERO, ZERO, DWORK(PWCK), 2 ) + CALL DLACPY( 'All', NB, M-K+1, A(K,K), LDA, DWORK(PWDL), 2 ) + CALL DLASET( 'All', NB, M-K+1, ZERO, ZERO, A(K,K), LDA ) +C + L = K +C +C WHILE L >= 1 DO +C + 60 CONTINUE +C + IF ( K.EQ.L ) THEN +C +C Annihilate B(k,k). +C + NBL = NB + CALL DLASET( 'All', NB+NBL, NB+NBL, ZERO, ZERO, T, + $ LDQZ ) + CALL DLACPY( 'Upper', NBL, NBL, B(L,L), LDB, + $ T(NB+1,1), LDQZ ) + IF ( NB.EQ.1 ) THEN + DWORK(PWDL) = -DWORK(PWDL) + ELSE + CALL DSCAL( 2*NB, -ONE, DWORK(PWDL), 1 ) + END IF + CALL DLACPY( 'All', NB, NB, DWORK(PWDL), 2, T(1,NB+1), + $ LDQZ ) + ELSE +C +C Annihilate B(l,k). +C + CALL DLASET( 'All', NBL+NB, NBL+NB, ZERO, ZERO, T, + $ LDQZ ) + CALL DLACPY( 'All', NBL, NBL, A(L,L), LDA, T, LDQZ ) + CALL DLACPY( 'All', NBL, NB, B(L,K), LDB, T(1,NBL+1), + $ LDQZ ) + CALL DLACPY( 'All', NB, NB, DWORK(PWCK), 2, + $ T(NBL+1,NBL+1), LDQZ ) + PWDL = PWD + 2*( L - 1 ) + END IF +C + CALL DGEES( 'V', 'Not Sorted', LFDUM, NB+NBL, T, LDQZ, + $ MM, WRNEW, WINEW, Q, LDQZ, DW12, 12, LDUM, + $ IERR ) + IF ( IERR.NE.0 ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 3 + RETURN + END IF +C +C Reorder Schur form. +C + MM = 0 + DO 70 I = 1, NB+NBL + IF ( WRNEW(I).GT.0 ) THEN + MM = MM + 1 + SELNEW(I) = .TRUE. + ELSE + SELNEW(I) = .FALSE. + END IF + 70 CONTINUE + IF ( MM.LT.NB ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 4 + RETURN + END IF + CALL DTRSEN( 'None', 'V', SELNEW, NB+NBL, T, LDQZ, Q, + $ LDQZ, WRNEW, WINEW, MM, TEMP, TEMP, DW12, + $ 4, IDUM, 1, IERR ) + IF ( IERR.NE.0 ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 2 + RETURN + END IF +C +C Permute Q if necessary. +C + IF ( K.NE.L ) THEN + CALL DLACPY( 'All', NBL, NB+NBL, Q, LDQZ, Z(NB+1,1), + $ LDQZ ) + CALL DLACPY( 'All', NB, NB+NBL, Q(NBL+1,1), LDQZ, + $ Z, LDQZ ) + CALL DLACPY( 'All', NB+NBL, NB+NBL, Z, LDQZ, Q, LDQZ ) + END IF +C +C Update "diagonal" blocks. +C + CALL DLACPY( 'All', NB, NB, T, LDQZ, DWORK(PWCK), 2 ) + CALL DLACPY( 'All', NB, NBL, T(1,NB+1), LDQZ, + $ DWORK(PWDL), 2 ) + IF ( NB.EQ.1 ) THEN + CALL DSCAL( NBL, -ONE, DWORK(PWDL), 2 ) + ELSE + CALL DSCAL( 2*NBL, -ONE, DWORK(PWDL), 1 ) + END IF + CALL DLACPY( 'All', NBL, NBL, T(NB+1,NB+1), LDQZ, + $ A(L,L), LDA ) +C +C Update block columns of A and B. +C + LEN = L - 1 + IF ( LEN.GT.0 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, + $ NB, ONE, B(1,K), LDB, Q, LDQZ, ZERO, + $ DWORK(PW), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, + $ NB, ONE, B(1,K), LDB, Q(1,NB+1), LDQZ, + $ ZERO, DWORK(PW+2*M), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, + $ NBL, ONE, A(1,L), LDA, Q(NB+1,1), LDQZ, + $ ONE, DWORK(PW), M ) + CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, B(1,K), + $ LDB ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, + $ NBL, ONE, A(1,L), LDA, Q(NB+1,NB+1), + $ LDQZ, ONE, DWORK(PW+2*M), M ) + CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M, + $ A(1,L), LDA ) + END IF +C +C Update block column of A. +C + LEN = M - L - NBL + 1 + IF ( LEN.GT.0 ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NB, + $ ONE, Q, LDQZ, DWORK(PWDL+2*NBL), 2, ZERO, + $ DWORK(PW), 2 ) + CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, NB, + $ -ONE, Q(1,NB+1), LDQZ, DWORK(PWDL+2*NBL), + $ 2, ZERO, DWORK(PW+2*M), 2 ) + CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NBL, + $ -ONE, Q(NB+1,1), LDQZ, A(L,L+NBL), LDA, + $ ONE, DWORK(PW), 2 ) + CALL DLACPY( 'All', NB, LEN, DWORK(PW), 2, + $ DWORK(PWDL+2*NBL), 2 ) + CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, + $ NBL, ONE, Q(NB+1,NB+1), LDQZ, A(L,L+NBL), + $ LDA, ONE, DWORK(PW+2*M), 2 ) + CALL DLACPY( 'All', NBL, LEN, DWORK(PW+2*M), 2, + $ A(L,L+NBL), LDA ) + END IF +C +C Update block row of B. +C + LEN = M - K - NB + 1 + IF ( LEN.GT.0 ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NB, + $ ONE, Q, LDQZ, DWORK(PWCK+2*NB), 2, ZERO, + $ DWORK(PW), 2 ) + CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, NB, + $ ONE, Q(1,NB+1), LDQZ, DWORK(PWCK+2*NB), 2, + $ ZERO, DWORK(PW+2*M), 2 ) + CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NBL, + $ ONE, Q(NB+1,1), LDQZ, B(L,K+NB), LDB, ONE, + $ DWORK(PW), 2 ) + CALL DLACPY( 'All', NB, LEN, DWORK(PW), 2, + $ DWORK(PWCK+2*NB), 2 ) + CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, + $ NBL, ONE, Q(NB+1,NB+1), LDQZ, B(L,K+NB), + $ LDB, ONE, DWORK(PW+2*M), 2 ) + CALL DLACPY( 'All', NBL, LEN, DWORK(PW+2*M), 2, + $ B(L,K+NB), LDB ) + END IF +C +C Update W. +C + IF ( WANTW ) THEN + IF ( INITW ) THEN + POS = L + LEN = K + NB - L + ELSE + POS = 1 + LEN = M + END IF + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, + $ NB, ONE, W(POS,K), LDW, Q, LDQZ, ZERO, + $ DWORK(PW), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, + $ NB, ONE, W(POS,K), LDW, Q(1,NB+1), LDQZ, + $ ZERO, DWORK(PW+2*M), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, + $ NBL, ONE, W(POS,M+L), LDW, Q(NB+1,1), + $ LDQZ, ONE, DWORK(PW), M ) + CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, W(POS,K), + $ LDW ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, + $ NBL, ONE, W(POS,M+L), LDW, Q(NB+1,NB+1), + $ LDQZ, ONE, DWORK(PW+2*M), M ) + CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M, + $ W(POS,M+L), LDW ) +C + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, + $ NB, ONE, W(M+POS,K), LDW, Q, LDQZ, ZERO, + $ DWORK(PW), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, + $ NB, ONE, W(M+POS,K), LDW, Q(1,NB+1), LDQZ, + $ ZERO, DWORK(PW+2*M), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, + $ NBL, ONE, W(M+POS,M+L), LDW, Q(NB+1,1), + $ LDQZ, ONE, DWORK(PW), M ) + CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, W(M+POS,K), + $ LDW ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, + $ NBL, ONE, W(M+POS,M+L), LDW, Q(NB+1,NB+1), + $ LDQZ, ONE, DWORK(PW+2*M), M ) + CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M, + $ W(M+POS,M+L), LDW ) + END IF +C + L = L - 1 + NBL = 1 + IF ( L.GT.1 ) THEN + IF ( A(L,L-1).NE.ZERO ) THEN + NBL = 2 + L = L - 1 + END IF + END IF +C +C END WHILE L >= 1 DO +C + IF ( L.GE.1 ) + $ GO TO 60 +C +C Copy recomputed eigenvalues. +C + CALL DCOPY( NB, WRNEW, 1, WR(K), 1 ) + CALL DCOPY( NB, WINEW, 1, WI(K), 1 ) + END IF + 80 CONTINUE + DWORK(1) = DBLE( WRKMIN ) + RETURN +C *** Last line of MB03ZA *** + END +C + LOGICAL FUNCTION LFDUM( X, Y ) +C +C Void logical function for DGEES. +C + DOUBLE PRECISION X, Y + LFDUM = .FALSE. + RETURN +C *** Last line of LFDUM *** + END diff --git a/mex/sources/libslicot/MB03ZD.f b/mex/sources/libslicot/MB03ZD.f new file mode 100644 index 000000000..74e945525 --- /dev/null +++ b/mex/sources/libslicot/MB03ZD.f @@ -0,0 +1,908 @@ + SUBROUTINE MB03ZD( WHICH, METH, STAB, BALANC, ORTBAL, SELECT, N, + $ MM, ILO, SCALE, S, LDS, T, LDT, G, LDG, U1, + $ LDU1, U2, LDU2, V1, LDV1, V2, LDV2, M, WR, WI, + $ US, LDUS, UU, LDUU, LWORK, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the stable and unstable invariant subspaces for a +C Hamiltonian matrix with no eigenvalues on the imaginary axis, +C using the output of the SLICOT Library routine MB03XD. +C +C ARGUMENTS +C +C Mode Parameters +C +C WHICH CHARACTER*1 +C Specifies the cluster of eigenvalues for which the +C invariant subspaces are computed: +C = 'A': select all n eigenvalues; +C = 'S': select a cluster of eigenvalues specified by +C SELECT. +C +C METH CHARACTER*1 +C If WHICH = 'A' this parameter specifies the method to be +C used for computing bases of the invariant subspaces: +C = 'S': compute the n-dimensional basis from a set of +C n vectors; +C = 'L': compute the n-dimensional basis from a set of +C 2*n vectors. +C When in doubt, use METH = 'S'. In some cases, METH = 'L' +C may result in more accurately computed invariant +C subspaces, see [1]. +C +C STAB CHARACTER*1 +C Specifies the type of invariant subspaces to be computed: +C = 'S': compute the stable invariant subspace, i.e., the +C invariant subspace belonging to those selected +C eigenvalues that have negative real part; +C = 'U': compute the unstable invariant subspace, i.e., +C the invariant subspace belonging to those +C selected eigenvalues that have positive real +C part; +C = 'B': compute both the stable and unstable invariant +C subspaces. +C +C BALANC CHARACTER*1 +C Specifies the type of inverse balancing transformation +C required: +C = 'N': do nothing; +C = 'P': do inverse transformation for permutation only; +C = 'S': do inverse transformation for scaling only; +C = 'B': do inverse transformations for both permutation +C and scaling. +C BALANC must be the same as the argument BALANC supplied to +C MB03XD. Note that if the data is further post-processed, +C e.g., for solving an algebraic Riccati equation, it is +C recommended to delay inverse balancing (in particular the +C scaling part) and apply it to the final result only, +C see [2]. +C +C ORTBAL CHARACTER*1 +C If BALANC <> 'N', this option specifies how inverse +C balancing is applied to the computed invariant subspaces: +C = 'B': apply inverse balancing before orthogonal bases +C for the invariant subspaces are computed; +C = 'A': apply inverse balancing after orthogonal bases +C for the invariant subspaces have been computed; +C this may yield non-orthogonal bases if +C BALANC = 'S' or BALANC = 'B'. +C +C SELECT (input) LOGICAL array, dimension (N) +C If WHICH = 'S', SELECT specifies the eigenvalues +C corresponding to the positive and negative square +C roots of the eigenvalues of S*T in the selected cluster. +C To select a real eigenvalue w(j), SELECT(j) must be set +C to .TRUE.. To select a complex conjugate pair of +C eigenvalues w(j) and w(j+1), corresponding to a 2-by-2 +C diagonal block, both SELECT(j) and SELECT(j+1) must be set +C to .TRUE.; a complex conjugate pair of eigenvalues must be +C either both included in the cluster or both excluded. +C This array is not referenced if WHICH = 'A'. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices S, T and G. N >= 0. +C +C MM (input) INTEGER +C The number of columns in the arrays US and/or UU. +C If WHICH = 'A' and METH = 'S', MM >= N; +C if WHICH = 'A' and METH = 'L', MM >= 2*N; +C if WHICH = 'S', MM >= M. +C The minimal values above for MM give the numbers of +C vectors to be used for computing a basis for the +C invariant subspace(s). +C +C ILO (input) INTEGER +C If BALANC <> 'N', then ILO is the integer returned by +C MB03XD. 1 <= ILO <= N+1. +C +C SCALE (input) DOUBLE PRECISION array, dimension (N) +C If BALANC <> 'N', the leading N elements of this array +C must contain details of the permutation and scaling +C factors, as returned by MB03XD. +C This array is not referenced if BALANC = 'N'. +C +C S (input/output) DOUBLE PRECISION array, dimension (LDS,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix S in real Schur form. +C On exit, the leading N-by-N part of this array is +C overwritten. +C +C LDS INTEGER +C The leading dimension of the array S. LDS >= max(1,N). +C +C T (input/output) DOUBLE PRECISION array, dimension (LDT,N) +C On entry, the leading N-by-N part of this array must +C contain the upper triangular matrix T. +C On exit, the leading N-by-N part of this array is +C overwritten. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= max(1,N). +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) +C On entry, if METH = 'L', the leading N-by-N part of this +C array must contain a general matrix G. +C On exit, if METH = 'L', the leading N-by-N part of this +C array is overwritten. +C This array is not referenced if METH = 'S'. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= 1. +C LDG >= max(1,N) if METH = 'L'. +C +C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) +C On entry, the leading N-by-N part of this array must +C contain the (1,1) block of an orthogonal symplectic +C matrix U. +C On exit, this array is overwritten. +C +C LDU1 INTEGER +C The leading dimension of the array U1. LDU1 >= MAX(1,N). +C +C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) +C On entry, the leading N-by-N part of this array must +C contain the (2,1) block of an orthogonal symplectic +C matrix U. +C On exit, this array is overwritten. +C +C LDU2 INTEGER +C The leading dimension of the array U2. LDU2 >= MAX(1,N). +C +C V1 (input/output) DOUBLE PRECISION array, dimension (LDV1,N) +C On entry, the leading N-by-N part of this array must +C contain the (1,1) block of an orthogonal symplectic +C matrix V. +C On exit, this array is overwritten. +C +C LDV1 INTEGER +C The leading dimension of the array V1. LDV1 >= MAX(1,N). +C +C V2 (input/output) DOUBLE PRECISION array, dimension (LDV1,N) +C On entry, the leading N-by-N part of this array must +C contain the (2,1) block of an orthogonal symplectic +C matrix V. +C On exit, this array is overwritten. +C +C LDV2 INTEGER +C The leading dimension of the array V2. LDV2 >= MAX(1,N). +C +C M (output) INTEGER +C The number of selected eigenvalues. +C +C WR (output) DOUBLE PRECISION array, dimension (M) +C WI (output) DOUBLE PRECISION array, dimension (M) +C On exit, the leading M elements of WR and WI contain the +C real and imaginary parts, respectively, of the selected +C eigenvalues that have nonpositive real part. Complex +C conjugate pairs of eigenvalues with real part not equal +C to zero will appear consecutively with the eigenvalue +C having the positive imaginary part first. Note that, due +C to roundoff errors, these numbers may differ from the +C eigenvalues computed by MB03XD. +C +C US (output) DOUBLE PRECISION array, dimension (LDUS,MM) +C On exit, if STAB = 'S' or STAB = 'B', the leading 2*N-by-M +C part of this array contains a basis for the stable +C invariant subspace belonging to the selected eigenvalues. +C This basis is orthogonal unless ORTBAL = 'A'. +C +C LDUS INTEGER +C The leading dimension of the array US. LDUS >= 1. +C If STAB = 'S' or STAB = 'B', LDUS >= 2*N. +C +C UU (output) DOUBLE PRECISION array, dimension (LDUU,MM) +C On exit, if STAB = 'U' or STAB = 'B', the leading 2*N-by-M +C part of this array contains a basis for the unstable +C invariant subspace belonging to the selected eigenvalues. +C This basis is orthogonal unless ORTBAL = 'A'. +C +C LDUU INTEGER +C The leading dimension of the array UU. LDUU >= 1. +C If STAB = 'U' or STAB = 'B', LDUU >= 2*N. +C +C Workspace +C +C LWORK LOGICAL array, dimension (2*N) +C This array is only referenced if WHICH = 'A' and +C METH = 'L'. +C +C IWORK INTEGER array, dimension (2*N), +C This array is only referenced if WHICH = 'A' and +C METH = 'L'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -35, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C If WHICH = 'S' or METH = 'S': +C LDWORK >= MAX( 1, 4*M*M + MAX( 8*M, 4*N ) ). +C If WHICH = 'A' and METH = 'L' and +C ( STAB = 'U' or STAB = 'S' ): +C LDWORK >= MAX( 1, 2*N*N + 2*N, 8*N ). +C If WHICH = 'A' and METH = 'L' and STAB = 'B': +C LDWORK >= 8*N + 1. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: some of the selected eigenvalues are on or too close +C to the imaginary axis; +C = 2: reordering of the product S*T in routine MB03ZA +C failed because some eigenvalues are too close to +C separate; +C = 3: the QR algorithm failed to compute some Schur form +C in MB03ZA; +C = 4: reordering of the Hamiltonian Schur form in routine +C MB03TD failed because some eigenvalues are too close +C to separate. +C +C METHOD +C +C This is an implementation of Algorithm 1 in [1]. +C +C NUMERICAL ASPECTS +C +C The method is strongly backward stable for an embedded +C (skew-)Hamiltonian matrix, see [1]. Although good results have +C been reported if the eigenvalues are not too close to the +C imaginary axis, the method is not backward stable for the original +C Hamiltonian matrix itself. +C +C REFERENCES +C +C [1] Benner, P., Mehrmann, V., and Xu, H. +C A new method for computing the stable invariant subspace of a +C real Hamiltonian matrix, J. Comput. Appl. Math., 86, +C pp. 17-43, 1997. +C +C [2] Benner, P. +C Symplectic balancing of Hamiltonian matrices. +C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DHASUB). +C +C KEYWORDS +C +C Hamiltonian matrix, invariant subspace. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER BALANC, METH, ORTBAL, STAB, WHICH + INTEGER ILO, INFO, LDG, LDS, LDT, LDU1, LDU2, LDUS, + $ LDUU, LDV1, LDV2, LDWORK, M, MM, N +C .. Array Arguments .. + LOGICAL LWORK(*), SELECT(*) + INTEGER IWORK(*) + DOUBLE PRECISION DWORK(*), G(LDG,*), S(LDS,*), SCALE(*), + $ T(LDT,*), U1(LDU1,*), U2(LDU2,*), US(LDUS,*), + $ UU(LDUU,*), V1(LDV1,*), V2(LDV2,*), WI(*), + $ WR(*) +C .. Local Scalars .. + LOGICAL LALL, LBAL, LBEF, LEXT, LUS, LUU, PAIR + INTEGER I, IERR, J, K, PDW, PW, WRKMIN, WRKOPT + DOUBLE PRECISION TEMP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DGEMM, DGEQP3, DGEQRF, DLACPY, DLASCL, + $ DLASET, DORGQR, DSCAL, MB01UX, MB03TD, MB03ZA, + $ MB04DI, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode and check input parameters. +C + LALL = LSAME( WHICH, 'A' ) + IF ( LALL ) THEN + LEXT = LSAME( METH, 'L' ) + ELSE + LEXT = .FALSE. + END IF + LUS = LSAME( STAB, 'S' ) .OR. LSAME( STAB, 'B' ) + LUU = LSAME( STAB, 'U' ) .OR. LSAME( STAB, 'B' ) + LBAL = LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'S' ) .OR. + $ LSAME( BALANC, 'B' ) + LBEF = .FALSE. + IF ( LBAL ) + $ LBEF = LSAME( ORTBAL, 'B' ) +C + WRKMIN = 1 + WRKOPT = WRKMIN +C + INFO = 0 +C + IF ( .NOT.LALL .AND. .NOT.LSAME( WHICH, 'S' ) ) THEN + INFO = -1 + ELSE IF ( LALL .AND. ( .NOT.LEXT .AND. + $ .NOT.LSAME( METH, 'S' ) ) ) THEN + INFO = -2 + ELSE IF ( .NOT.LUS .AND. .NOT.LUU ) THEN + INFO = -3 + ELSE IF ( .NOT.LBAL .AND. .NOT.LSAME( BALANC, 'N' ) ) THEN + INFO = -4 + ELSE IF ( LBAL .AND. ( .NOT.LBEF .AND. + $ .NOT.LSAME( ORTBAL, 'A' ) ) ) THEN + INFO = -5 + ELSE + IF ( LALL ) THEN + M = N + ELSE +C +C Set M to the dimension of the specified invariant subspace. +C + M = 0 + PAIR = .FALSE. + DO 10 K = 1, N + IF ( PAIR ) THEN + PAIR = .FALSE. + ELSE + IF ( K.LT.N ) THEN + IF ( S(K+1,K).EQ.ZERO ) THEN + IF ( SELECT(K) ) + $ M = M + 1 + ELSE + PAIR = .TRUE. + IF ( SELECT(K) .OR. SELECT(K+1) ) + $ M = M + 2 + END IF + ELSE + IF ( SELECT(N) ) + $ M = M + 1 + END IF + END IF + 10 CONTINUE + END IF +C +C Compute workspace requirements. +C + IF ( .NOT.LEXT ) THEN + WRKOPT = MAX( WRKOPT, 4*M*M + MAX( 8*M, 4*N ) ) + ELSE + IF ( LUS.AND.LUU ) THEN + WRKOPT = MAX( WRKOPT, 8*N + 1 ) + ELSE + WRKOPT = MAX( WRKOPT, 2*N*N + 2*N, 8*N ) + END IF + END IF +C + IF ( N.LT.0 ) THEN + INFO = -7 + ELSE IF ( MM.LT.M .OR. ( LEXT .AND. MM.LT.2*N ) ) THEN + INFO = -8 + ELSE IF ( LBAL .AND. ( ILO.LT.1 .OR. ILO.GT.N+1 ) ) THEN + INFO = -9 + ELSE IF ( LDS.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF ( LDT.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF ( LDG.LT.1 .OR. ( LEXT .AND. LDG.LT.N ) ) THEN + INFO = -16 + ELSE IF ( LDU1.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF ( LDU2.LT.MAX( 1, N ) ) THEN + INFO = -20 + ELSE IF ( LDV1.LT.MAX( 1, N ) ) THEN + INFO = -22 + ELSE IF ( LDV2.LT.MAX( 1, N ) ) THEN + INFO = -24 + ELSE IF ( LDUS.LT.1 .OR. ( LUS .AND. LDUS.LT.2*N ) ) THEN + INFO = -29 + ELSE IF ( LDUU.LT.1 .OR. ( LUU .AND. LDUU.LT.2*N ) ) THEN + INFO = -31 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + INFO = -35 + DWORK(1) = DBLE( WRKMIN ) + END IF + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03ZD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( M, N ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF + WRKOPT = WRKMIN +C + IF ( .NOT.LEXT ) THEN +C +C Workspace requirements: 4*M*M + MAX( 8*M, 4*N ). +C + PW = 1 + PDW = PW + 4*M*M + CALL MB03ZA( 'No Update', 'Update', 'Update', 'Init', WHICH, + $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, U2, + $ LDU2, V1, LDV1, V2, LDV2, DWORK(PW), 2*M, WR, WI, + $ M, DWORK(PDW), LDWORK-PDW+1, IERR ) + IF ( IERR.NE.0 ) + $ GO TO 250 +C + PDW = PW + 2*M*M + CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, ONE, + $ DWORK(PW), 2*M, V1, LDV1, DWORK(PDW), + $ LDWORK-PDW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) +C + IF ( LUS ) + $ CALL DLACPY( 'All', N, M, V1, LDV1, US, LDUS ) + IF ( LUU ) + $ CALL DLACPY( 'All', N, M, V1, LDV1, UU, LDUU ) +C + CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, ONE, + $ DWORK(PW+M), 2*M, U1, LDU1, DWORK(PDW), + $ LDWORK-PDW+1, IERR ) +C + IF ( LUS ) THEN + DO 20 J = 1, M + CALL DAXPY( N, -ONE, U1(1,J), 1, US(1,J), 1 ) + 20 CONTINUE + END IF + IF ( LUU ) THEN + DO 30 J = 1, M + CALL DAXPY( N, ONE, U1(1,J), 1, UU(1,J), 1 ) + 30 CONTINUE + END IF +C + CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, -ONE, + $ DWORK(PW), 2*M, V2, LDV2, DWORK(PDW), + $ LDWORK-PDW+1, IERR ) +C + IF ( LUS ) + $ CALL DLACPY( 'All', N, M, V2, LDV2, US(N+1,1), LDUS ) + IF ( LUU ) + $ CALL DLACPY( 'All', N, M, V2, LDV2, UU(N+1,1), LDUU ) +C + CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, ONE, + $ DWORK(PW+M), 2*M, U2, LDU2, DWORK(PDW), + $ LDWORK-PDW+1, IERR ) +C + IF ( LUS ) THEN + DO 40 J = 1, M + CALL DAXPY( N, ONE, U2(1,J), 1, US(N+1,J), 1 ) + 40 CONTINUE + END IF + IF ( LUU ) THEN + DO 50 J = 1, M + CALL DAXPY( N, -ONE, U2(1,J), 1, UU(N+1,J), 1 ) + 50 CONTINUE + END IF +C +C Orthonormalize obtained bases and apply inverse balancing +C transformation. +C + IF ( LBAL .AND. LBEF ) THEN + IF ( LUS ) + $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, US, + $ LDUS, US(N+1,1), LDUS, IERR ) + IF ( LUU ) + $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, UU, + $ LDUU, UU(N+1,1), LDUU, IERR ) + END IF +C + IF ( LUS ) THEN + CALL DGEQRF( 2*N, M, US, LDUS, DWORK(1), DWORK(M+1), + $ LDWORK-M, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) + CALL DORGQR( 2*N, M, M, US, LDUS, DWORK(1), DWORK(M+1), + $ LDWORK-M, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) + END IF + IF ( LUU ) THEN + CALL DGEQRF( 2*N, M, UU, LDUU, DWORK(1), DWORK(M+1), + $ LDWORK-M, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) + CALL DORGQR( 2*N, M, M, UU, LDUU, DWORK(1), DWORK(M+1), + $ LDWORK-M, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) + END IF +C + IF ( LBAL .AND. .NOT.LBEF ) THEN + IF ( LUS ) + $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, US, + $ LDUS, US(N+1,1), LDUS, IERR ) + IF ( LUU ) + $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, UU, + $ LDUU, UU(N+1,1), LDUU, IERR ) + END IF +C + ELSE +C + DO 60 I = 1, 2*N + LWORK(I) = .TRUE. + 60 CONTINUE +C + IF ( LUS .AND.( .NOT.LUU ) ) THEN +C +C Workspace requirements: MAX( 2*N*N + 2*N, 8*N ) +C + CALL MB03ZA( 'Update', 'Update', 'Update', 'Init', WHICH, + $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, + $ U2, LDU2, V1, LDV1, V2, LDV2, US, LDUS, WR, + $ WI, M, DWORK, LDWORK, IERR ) + IF ( IERR.NE.0 ) + $ GO TO 250 +C + CALL MB01UX( 'Left', 'Lower', 'Transpose', N, N, ONE, + $ US(N+1,N+1), LDUS, G, LDG, DWORK, LDWORK, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(1,N+1), LDUS, G, LDG, DWORK, LDWORK, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C + DO 70 J = 1, N + CALL DAXPY( J, ONE, G(J,1), LDG, G(1,J), 1 ) + 70 CONTINUE + PDW = 2*N*N+1 +C +C DW <- -[V1;V2]*W11 +C + CALL DLACPY( 'All', N, N, V1, LDV1, DWORK, 2*N ) + CALL DLACPY( 'All', N, N, V2, LDV2, DWORK(N+1), 2*N ) + CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, -ONE, + $ US, LDUS, DWORK, 2*N, DWORK(PDW), LDWORK-PDW+1, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) +C +C DW2 <- DW2 - U2*W21 +C + CALL DLACPY( 'All', N, N, U2, LDU2, US, LDUS ) + CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, ONE, + $ US(N+1,1), LDUS, US, LDUS, DWORK(PDW), + $ LDWORK-PDW+1, IERR ) + DO 80 J = 1, N + CALL DAXPY( N, ONE, US(1,J), 1, DWORK(N+2*(J-1)*N+1), 1 ) + 80 CONTINUE +C +C US11 <- -U1*W21 - DW1 +C + CALL DLACPY( 'All', N, N, U1, LDU1, US, LDUS ) + CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, -ONE, + $ US(N+1,1), LDUS, US, LDUS, DWORK(PDW), + $ LDWORK-PDW+1, IERR ) + DO 90 J = 1, N + CALL DAXPY( N, -ONE, DWORK(2*(J-1)*N+1), 1, US(1,J), 1 ) + 90 CONTINUE +C +C US21 <- DW2 +C + CALL DLACPY( 'All', N, N, DWORK(N+1), 2*N, US(N+1,1), LDUS ) +C + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(1,N+1), LDUS, V1, LDV1, DWORK, LDWORK, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(1,N+1), LDUS, V2, LDV2, DWORK, LDWORK, + $ IERR ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(N+1,N+1), LDUS, U1, LDU1, DWORK, LDWORK, + $ IERR ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(N+1,N+1), LDUS, U2, LDU2, DWORK, LDWORK, + $ IERR ) + CALL DLACPY( 'All', N, N, V1, LDV1, US(1,N+1), LDUS ) + CALL DLACPY( 'All', N, N, V2, LDV2, US(N+1,N+1), LDUS ) + DO 100 J = 1, N + CALL DAXPY( N, -ONE, U1(1,J), 1, US(1,N+J), 1 ) + 100 CONTINUE + DO 110 J = 1, N + CALL DAXPY( N, -ONE, U2(1,J), 1, US(N+1,N+J), 1 ) + 110 CONTINUE +C + CALL MB03TD( 'Hamiltonian', 'Update', LWORK, LWORK(N+1), N, + $ S, LDS, G, LDG, US(1,N+1), LDUS, US(N+1,N+1), + $ LDUS, WR, WI, M, DWORK, LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, N, US(N+1,N+1), + $ LDUS, IERR ) +C + ELSE IF ( ( .NOT.LUS ).AND.LUU ) THEN +C +C Workspace requirements: MAX( 2*N*N + 2*N, 8*N ) +C + CALL MB03ZA( 'Update', 'Update', 'Update', 'Init', WHICH, + $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, + $ U2, LDU2, V1, LDV1, V2, LDV2, UU, LDUU, WR, + $ WI, M, DWORK, LDWORK, IERR ) + IF ( IERR.NE.0 ) + $ GO TO 250 + CALL MB01UX( 'Left', 'Lower', 'Transpose', N, N, ONE, + $ UU(N+1,N+1), LDUU, G, LDG, DWORK, LDWORK, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ UU(1,N+1), LDUU, G, LDG, DWORK, LDWORK, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + DO 120 J = 1, N + CALL DAXPY( J, ONE, G(J,1), LDG, G(1,J), 1 ) + 120 CONTINUE + PDW = 2*N*N+1 +C +C DW <- -[V1;V2]*W11 +C + CALL DLACPY( 'All', N, N, V1, LDV1, DWORK, 2*N ) + CALL DLACPY( 'All', N, N, V2, LDV2, DWORK(N+1), 2*N ) + CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, -ONE, + $ UU, LDUU, DWORK, 2*N, DWORK(PDW), LDWORK-PDW+1, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) +C +C DW2 <- DW2 - U2*W21 +C + CALL DLACPY( 'All', N, N, U2, LDU2, UU, LDUU ) + CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, -ONE, + $ UU(N+1,1), LDUU, UU, LDUU, DWORK(PDW), + $ LDWORK-PDW+1, IERR ) + DO 130 J = 1, N + CALL DAXPY( N, ONE, UU(1,J), 1, DWORK(N+2*(J-1)*N+1), 1 ) + 130 CONTINUE +C +C UU11 <- U1*W21 - DW1 +C + CALL DLACPY( 'All', N, N, U1, LDU1, UU, LDUU ) + CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, ONE, + $ UU(N+1,1), LDUU, UU, LDUU, DWORK(PDW), + $ LDWORK-PDW+1, IERR ) + DO 140 J = 1, N + CALL DAXPY( N, -ONE, DWORK(2*(J-1)*N+1), 1, UU(1,J), 1 ) + 140 CONTINUE +C +C UU21 <- DW2 +C + CALL DLACPY( 'All', N, N, DWORK(N+1), 2*N, UU(N+1,1), LDUU ) +C + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ UU(1,N+1), LDUU, V1, LDV1, DWORK, LDWORK, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ UU(1,N+1), LDUU, V2, LDV2, DWORK, LDWORK, + $ IERR ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ UU(N+1,N+1), LDUU, U1, LDU1, DWORK, LDWORK, + $ IERR ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ UU(N+1,N+1), LDUU, U2, LDU2, DWORK, LDWORK, + $ IERR ) + CALL DLACPY( 'All', N, N, V1, LDV1, UU(1,N+1), LDUU ) + CALL DLACPY( 'All', N, N, V2, LDV2, UU(N+1,N+1), LDUU ) + DO 150 J = 1, N + CALL DAXPY( N, ONE, U1(1,J), 1, UU(1,N+J), 1 ) + 150 CONTINUE + DO 160 J = 1, N + CALL DAXPY( N, ONE, U2(1,J), 1, UU(N+1,N+J), 1 ) + 160 CONTINUE +C + CALL MB03TD( 'Hamiltonian', 'Update', LWORK, LWORK(N+1), N, + $ S, LDS, G, LDG, UU(1,N+1), LDUU, UU(N+1,N+1), + $ LDUU, WR, WI, M, DWORK, LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, N, UU(N+1,N+1), + $ LDUU, IERR ) + ELSE +C +C Workspace requirements: 8*N +C + CALL MB03ZA( 'Update', 'Update', 'Update', 'Init', WHICH, + $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, + $ U2, LDU2, V1, LDV1, V2, LDV2, US, LDUS, WR, + $ WI, M, DWORK, LDWORK, IERR ) + IF ( IERR.NE.0 ) + $ GO TO 250 + CALL MB01UX( 'Left', 'Lower', 'Transpose', N, N, ONE, + $ US(N+1,N+1), LDUS, G, LDG, DWORK, LDWORK, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(1,N+1), LDUS, G, LDG, DWORK, LDWORK, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + DO 170 J = 1, N + CALL DAXPY( J, ONE, G(J,1), LDG, G(1,J), 1 ) + 170 CONTINUE +C +C UU = [ V1 -V2; U1 -U2 ]*diag(W11,W21) +C + CALL DLACPY( 'All', N, N, V1, LDV1, UU, LDUU ) + CALL DLACPY( 'All', N, N, V2, LDV2, UU(N+1,1), LDUU ) + CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, ONE, + $ US, LDUS, UU, LDUU, DWORK, LDWORK, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + CALL DLACPY( 'All', N, N, U1, LDU1, UU(1,N+1), LDUU ) + CALL DLACPY( 'All', N, N, U2, LDU2, UU(N+1,N+1), LDUU ) + CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, ONE, + $ US(N+1,1), LDUS, UU(1,N+1), LDUU, DWORK, + $ LDWORK, IERR ) + CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, 2*N, UU(N+1,1), + $ LDUU, IERR ) +C + CALL DLACPY( 'All', 2*N, N, UU, LDUU, US, LDUS ) + DO 180 J = 1, N + CALL DAXPY( 2*N, -ONE, UU(1,N+J), 1, US(1,J), 1 ) + 180 CONTINUE + DO 190 J = 1, N + CALL DAXPY( 2*N, ONE, UU(1,N+J), 1, UU(1,J), 1 ) + 190 CONTINUE +C +C V1 <- V1*W12-U1*W22 +C U1 <- V1*W12+U1*W22 +C V2 <- V2*W12-U2*W22 +C U2 <- V2*W12+U2*W22 +C + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(1,N+1), LDUS, V1, LDV1, DWORK, LDWORK, + $ IERR ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(1,N+1), LDUS, V2, LDV2, DWORK, LDWORK, + $ IERR ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(N+1,N+1), LDUS, U1, LDU1, DWORK, LDWORK, + $ IERR ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(N+1,N+1), LDUS, U2, LDU2, DWORK, LDWORK, + $ IERR ) + DO 210 J = 1, N + DO 200 I = 1, N + TEMP = V1(I,J) + V1(I,J) = TEMP - U1(I,J) + U1(I,J) = TEMP + U1(I,J) + 200 CONTINUE + 210 CONTINUE + DO 230 J = 1, N + DO 220 I = 1, N + TEMP = V2(I,J) + V2(I,J) = TEMP - U2(I,J) + U2(I,J) = TEMP + U2(I,J) + 220 CONTINUE + 230 CONTINUE +C + CALL DLASET( 'All', 2*N, N, ZERO, ONE, US(1,N+1), LDUS ) + CALL MB03TD( 'Hamiltonian', 'Update', LWORK, LWORK(N+1), N, + $ S, LDS, G, LDG, US(1,N+1), LDUS, US(N+1,N+1), + $ LDUS, WR, WI, M, DWORK, LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, + $ U1, LDU1, US(1,N+1), LDUS, ZERO, UU(1,N+1), + $ LDUU ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, + $ U2, LDU2, US(N+1,N+1), LDUS, ONE, UU(1,N+1), + $ LDUU ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, + $ U1, LDU1, US(N+1,N+1), LDUS, ZERO, UU(N+1,N+1), + $ LDUU ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, + $ U2, LDU2, US(1,N+1), LDUS, ONE, UU(N+1,N+1), + $ LDUU ) + CALL DLACPY( 'All', N, N, US(1,N+1), LDUS, U1, LDU1 ) + CALL DLACPY( 'All', N, N, US(N+1,N+1), LDUS, U2, LDU2 ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, + $ V1, LDV1, U1, LDU1, ZERO, US(1,N+1), LDUS ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, + $ V2, LDV2, U2, LDU2, ONE, US(1,N+1), LDUS ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, + $ V1, LDV1, U2, LDU2, ZERO, US(N+1,N+1), LDUS ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, + $ V2, LDV2, U1, LDU1, ONE, US(N+1,N+1), LDUS ) + END IF +C +C Orthonormalize obtained bases and apply inverse balancing +C transformation. +C + IF ( LBAL .AND. LBEF ) THEN + IF ( LUS ) + $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, US, + $ LDUS, US(N+1,1), LDUS, IERR ) + IF ( LUU ) + $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, UU, + $ LDUU, UU(N+1,1), LDUU, IERR ) + END IF +C +C Workspace requirements: 8*N+1 +C + DO 240 J = 1, 2*N + IWORK(J) = 0 + 240 CONTINUE + IF ( LUS ) THEN + CALL DGEQP3( 2*N, 2*N, US, LDUS, IWORK, DWORK, DWORK(2*N+1), + $ LDWORK-2*N, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) + CALL DORGQR( 2*N, 2*N, N, US, LDUS, DWORK, DWORK(2*N+1), + $ LDWORK-2*N, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) + END IF + IF ( LUU ) THEN + CALL DGEQP3( 2*N, 2*N, UU, LDUU, IWORK, DWORK, DWORK(2*N+1), + $ LDWORK-2*N, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) + CALL DORGQR( 2*N, 2*N, N, UU, LDUU, DWORK, DWORK(2*N+1), + $ LDWORK-2*N, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) + END IF +C + IF ( LBAL .AND. .NOT.LBEF ) THEN + IF ( LUS ) + $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, US, + $ LDUS, US(N+1,1), LDUS, IERR ) + IF ( LUU ) + $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, UU, + $ LDUU, UU(N+1,1), LDUU, IERR ) + END IF + END IF +C + CALL DSCAL( M, -ONE, WR, 1 ) + DWORK(1) = DBLE( WRKOPT ) +C + RETURN + 250 CONTINUE + IF ( IERR.EQ.1 ) THEN + INFO = 2 + ELSE IF ( IERR.EQ.2 .OR. IERR.EQ.4 ) THEN + INFO = 1 + ELSE IF ( IERR.EQ.3 ) THEN + INFO = 3 + END IF + RETURN +C *** Last line of MB03ZD *** + END diff --git a/mex/sources/libslicot/MB04DD.f b/mex/sources/libslicot/MB04DD.f new file mode 100644 index 000000000..857bceef0 --- /dev/null +++ b/mex/sources/libslicot/MB04DD.f @@ -0,0 +1,440 @@ + SUBROUTINE MB04DD( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To balance a real Hamiltonian matrix, +C +C [ A G ] +C H = [ T ] , +C [ Q -A ] +C +C where A is an N-by-N matrix and G, Q are N-by-N symmetric +C matrices. This involves, first, permuting H by a symplectic +C similarity transformation to isolate eigenvalues in the first +C 1:ILO-1 elements on the diagonal of A; and second, applying a +C diagonal similarity transformation to rows and columns +C ILO:2*N-ILO+1 to make the rows and columns as close in 1-norm +C as possible. Both steps are optional. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the operations to be performed on H: +C = 'N': none, set ILO = 1, SCALE(I) = 1.0, I = 1 .. N; +C = 'P': permute only; +C = 'S': scale only; +C = 'B': both permute and scale. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, the leading N-by-N part of this array contains +C the matrix A of the balanced Hamiltonian. In particular, +C the lower triangular part of the first ILO-1 columns of A +C is zero. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C QG (input/output) DOUBLE PRECISION array, dimension +C (LDQG,N+1) +C On entry, the leading N-by-N+1 part of this array must +C contain the lower triangular part of the matrix Q and +C the upper triangular part of the matrix G. +C On exit, the leading N-by-N+1 part of this array contains +C the lower and upper triangular parts of the matrices Q and +C G, respectively, of the balanced Hamiltonian. In +C particular, the lower triangular and diagonal part of the +C first ILO-1 columns of QG is zero. +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= MAX(1,N). +C +C ILO (output) INTEGER +C ILO-1 is the number of deflated eigenvalues in the +C balanced Hamiltonian matrix. +C +C SCALE (output) DOUBLE PRECISION array of dimension (N) +C Details of the permutations and scaling factors applied to +C H. For j = 1,...,ILO-1 let P(j) = SCALE(j). If P(j) <= N, +C then rows and columns P(j) and P(j)+N are interchanged +C with rows and columns j and j+N, respectively. If +C P(j) > N, then row and column P(j)-N are interchanged with +C row and column j+N by a generalized symplectic +C permutation. For j = ILO,...,N the j-th element of SCALE +C contains the factor of the scaling applied to row and +C column j. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Benner, P. +C Symplectic balancing of Hamiltonian matrices. +C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DHABAL). +C +C KEYWORDS +C +C Balancing, Hamiltonian matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER ILO, INFO, LDA, LDQG, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), QG(LDQG,*), SCALE(*) +C .. Local Scalars .. + LOGICAL CONV, LPERM, LSCAL + INTEGER I, IC, ILOOLD, J + DOUBLE PRECISION C, F, GII, MAXC, MAXR, QII, R, SCLFAC, + $ SFMAX1, SFMAX2, SFMIN1, SFMIN2, TEMP +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DASUM, DLAMCH + EXTERNAL DASUM, DLAMCH, IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DRSCL, DSCAL, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) + LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) +C + IF ( .NOT.LPERM .AND. .NOT.LSCAL + $ .AND. .NOT.LSAME( JOB, 'N' ) ) THEN + INFO = -1 + ELSE IF ( N.LT.0 ) THEN + INFO = -2 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF +C +C Return if there were illegal values. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04DD', -INFO ) + RETURN + END IF +C + ILO = 1 +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN + IF ( .NOT.LPERM .AND. .NOT.LSCAL ) THEN + DO 10 I = 1, N + SCALE(I) = ONE + 10 CONTINUE + RETURN + END IF +C +C Permutations to isolate eigenvalues if possible. +C + IF ( LPERM ) THEN + ILOOLD = 0 +C WHILE ( ILO.NE.ILOOLD ) + 20 IF ( ILO.NE.ILOOLD ) THEN + ILOOLD = ILO +C +C Scan columns ILO .. N. +C + I = ILO +C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) + 30 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN + DO 40 J = ILO, I-1 + IF ( A(J,I).NE.ZERO ) THEN + I = I + 1 + GOTO 30 + END IF + 40 CONTINUE + DO 50 J = I+1, N + IF ( A(J,I).NE.ZERO ) THEN + I = I + 1 + GOTO 30 + END IF + 50 CONTINUE + DO 60 J = ILO, I + IF ( QG(I,J).NE.ZERO ) THEN + I = I + 1 + GOTO 30 + END IF + 60 CONTINUE + DO 70 J = I+1, N + IF ( QG(J,I).NE.ZERO ) THEN + I = I + 1 + GOTO 30 + END IF + 70 CONTINUE +C +C Exchange columns/rows ILO <-> I. +C + SCALE( ILO ) = DBLE( I ) + IF ( ILO.NE.I ) THEN +C + CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) + CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) +C + CALL DSWAP( 1, QG(I,ILO), LDQG, QG(ILO,ILO), LDQG ) + CALL DSWAP( N-I+1, QG(I,I), 1, QG(I,ILO), 1 ) + CALL DSWAP( I-ILO, QG(ILO,ILO), 1, QG(I,ILO), LDQG ) +C + CALL DSWAP( ILO, QG(1,I+1), 1, QG(1,ILO+1), 1 ) + CALL DSWAP( N-I+1, QG(I,I+1), LDQG, QG(ILO,I+1), + $ LDQG ) + CALL DSWAP( I-ILO, QG(ILO,ILO+1), LDQG, QG(ILO,I+1), + $ 1 ) + END IF + ILO = ILO + 1 + END IF +C END WHILE 30 +C +C Scan columns N+ILO .. 2*N. +C + I = ILO +C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) + 80 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN + DO 90 J = ILO, I-1 + IF ( A(I,J).NE.ZERO ) THEN + I = I + 1 + GOTO 80 + END IF + 90 CONTINUE + DO 100 J = I+1, N + IF ( A(I,J).NE.ZERO ) THEN + I = I + 1 + GOTO 80 + END IF + 100 CONTINUE + DO 110 J = ILO, I + IF ( QG(J,I+1).NE.ZERO ) THEN + I = I + 1 + GOTO 80 + END IF + 110 CONTINUE + DO 120 J = I+1, N + IF ( QG(I,J+1).NE.ZERO ) THEN + I = I + 1 + GOTO 80 + END IF + 120 CONTINUE + SCALE( ILO ) = DBLE( N+I ) +C +C Exchange columns/rows I <-> I+N with a symplectic +C generalized permutation. +C + CALL DSWAP( I-ILO, A(I,ILO), LDA, QG(I,ILO), LDQG ) + CALL DSCAL( I-ILO, -ONE, A(I,ILO), LDA ) + CALL DSWAP( N-I, A(I,I+1), LDA, QG(I+1,I), 1 ) + CALL DSCAL( N-I, -ONE, A(I,I+1), LDA ) + CALL DSWAP( I-1, A(1,I), 1, QG(1,I+1), 1 ) + CALL DSCAL( I-1, -ONE, A(1,I), 1 ) + CALL DSWAP( N-I, A(I+1,I), 1, QG(I,I+2), LDQG ) + CALL DSCAL( N-I, -ONE, A(I+1,I), 1 ) + A(I,I) = -A(I,I) + TEMP = QG(I,I) + QG(I,I) = -QG(I,I+1) + QG(I,I+1) = -TEMP +C +C Exchange columns/rows ILO <-> I. +C + IF ( ILO.NE.I ) THEN +C + CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) + CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) +C + CALL DSWAP( 1, QG(I,ILO), LDQG, QG(ILO,ILO), LDQG ) + CALL DSWAP( N-I+1, QG(I,I), 1, QG(I,ILO), 1 ) + CALL DSWAP( I-ILO, QG(ILO,ILO), 1, QG(I,ILO), LDQG ) +C + CALL DSWAP( ILO, QG(1,I+1), 1, QG(1,ILO+1), 1 ) + CALL DSWAP( N-I+1, QG(I,I+1), LDQG, QG(ILO,I+1), + $ LDQG ) + CALL DSWAP( I-ILO, QG(ILO,ILO+1), LDQG, QG(ILO,I+1), + $ 1 ) + END IF + ILO = ILO + 1 + END IF +C END WHILE 80 + GOTO 20 + END IF +C END WHILE 20 + END IF +C + DO 130 I = ILO, N + SCALE(I) = ONE + 130 CONTINUE +C +C Scale to reduce the 1-norm of the remaining blocks. +C + IF ( LSCAL ) THEN + SCLFAC = DLAMCH( 'B' ) + SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) + SFMAX1 = ONE / SFMIN1 + SFMIN2 = SFMIN1*SCLFAC + SFMAX2 = ONE / SFMIN2 +C +C Scale the rows and columns one at a time to minimize the +C 1-norm of the remaining Hamiltonian submatrix. +C Stop when the 1-norm is very roughly minimal. +C + 140 CONTINUE + CONV = .TRUE. + DO 170 I = ILO, N +C +C Compute 1-norm of row and column I without diagonal +C elements. +C + R = DASUM( I-ILO, A(I,ILO), LDA ) + + $ DASUM( N-I, A(I,I+1), LDA ) + + $ DASUM( I-ILO, QG(ILO,I+1), 1 ) + + $ DASUM( N-I, QG(I,I+2), LDQG ) + C = DASUM( I-ILO, A(ILO,I), 1 ) + + $ DASUM( N-I, A(I+1,I), 1 ) + + $ DASUM( I-ILO, QG(I,ILO), LDQG ) + + $ DASUM( N-I, QG(I+1,I), 1 ) + QII = ABS( QG(I,I) ) + GII = ABS( QG(I,I+1) ) +C +C Compute inf-norms of row and column I. +C + IC = IDAMAX( N-ILO+1, A(I,ILO), LDA ) + MAXR = ABS( A(I,IC+ILO-1) ) + IF ( I.GT.1 ) THEN + IC = IDAMAX( I-1, QG(1,I+1), 1 ) + MAXR = MAX( MAXR, ABS( QG(IC,I+1) ) ) + END IF + IF ( N.GT.I ) THEN + IC = IDAMAX( N-I, QG(I,I+2), LDQG ) + MAXR = MAX( MAXR, ABS( QG(I,IC+I+1) ) ) + END IF + IC = IDAMAX( N, A(1,I), 1 ) + MAXC = ABS( A(IC,I) ) + IF ( I.GT.ILO ) THEN + IC = IDAMAX( I-ILO, QG(I,ILO), LDQG ) + MAXC = MAX( MAXC, ABS( QG(I,IC+ILO-1) ) ) + END IF + IF ( N.GT.I ) THEN + IC = IDAMAX( N-I, QG(I+1,I), 1 ) + MAXC = MAX( MAXC, ABS( QG(IC+I,I) ) ) + END IF + IF ( ( C + QII ).EQ.ZERO .OR. ( R + GII ).EQ.ZERO ) + $ GO TO 170 +C + F = ONE + 150 CONTINUE + IF ( ( ( R + GII/SCLFAC )/SCLFAC ).GE. + $ ( ( C + QII*SCLFAC )*SCLFAC ) .AND. + $ MAX( F*SCLFAC, C*SCLFAC, MAXC*SCLFAC, + $ QII*SCLFAC*SCLFAC ).LT.SFMAX2 .AND. + $ MIN( ( R + GII/SCLFAC )/SCLFAC, MAX( MAXR/SCLFAC, + $ GII/SCLFAC/SCLFAC ) ).GT.SFMIN2 ) THEN + F = F*SCLFAC + C = C*SCLFAC + QII = QII*SCLFAC*SCLFAC + R = R / SCLFAC + GII = GII/SCLFAC/SCLFAC + MAXC = MAXC*SCLFAC + MAXR = MAXR / SCLFAC + GO TO 150 + END IF +C + 160 CONTINUE + IF ( ( ( R + GII*SCLFAC )*SCLFAC ).LE. + $ ( ( C + QII/SCLFAC )/SCLFAC ) .AND. + $ MAX( R*SCLFAC, MAXR*SCLFAC, + $ GII*SCLFAC*SCLFAC ).LT.SFMAX2 .AND. + $ MIN( F/SCLFAC, ( C + QII/SCLFAC )/SCLFAC, + $ MAX( MAXC/SCLFAC, QII/SCLFAC/SCLFAC ) ) + $ .GT.SFMIN2 ) THEN + F = F / SCLFAC + C = C / SCLFAC + QII = QII/SCLFAC/SCLFAC + R = R*SCLFAC + GII = GII*SCLFAC*SCLFAC + MAXC = MAXC/SCLFAC + MAXR = MAXR*SCLFAC + GO TO 160 + END IF +C +C Now balance if necessary. +C + IF ( F.NE.ONE ) THEN + IF ( F.LT.ONE .AND. SCALE(I).LT.ONE ) THEN + IF ( F*SCALE(I).LE.SFMIN1 ) + $ GO TO 170 + END IF + IF ( F.GT.ONE .AND. SCALE(I).GT.ONE ) THEN + IF ( SCALE(I).GE.SFMAX1 / F ) + $ GO TO 170 + END IF + CONV = .FALSE. + SCALE(I) = SCALE(I)*F + CALL DRSCL( I-ILO, F, A(I,ILO), LDA ) + CALL DRSCL( N-I, F, A(I,I+1), LDA ) + CALL DSCAL( I-1, F, A(1,I), 1 ) + CALL DSCAL( N-I, F, A(I+1,I), 1 ) + CALL DRSCL( I-1, F, QG(1,I+1), 1 ) + QG(I,I+1) = QG(I,I+1) / F / F + CALL DRSCL( N-I, F, QG(I,I+1+1), LDQG ) + CALL DSCAL( I-ILO, F, QG(I,ILO), LDQG ) + QG(I,I) = QG(I,I) * F * F + CALL DSCAL( N-I, F, QG(I+1,I), 1 ) + END IF + 170 CONTINUE + IF ( .NOT.CONV ) GO TO 140 + END IF + RETURN +C *** Last line of MB04DD *** + END diff --git a/mex/sources/libslicot/MB04DI.f b/mex/sources/libslicot/MB04DI.f new file mode 100644 index 000000000..793d6ab5a --- /dev/null +++ b/mex/sources/libslicot/MB04DI.f @@ -0,0 +1,216 @@ + SUBROUTINE MB04DI( JOB, SGN, N, ILO, SCALE, M, V1, LDV1, V2, LDV2, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply the inverse of a balancing transformation, computed by +C the SLICOT Library routines MB04DD or MB04DS, to a 2*N-by-M matrix +C +C [ V1 ] +C [ ], +C [ sgn*V2 ] +C +C where sgn is either +1 or -1. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the type of inverse transformation required: +C = 'N': do nothing, return immediately; +C = 'P': do inverse transformation for permutation only; +C = 'S': do inverse transformation for scaling only; +C = 'B': do inverse transformations for both permutation +C and scaling. +C JOB must be the same as the argument JOB supplied to +C MB04DD or MB04DS. +C +C SGN CHARACTER*1 +C Specifies the sign to use for V2: +C = 'P': sgn = +1; +C = 'N': sgn = -1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of rows of the matrices V1 and V2. N >= 0. +C +C ILO (input) INTEGER +C The integer ILO determined by MB04DD or MB04DS. +C 1 <= ILO <= N+1. +C +C SCALE (input) DOUBLE PRECISION array, dimension (N) +C Details of the permutation and scaling factors, as +C returned by MB04DD or MB04DS. +C +C M (input) INTEGER +C The number of columns of the matrices V1 and V2. M >= 0. +C +C V1 (input/output) DOUBLE PRECISION array, dimension (LDV1,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix V1. +C On exit, the leading N-by-M part of this array is +C overwritten by the updated matrix V1 of the transformed +C matrix. +C +C LDV1 INTEGER +C The leading dimension of the array V1. LDV1 >= max(1,N). +C +C V2 (input/output) DOUBLE PRECISION array, dimension (LDV2,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix V2. +C On exit, the leading N-by-M part of this array is +C overwritten by the updated matrix V2 of the transformed +C matrix. +C +C LDV2 INTEGER +C The leading dimension of the array V2. LDV2 >= max(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Benner, P. +C Symplectic balancing of Hamiltonian matrices. +C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DHABAK). +C +C KEYWORDS +C +C Balancing, Hamiltonian matrix, skew-Hamiltonian matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB, SGN + INTEGER ILO, INFO, LDV1, LDV2, M, N +C .. Array Arguments .. + DOUBLE PRECISION SCALE(*), V1(LDV1,*), V2(LDV2,*) +C .. Local Scalars .. + LOGICAL LPERM, LSCAL, LSGN, SYSW + INTEGER I, K +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DRSCL, DSCAL, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) + LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) + LSGN = LSAME( SGN, 'N' ) + IF ( .NOT.LPERM .AND. .NOT.LSCAL + $ .AND. .NOT.LSAME( JOB, 'N' ) ) THEN + INFO = -1 + ELSE IF ( .NOT.LSGN .AND. .NOT.LSAME( SGN, 'P' ) ) THEN + INFO = -2 + ELSE IF ( N.LT.0 ) THEN + INFO = -3 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.N+1 ) THEN + INFO = -4 + ELSE IF ( M.LT.0 ) THEN + INFO = -6 + ELSE IF ( LDV1.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF ( LDV2.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF +C +C Return if there were illegal values. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04DI', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 .OR. LSAME( JOB, 'N' ) ) + $ RETURN +C +C Inverse scaling. +C + IF ( LSCAL ) THEN + DO 20 I = ILO, N + CALL DRSCL( M, SCALE(I), V1(I,1), LDV1 ) + 20 CONTINUE + DO 30 I = ILO, N + CALL DRSCL( M, SCALE(I), V2(I,1), LDV2 ) + 30 CONTINUE + END IF +C +C Inverse permutation. +C + IF ( LPERM ) THEN + DO 40 I = ILO-1, 1, -1 + K = SCALE( I ) + SYSW = ( K.GT.N ) + IF ( SYSW ) + $ K = K - N +C + IF ( K.NE.I ) THEN +C +C Exchange rows k <-> i. +C + CALL DSWAP( M, V1(I,1), LDV1, V1(K,1), LDV1 ) + CALL DSWAP( M, V2(I,1), LDV2, V2(K,1), LDV2 ) + END IF +C + IF ( SYSW ) THEN +C +C Exchange V1(k,:) <-> V2(k,:). +C + CALL DSWAP( M, V1(K,1), LDV1, V2(K,1), LDV2 ) + IF ( LSGN ) THEN + CALL DSCAL( M, -ONE, V2(K,1), LDV2 ) + ELSE + CALL DSCAL( M, -ONE, V1(K,1), LDV1 ) + END IF + END IF + 40 CONTINUE + END IF +C + RETURN +C *** Last line of MB04DI *** + END diff --git a/mex/sources/libslicot/MB04DS.f b/mex/sources/libslicot/MB04DS.f new file mode 100644 index 000000000..f543a97d1 --- /dev/null +++ b/mex/sources/libslicot/MB04DS.f @@ -0,0 +1,450 @@ + SUBROUTINE MB04DS( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To balance a real skew-Hamiltonian matrix +C +C [ A G ] +C S = [ T ] , +C [ Q A ] +C +C where A is an N-by-N matrix and G, Q are N-by-N skew-symmetric +C matrices. This involves, first, permuting S by a symplectic +C similarity transformation to isolate eigenvalues in the first +C 1:ILO-1 elements on the diagonal of A; and second, applying a +C diagonal similarity transformation to rows and columns +C ILO:2*N-ILO+1 to make the rows and columns as close in 1-norm +C as possible. Both steps are optional. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the operations to be performed on S: +C = 'N': none, set ILO = 1, SCALE(I) = 1.0, I = 1 .. N; +C = 'P': permute only; +C = 'S': scale only; +C = 'B': both permute and scale. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, the leading N-by-N part of this array contains +C the matrix A of the balanced skew-Hamiltonian. In +C particular, the lower triangular part of the first ILO-1 +C columns of A is zero. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C QG (input/output) DOUBLE PRECISION array, dimension +C (LDQG,N) +C On entry, the leading N-by-N+1 part of this array must +C contain in columns 1:N the strictly lower triangular part +C of the matrix Q and in columns 2:N+1 the strictly upper +C triangular part of the matrix G. The parts containing the +C diagonal and the first supdiagonal of this array are not +C referenced. +C On exit, the leading N-by-N+1 part of this array contains +C the strictly lower and strictly upper triangular parts of +C the matrices Q and G, respectively, of the balanced +C skew-Hamiltonian. In particular, the strictly lower +C triangular part of the first ILO-1 columns of QG is zero. +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= MAX(1,N). +C +C ILO (output) INTEGER +C ILO-1 is the number of deflated eigenvalues in the +C balanced skew-Hamiltonian matrix. +C +C SCALE (output) DOUBLE PRECISION array of dimension (N) +C Details of the permutations and scaling factors applied to +C S. For j = 1,...,ILO-1 let P(j) = SCALE(j). If P(j) <= N, +C then rows and columns P(j) and P(j)+N are interchanged +C with rows and columns j and j+N, respectively. If +C P(j) > N, then row and column P(j)-N are interchanged with +C row and column j+N by a generalized symplectic +C permutation. For j = ILO,...,N the j-th element of SCALE +C contains the factor of the scaling applied to row and +C column j. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Benner, P. +C Symplectic balancing of Hamiltonian matrices. +C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DSHBAL). +C +C KEYWORDS +C +C Balancing, skew-Hamiltonian matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + DOUBLE PRECISION FACTOR + PARAMETER ( FACTOR = 0.95D0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER ILO, INFO, LDA, LDQG, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), QG(LDQG,*), SCALE(*) +C .. Local Scalars .. + LOGICAL CONV, LPERM, LSCAL + INTEGER I, IC, ILOOLD, J + DOUBLE PRECISION C, F, G, MAXC, MAXR, R, S, SCLFAC, SFMAX1, + $ SFMAX2, SFMIN1, SFMIN2 +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DASUM, DLAMCH + EXTERNAL DASUM, DLAMCH, IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DRSCL, DSCAL, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) + LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) +C + IF ( .NOT.LPERM .AND. .NOT.LSCAL .AND. + $ .NOT.LSAME( JOB, 'N' ) ) THEN + INFO = -1 + ELSE IF ( N.LT.0 ) THEN + INFO = -2 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF +C +C Return if there were illegal values. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04DS', -INFO ) + RETURN + END IF +C + ILO = 1 +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN + IF ( .NOT.LPERM .AND. .NOT.LSCAL ) THEN + DO 10 I = 1, N + SCALE(I) = ONE + 10 CONTINUE + RETURN + END IF +C +C Permutations to isolate eigenvalues if possible. +C + IF ( LPERM ) THEN + ILOOLD = 0 +C WHILE ( ILO.NE.ILOOLD ) + 20 IF ( ILO.NE.ILOOLD ) THEN + ILOOLD = ILO +C +C Scan columns ILO .. N. +C + I = ILO +C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) + 30 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN + DO 40 J = ILO, I-1 + IF ( A(J,I).NE.ZERO ) THEN + I = I + 1 + GOTO 30 + END IF + 40 CONTINUE + DO 50 J = I+1, N + IF ( A(J,I).NE.ZERO ) THEN + I = I + 1 + GOTO 30 + END IF + 50 CONTINUE + DO 60 J = ILO, I-1 + IF ( QG(I,J).NE.ZERO ) THEN + I = I + 1 + GOTO 30 + END IF + 60 CONTINUE + DO 70 J = I+1, N + IF ( QG(J,I).NE.ZERO ) THEN + I = I + 1 + GOTO 30 + END IF + 70 CONTINUE +C +C Exchange columns/rows ILO <-> I. +C + SCALE(ILO) = DBLE( I ) + IF ( ILO.NE.I ) THEN +C + CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) + CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) +C + IF ( I.LT.N ) + $ CALL DSWAP( N-I, QG(I+1,I), 1, QG(I+1,ILO), 1 ) + IF ( I.GT.ILO+1 ) THEN + CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,ILO), 1 ) + CALL DSWAP( I-ILO-1, QG(ILO+1,ILO), 1, QG(I,ILO+1), + $ LDQG ) + END IF +C + CALL DSWAP( ILO-1, QG(1,I+1), 1, QG(1,ILO+1), 1 ) + IF ( N.GT.I ) + $ CALL DSWAP( N-I, QG(I,I+2), LDQG, QG(ILO,I+2), + $ LDQG ) + IF ( I.GT.ILO+1 ) THEN + CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,I+1), 1 ) + CALL DSWAP( I-ILO-1, QG(ILO,ILO+2), LDQG, + $ QG(ILO+1,I+1), 1 ) + END IF + CALL DSCAL( I-ILO, -ONE, QG(ILO,I+1), 1 ) + END IF + ILO = ILO + 1 + END IF +C END WHILE 30 +C +C Scan columns N+ILO .. 2*N. +C + I = ILO +C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) + 80 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN + DO 90 J = ILO, I-1 + IF ( A(I,J).NE.ZERO ) THEN + I = I + 1 + GOTO 80 + END IF + 90 CONTINUE + DO 100 J = I+1, N + IF ( A(I,J).NE.ZERO ) THEN + I = I + 1 + GOTO 80 + END IF + 100 CONTINUE + DO 110 J = ILO, I-1 + IF ( QG(J,I+1).NE.ZERO ) THEN + I = I + 1 + GOTO 80 + END IF + 110 CONTINUE + DO 120 J = I+1, N + IF ( QG(I,J+1).NE.ZERO ) THEN + I = I + 1 + GOTO 80 + END IF + 120 CONTINUE + SCALE(ILO) = DBLE( N+I ) +C +C Exchange columns/rows I <-> I+N with a symplectic +C generalized permutation. +C + CALL DSWAP( I-ILO, A(I,ILO), LDA, QG(I,ILO), LDQG ) + CALL DSCAL( I-ILO, -ONE, A(I,ILO), LDA ) + CALL DSWAP( N-I, A(I,I+1), LDA, QG(I+1,I), 1 ) + CALL DSCAL( N-I, -ONE, QG(I+1,I), 1 ) + CALL DSWAP( I-1, A(1,I), 1, QG(1,I+1), 1 ) + CALL DSCAL( I-1, -ONE, A(1,I), 1 ) + CALL DSCAL( N-I, -ONE, A(I+1,I), 1 ) + CALL DSWAP( N-I, A(I+1,I), 1, QG(I,I+2), LDQG ) +C +C Exchange columns/rows ILO <-> I. +C + IF ( ILO.NE.I ) THEN +C + CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) + CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) +C + IF ( I.LT.N ) + $ CALL DSWAP( N-I, QG(I+1,I), 1, QG(I+1,ILO), 1 ) + IF ( I.GT.ILO+1 ) THEN + CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,ILO), 1 ) + CALL DSWAP( I-ILO-1, QG(ILO+1,ILO), 1, QG(I,ILO+1), + $ LDQG ) + END IF +C + CALL DSWAP( ILO-1, QG(1,I+1), 1, QG(1,ILO+1), 1 ) + IF ( N.GT.I ) + $ CALL DSWAP( N-I, QG(I,I+2), LDQG, QG(ILO,I+2), + $ LDQG ) + IF ( I.GT.ILO+1 ) THEN + CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,I+1), 1 ) + CALL DSWAP( I-ILO-1, QG(ILO,ILO+2), LDQG, + $ QG(ILO+1,I+1), 1 ) + END IF + CALL DSCAL( I-ILO, -ONE, QG(ILO,I+1), 1 ) + END IF + ILO = ILO + 1 + END IF +C END WHILE 80 + GOTO 20 + END IF +C END WHILE 20 + END IF +C + DO 130 I = ILO, N + SCALE(I) = ONE + 130 CONTINUE +C +C Scale to reduce the 1-norm of the remaining blocks. +C + IF ( LSCAL ) THEN + SCLFAC = DLAMCH( 'B' ) + SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) + SFMAX1 = ONE / SFMIN1 + SFMIN2 = SFMIN1*SCLFAC + SFMAX2 = ONE / SFMIN2 +C +C Scale the rows and columns one at a time to minimize the +C 1-norm of the skew-Hamiltonian submatrix. +C Stop when the 1-norm is very roughly minimal. +C + 140 CONTINUE + CONV = .TRUE. + DO 190 I = ILO, N +C +C Compute 1-norm of row and column I without diagonal +C elements. +C + R = DASUM( I-ILO, A(I,ILO), LDA ) + + $ DASUM( N-I, A(I,I+1), LDA ) + + $ DASUM( I-ILO, QG(ILO,I+1), 1 ) + + $ DASUM( N-I, QG(I,I+2), LDQG ) + C = DASUM( I-ILO, A(ILO,I), 1 ) + + $ DASUM( N-I, A(I+1,I), 1 ) + + $ DASUM( I-ILO, QG(I,ILO), LDQG ) + + $ DASUM( N-I, QG(I+1,I), 1 ) +C +C Compute inf-norms of row and column I. +C + IC = IDAMAX( N-ILO+1, A(I,ILO), LDA ) + MAXR = ABS( A(I,IC+ILO-1) ) + IF ( I.GT.1 ) THEN + IC = IDAMAX( I-1, QG(1,I+1), 1 ) + MAXR = MAX( MAXR, ABS( QG(IC,I+1) ) ) + END IF + IF ( N.GT.I ) THEN + IC = IDAMAX( N-I, QG(I,I+2), LDQG ) + MAXR = MAX( MAXR, ABS( QG(I,IC+I+1) ) ) + END IF + IC = IDAMAX( N, A(1,I), 1 ) + MAXC = ABS( A(IC,I) ) + IF ( I.GT.ILO ) THEN + IC = IDAMAX( I-ILO, QG(I,ILO), LDQG ) + MAXC = MAX( MAXC, ABS( QG(I,IC+ILO-1) ) ) + END IF + IF ( N.GT.I ) THEN + IC = IDAMAX( N-I, QG(I+1,I), 1 ) + MAXC = MAX( MAXC, ABS( QG(IC+I,I) ) ) + END IF +C + IF ( C.EQ.ZERO .OR. R.EQ.ZERO ) + $ GOTO 190 + G = R / SCLFAC + F = ONE + S = C + R + 150 CONTINUE + IF ( C.GE.G .OR. MAX( F, C, MAXC ).GE.SFMAX2 .OR. + $ MIN( R, G, MAXR ).LE.SFMIN2 ) + $ GOTO 160 + F = F*SCLFAC + G = G / SCLFAC + C = C*SCLFAC + R = R / SCLFAC + MAXC = MAXC*SCLFAC + MAXR = MAXR / SCLFAC + GOTO 150 +C + 160 CONTINUE + G = C / SCLFAC + 170 CONTINUE + IF ( G.LT.R .OR. MAX( R, MAXR ).GE.SFMAX2 .OR. + $ MIN( F, C, G, MAXC ).LE.SFMIN2 ) + $ GOTO 180 + F = F / SCLFAC + G = G / SCLFAC + C = C / SCLFAC + R = R*SCLFAC + MAXC = MAXC / SCLFAC + MAXR = MAXR*SCLFAC + GOTO 170 +C + 180 CONTINUE +C +C Now balance if necessary. +C + IF ( ( C+R ).GE.FACTOR*S ) + $ GOTO 190 + IF ( F.LT.ONE .AND. SCALE(I).LT.ONE ) THEN + IF ( F*SCALE(I).LE.SFMIN1 ) + $ GOTO 190 + END IF + IF ( F.GT.ONE .AND. SCALE(I).GT.ONE ) THEN + IF ( SCALE(I).GE.SFMAX1 / F ) + $ GOTO 190 + END IF + CONV = .FALSE. + SCALE(I) = SCALE(I)*F + CALL DRSCL( I-ILO, F, A(I,ILO), LDA ) + CALL DRSCL( N-I, F, A(I,I+1), LDA ) + CALL DSCAL( I-1, F, A(1,I), 1 ) + CALL DSCAL( N-I, F, A(I+1,I), 1 ) + CALL DRSCL( I-1, F, QG(1,I+1), 1 ) + CALL DRSCL( N-I, F, QG(I,I+2), LDQG ) + CALL DSCAL( I-ILO, F, QG(I,ILO), LDQG ) + CALL DSCAL( N-I, F, QG(I+1,I), 1 ) + 190 CONTINUE + IF ( .NOT.CONV ) GOTO 140 + END IF + RETURN +C *** Last line of MB04DS *** + END diff --git a/mex/sources/libslicot/MB04DY.f b/mex/sources/libslicot/MB04DY.f new file mode 100644 index 000000000..6b8b3203d --- /dev/null +++ b/mex/sources/libslicot/MB04DY.f @@ -0,0 +1,329 @@ + SUBROUTINE MB04DY( JOBSCL, N, A, LDA, QG, LDQG, D, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform a symplectic scaling on the Hamiltonian matrix +C +C ( A G ) +C H = ( T ), (1) +C ( Q -A ) +C +C i.e., perform either the symplectic scaling transformation +C +C -1 +C ( A' G' ) ( D 0 ) ( A G ) ( D 0 ) +C H' <-- ( T ) = ( ) ( T ) ( -1 ), (2) +C ( Q' -A' ) ( 0 D ) ( Q -A ) ( 0 D ) +C +C where D is a diagonal scaling matrix, or the symplectic norm +C scaling transformation +C +C ( A'' G'' ) 1 ( A G/tau ) +C H'' <-- ( T ) = --- ( T ), (3) +C ( Q'' -A'' ) tau ( tau Q -A ) +C +C where tau is a real scalar. Note that if tau is not equal to 1, +C then (3) is NOT a similarity transformation. The eigenvalues +C of H are then tau times the eigenvalues of H''. +C +C For symplectic scaling (2), D is chosen to give the rows and +C columns of A' approximately equal 1-norms and to give Q' and G' +C approximately equal norms. (See METHOD below for details.) For +C norm scaling, tau = MAX(1, ||A||, ||G||, ||Q||) where ||.|| +C denotes the 1-norm (column sum norm). +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBSCL CHARACTER*1 +C Indicates which scaling strategy is used, as follows: +C = 'S' : do the symplectic scaling (2); +C = '1' or 'O': do the 1-norm scaling (3); +C = 'N' : do nothing; set INFO and return. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, G, and Q. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On input, if JOBSCL <> 'N', the leading N-by-N part of +C this array must contain the upper left block A of the +C Hamiltonian matrix H in (1). +C On output, if JOBSCL <> 'N', the leading N-by-N part of +C this array contains the leading N-by-N part of the scaled +C Hamiltonian matrix H' in (2) or H'' in (3), depending on +C the setting of JOBSCL. +C If JOBSCL = 'N', this array is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,N), if JOBSCL <> 'N'; +C LDA >= 1, if JOBSCL = 'N'. +C +C QG (input/output) DOUBLE PRECISION array, dimension +C (LDQG,N+1) +C On input, if JOBSCL <> 'N', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangle of the lower left symmetric block Q of the +C Hamiltonian matrix H in (1), and the N-by-N upper +C triangular part of the submatrix in the columns 2 to N+1 +C of this array must contain the upper triangle of the upper +C right symmetric block G of H in (1). +C So, if i >= j, then Q(i,j) = Q(j,i) is stored in QG(i,j) +C and G(i,j) = G(j,i) is stored in QG(j,i+1). +C On output, if JOBSCL <> 'N', the leading N-by-N lower +C triangular part of this array contains the lower triangle +C of the lower left symmetric block Q' or Q'', and the +C N-by-N upper triangular part of the submatrix in the +C columns 2 to N+1 of this array contains the upper triangle +C of the upper right symmetric block G' or G'' of the scaled +C Hamiltonian matrix H' in (2) or H'' in (3), depending on +C the setting of JOBSCL. +C If JOBSCL = 'N', this array is not referenced. +C +C LDQG INTEGER +C The leading dimension of the array QG. +C LDQG >= MAX(1,N), if JOBSCL <> 'N'; +C LDQG >= 1, if JOBSCL = 'N'. +C +C D (output) DOUBLE PRECISION array, dimension (nd) +C If JOBSCL = 'S', then nd = N and D contains the diagonal +C elements of the diagonal scaling matrix in (2). +C If JOBSCL = '1' or 'O', then nd = 1 and D(1) is set to tau +C from (3). In this case, no other elements of D are +C referenced. +C If JOBSCL = 'N', this array is not referenced. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C If JOBSCL = 'N', this array is not referenced. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, then the i-th argument had an illegal +C value. +C +C METHOD +C +C 1. Symplectic scaling (JOBSCL = 'S'): +C +C First, LAPACK subroutine DGEBAL is used to equilibrate the 1-norms +C of the rows and columns of A using a diagonal scaling matrix D_A. +C Then, H is similarily transformed by the symplectic diagonal +C matrix D1 = diag(D_A,D_A**(-1)). Next, the off-diagonal blocks of +C the resulting Hamiltonian matrix are equilibrated in the 1-norm +C using the symplectic diagonal matrix D2 of the form +C +C ( I/rho 0 ) +C D2 = ( ) +C ( 0 rho*I ) +C +C where rho is a real scalar. Thus, in (2), D = D1*D2. +C +C 2. Norm scaling (JOBSCL = '1' or 'O'): +C +C The norm of the matrices A and G of (1) is reduced by setting +C A := A/tau and G := G/(tau**2) where tau is the power of the +C base of the arithmetic closest to MAX(1, ||A||, ||G||, ||Q||) and +C ||.|| denotes the 1-norm. +C +C REFERENCES +C +C [1] Benner, P., Byers, R., and Barth, E. +C Fortran 77 Subroutines for Computing the Eigenvalues of +C Hamiltonian Matrices. I: The Square-Reduced Method. +C ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000. +C +C NUMERICAL ASPECTS +C +C For symplectic scaling, the complexity of the used algorithms is +C hard to estimate and depends upon how well the rows and columns of +C A in (1) are equilibrated. In one sweep, each row/column of A is +C scaled once, i.e., the cost of one sweep is N**2 multiplications. +C Usually, 3-6 sweeps are enough to equilibrate the norms of the +C rows and columns of a matrix. Roundoff errors are possible as +C LAPACK routine DGEBAL does NOT use powers of the machine base for +C scaling. The second stage (equilibrating ||G|| and ||Q||) requires +C N**2 multiplications. +C For norm scaling, 3*N**2 + O(N) multiplications are required and +C NO rounding errors occur as all multiplications are performed with +C powers of the machine base. +C +C CONTRIBUTOR +C +C P. Benner, Universitaet Bremen, Germany, and +C R. Byers, University of Kansas, Lawrence, USA. +C Aug. 1998, routine DHABL. +C V. Sima, Research Institute for Informatics, Bucharest, Romania, +C Oct. 1998, SLICOT Library version. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2009. +C +C KEYWORDS +C +C Balancing, Hamiltonian matrix, norms, symplectic similarity +C transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDQG, N + CHARACTER JOBSCL +C .. +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), D(*), DWORK(*), QG(LDQG,*) +C .. +C .. Local Scalars .. + DOUBLE PRECISION ANRM, BASE, EPS, GNRM, OFL, QNRM, + $ RHO, SFMAX, SFMIN, TAU, UFL, Y + INTEGER I, IERR, IHI, ILO, J + LOGICAL NONE, NORM, SYMP +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + LOGICAL LSAME + EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DGEBAL, DLABAD, DLASCL, DRSCL, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +C .. +C .. Executable Statements .. +C + INFO = 0 + SYMP = LSAME( JOBSCL, 'S' ) + NORM = LSAME( JOBSCL, '1' ) .OR. LSAME( JOBSCL, 'O' ) + NONE = LSAME( JOBSCL, 'N' ) +C + IF( .NOT.SYMP .AND. .NOT.NORM .AND. .NOT.NONE ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.1 .OR. ( .NOT.NONE .AND. LDA.LT.N ) ) THEN + INFO = -4 + ELSE IF( LDQG.LT.1 .OR. ( .NOT.NONE .AND. LDQG.LT.N ) ) THEN + INFO = -6 + END IF +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04DY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. NONE ) + $ RETURN +C +C Set some machine dependant constants. +C + BASE = DLAMCH( 'Base' ) + EPS = DLAMCH( 'Precision' ) + UFL = DLAMCH( 'Safe minimum' ) + OFL = ONE/UFL + CALL DLABAD( UFL, OFL ) + SFMAX = ( EPS/BASE )/UFL + SFMIN = ONE/SFMAX +C + IF ( NORM ) THEN +C +C Compute norms. +C + ANRM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) + GNRM = DLANSY( '1-norm', 'Upper', N, QG(1,2), LDQG, DWORK ) + QNRM = DLANSY( '1-norm', 'Lower', N, QG, LDQG, DWORK ) + Y = MAX( ONE, ANRM, GNRM, QNRM ) + TAU = ONE +C +C WHILE ( TAU < Y ) DO + 10 CONTINUE + IF ( ( TAU.LT.Y ) .AND. ( TAU.LT.SQRT( SFMAX ) ) ) THEN + TAU = TAU*BASE + GO TO 10 + END IF +C END WHILE 10 + IF ( TAU.GT.ONE ) THEN + IF ( ABS( TAU/BASE - Y ).LT.ABS( TAU - Y ) ) + $ TAU = TAU/BASE + CALL DLASCL( 'General', 0, 0, TAU, ONE, N, N, A, LDA, IERR ) + CALL DLASCL( 'Upper', 0, 0, TAU, ONE, N, N, QG(1,2), LDQG, + $ IERR ) + CALL DLASCL( 'Upper', 0, 0, TAU, ONE, N, N, QG(1,2), LDQG, + $ IERR ) + END IF +C + D(1) = TAU +C + ELSE + CALL DGEBAL( 'Scale', N, A, LDA, ILO, IHI, D, IERR ) +C + DO 30 J = 1, N +C + DO 20 I = J, N + QG(I,J) = QG(I,J)*D(J)*D(I) + 20 CONTINUE +C + 30 CONTINUE +C + DO 50 J = 2, N + 1 +C + DO 40 I = 1, J - 1 + QG(I,J) = QG(I,J)/D(J-1)/D(I) + 40 CONTINUE +C + 50 CONTINUE +C + GNRM = DLANSY( '1-norm', 'Upper', N, QG(1,2), LDQG, DWORK ) + QNRM = DLANSY( '1-norm', 'Lower', N, QG, LDQG, DWORK ) + IF ( GNRM.EQ.ZERO ) THEN + IF ( QNRM.EQ.ZERO ) THEN + RHO = ONE + ELSE + RHO = SFMAX + END IF + ELSE IF ( QNRM.EQ.ZERO ) THEN + RHO = SFMIN + ELSE + RHO = SQRT( QNRM )/SQRT( GNRM ) + END IF +C + CALL DLASCL( 'Lower', 0, 0, RHO, ONE, N, N, QG, LDQG, IERR ) + CALL DLASCL( 'Upper', 0, 0, ONE, RHO, N, N, QG(1,2), LDQG, + $ IERR ) + CALL DRSCL( N, SQRT( RHO ), D, 1 ) + END IF +C + RETURN +C *** Last line of MB04DY *** + END diff --git a/mex/sources/libslicot/MB04GD.f b/mex/sources/libslicot/MB04GD.f new file mode 100644 index 000000000..fa7502ec6 --- /dev/null +++ b/mex/sources/libslicot/MB04GD.f @@ -0,0 +1,258 @@ + SUBROUTINE MB04GD( M, N, A, LDA, JPVT, TAU, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute an RQ factorization with row pivoting of a +C real m-by-n matrix A: P*A = R*Q. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the m-by-n matrix A. +C On exit, +C if m <= n, the upper triangle of the subarray +C A(1:m,n-m+1:n) contains the m-by-m upper triangular +C matrix R; +C if m >= n, the elements on and above the (m-n)-th +C subdiagonal contain the m-by-n upper trapezoidal matrix R; +C the remaining elements, with the array TAU, represent the +C orthogonal matrix Q as a product of min(m,n) elementary +C reflectors (see METHOD). +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C JPVT (input/output) INTEGER array, dimension (M) +C On entry, if JPVT(i) .ne. 0, the i-th row of A is permuted +C to the bottom of P*A (a trailing row); if JPVT(i) = 0, +C the i-th row of A is a free row. +C On exit, if JPVT(i) = k, then the i-th row of P*A +C was the k-th row of A. +C +C TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) +C The scalar factors of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (3*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix Q is represented as a product of elementary reflectors +C +C Q = H(1) H(2) . . . H(k), where k = min(m,n). +C +C Each H(i) has the form +C +C H = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit +C in A(m-k+i,1:n-k+i-1), and tau in TAU(i). +C +C The matrix P is represented in jpvt as follows: If +C jpvt(j) = i +C then the jth row of P is the ith canonical unit vector. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Based on LAPACK Library routines DGEQPF and DGERQ2. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Factorization, matrix algebra, matrix operations, orthogonal +C transformation, triangular form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, P05 + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +C .. +C .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), DWORK( * ), TAU( * ) +C .. +C .. Local Scalars .. + INTEGER I, ITEMP, J, K, MA, MKI, NFREE, NKI, PVT + DOUBLE PRECISION AII, TEMP, TEMP2 +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2, IDAMAX +C .. +C .. External Subroutines .. + EXTERNAL DGERQ2, DLARF, DLARFG, DORMR2, DSWAP, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04GD', -INFO ) + RETURN + END IF +C + K = MIN( M, N ) +C +C Move non-free rows bottom. +C + ITEMP = M + DO 10 I = M, 1, -1 + IF( JPVT( I ).NE.0 ) THEN + IF( I.NE.ITEMP ) THEN + CALL DSWAP( N, A( I, 1 ), LDA, A( ITEMP, 1 ), LDA ) + JPVT( I ) = JPVT( ITEMP ) + JPVT( ITEMP ) = I + ELSE + JPVT( I ) = I + END IF + ITEMP = ITEMP - 1 + ELSE + JPVT( I ) = I + END IF + 10 CONTINUE + NFREE = M - ITEMP +C +C Compute the RQ factorization and update remaining rows. +C + IF( NFREE.GT.0 ) THEN + MA = MIN( NFREE, N ) + CALL DGERQ2( MA, N, A(M-MA+1,1), LDA, TAU(K-MA+1), DWORK, + $ INFO ) + CALL DORMR2( 'Right', 'Transpose', M-MA, N, MA, A(M-MA+1,1), + $ LDA, TAU(K-MA+1), A, LDA, DWORK, INFO ) + END IF +C + IF( NFREE.LT.K ) THEN +C +C Initialize partial row norms. The first ITEMP elements of +C DWORK store the exact row norms. (Here, ITEMP is the number of +C free rows, which have been permuted to be the first ones.) +C + DO 20 I = 1, ITEMP + DWORK( I ) = DNRM2( N-NFREE, A( I, 1 ), LDA ) + DWORK( M+I ) = DWORK( I ) + 20 CONTINUE +C +C Compute factorization. +C + DO 40 I = K-NFREE, 1, -1 +C +C Determine ith pivot row and swap if necessary. +C + MKI = M - K + I + NKI = N - K + I + PVT = IDAMAX( MKI, DWORK, 1 ) +C + IF( PVT.NE.MKI ) THEN + CALL DSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( MKI ) + JPVT( MKI ) = ITEMP + DWORK( PVT ) = DWORK( MKI ) + DWORK( M+PVT ) = DWORK( M+MKI ) + END IF +C +C Generate elementary reflector H(i) to annihilate +C A(m-k+i,1:n-k+i-1), k = min(m,n). +C + CALL DLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I ) + $ ) +C +C Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right. +C + AII = A( MKI, NKI ) + A( MKI, NKI ) = ONE + CALL DLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA, + $ TAU( I ), A, LDA, DWORK( 2*M+1 ) ) + A( MKI, NKI ) = AII +C +C Update partial row norms. +C + DO 30 J = 1, MKI - 1 + IF( DWORK( J ).NE.ZERO ) THEN + TEMP = ONE - ( ABS( A( J, NKI ) ) / DWORK( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = ONE + P05*TEMP* + $ ( DWORK( J ) / DWORK( M+J ) )**2 + IF( TEMP2.EQ.ONE ) THEN + DWORK( J ) = DNRM2( NKI-1, A( J, 1 ), LDA ) + DWORK( M+J ) = DWORK( J ) + ELSE + DWORK( J ) = DWORK( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE +C + 40 CONTINUE + END IF +C + RETURN +C *** Last line of MB04GD *** + END diff --git a/mex/sources/libslicot/MB04ID.f b/mex/sources/libslicot/MB04ID.f new file mode 100644 index 000000000..d28929f2f --- /dev/null +++ b/mex/sources/libslicot/MB04ID.f @@ -0,0 +1,278 @@ + SUBROUTINE MB04ID( N, M, P, L, A, LDA, B, LDB, TAU, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a QR factorization of an n-by-m matrix A (A = Q * R), +C having a p-by-min(p,m) zero triangle in the lower left-hand side +C corner, as shown below, for n = 8, m = 7, and p = 2: +C +C [ x x x x x x x ] +C [ x x x x x x x ] +C [ x x x x x x x ] +C [ x x x x x x x ] +C A = [ x x x x x x x ], +C [ x x x x x x x ] +C [ 0 x x x x x x ] +C [ 0 0 x x x x x ] +C +C and optionally apply the transformations to an n-by-l matrix B +C (from the left). The problem structure is exploited. This +C computation is useful, for instance, in combined measurement and +C time update of one iteration of the time-invariant Kalman filter +C (square root information filter). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of rows of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrix A. M >= 0. +C +C P (input) INTEGER +C The order of the zero triagle. P >= 0. +C +C L (input) INTEGER +C The number of columns of the matrix B. L >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix A. The elements corresponding to the +C zero P-by-MIN(P,M) lower trapezoidal/triangular part +C (if P > 0) are not referenced. +C On exit, the elements on and above the diagonal of this +C array contain the MIN(N,M)-by-M upper trapezoidal matrix +C R (R is upper triangular, if N >= M) of the QR +C factorization, and the relevant elements below the +C diagonal contain the trailing components (the vectors v, +C see Method) of the elementary reflectors used in the +C factorization. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,L) +C On entry, the leading N-by-L part of this array must +C contain the matrix B. +C On exit, the leading N-by-L part of this array contains +C the updated matrix B. +C If L = 0, this array is not referenced. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,N) if L > 0; +C LDB >= 1 if L = 0. +C +C TAU (output) DOUBLE PRECISION array, dimension MIN(N,M) +C The scalar factors of the elementary reflectors used. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK The length of the array DWORK. +C LDWORK >= MAX(1,M-1,M-P,L). +C For optimum performance LDWORK should be larger. +C +C If LDWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C DWORK array, returns this value as the first entry of +C the DWORK array, and no error message related to LDWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine uses min(N,M) Householder transformations exploiting +C the zero pattern of the matrix. A Householder matrix has the form +C +C ( 1 ), +C H = I - tau *u *u', u = ( v ) +C i i i i i ( i) +C +C where v is an (N-P+I-2)-vector. The components of v are stored +C i i +C in the i-th column of A, beginning from the location i+1, and +C tau is stored in TAU(i). +C i +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2009, +C Apr. 2009. +C +C KEYWORDS +C +C Elementary reflector, QR factorization, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, L, LDA, LDB, LDWORK, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*) +C .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, NB, WRKOPT + DOUBLE PRECISION FIRST +C .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +C .. External Subroutines .. + EXTERNAL DGEQRF, DLARF, DLARFG, DORMQR, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LQUERY = ( LDWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( L.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.1 .OR. ( L.GT.0 .AND. LDB.LT.N ) ) THEN + INFO = -8 + ELSE + I = MAX( 1, M - 1, M - P, L ) + IF( LQUERY ) THEN + IF( M.GT.P ) THEN + NB = ILAENV( 1, 'DGEQRF', ' ', N-P, M-P, -1, -1 ) + WRKOPT = MAX( I, ( M - P )*NB ) + IF ( L.GT.0 ) THEN + NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LT', N-P, L, + $ MIN(N,M)-P, -1 ) ) + WRKOPT = MAX( WRKOPT, MAX( 1, L )*NB ) + END IF + END IF + ELSE IF( LDWORK.LT.I ) THEN + INFO = -11 + END IF + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB04ID', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( M, N ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + ELSE IF( N.LE.P+1 ) THEN + DO 5 I = 1, MIN( N, M ) + TAU(I) = ZERO + 5 CONTINUE + DWORK(1) = ONE + RETURN + END IF +C +C Annihilate the subdiagonal elements of A and apply the +C transformations to B, if L > 0. +C Workspace: need MAX(M-1,L). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + DO 10 I = 1, MIN( P, M ) +C +C Exploit the structure of the I-th column of A. +C + CALL DLARFG( N-P, A(I,I), A(I+1,I), 1, TAU(I) ) + IF( TAU(I).NE.ZERO ) THEN +C + FIRST = A(I,I) + A(I,I) = ONE +C + IF ( I.LT.M ) CALL DLARF( 'Left', N-P, M-I, A(I,I), 1, + $ TAU(I), A(I,I+1), LDA, DWORK ) + IF ( L.GT.0 ) CALL DLARF( 'Left', N-P, L, A(I,I), 1, TAU(I), + $ B(I,1), LDB, DWORK ) +C + A(I,I) = FIRST + END IF + 10 CONTINUE +C + WRKOPT = MAX( 1, M - 1, L ) +C +C Fast QR factorization of the remaining right submatrix, if any. +C Workspace: need M-P; prefer (M-P)*NB. +C + IF( M.GT.P ) THEN + CALL DGEQRF( N-P, M-P, A(P+1,P+1), LDA, TAU(P+1), DWORK, + $ LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C + IF ( L.GT.0 ) THEN +C +C Apply the transformations to B. +C Workspace: need L; prefer L*NB. +C + CALL DORMQR( 'Left', 'Transpose', N-P, L, MIN(N,M)-P, + $ A(P+1,P+1), LDA, TAU(P+1), B(P+1,1), LDB, + $ DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + END IF + END IF +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of MB04ID *** + END diff --git a/mex/sources/libslicot/MB04IY.f b/mex/sources/libslicot/MB04IY.f new file mode 100644 index 000000000..4b07b2c35 --- /dev/null +++ b/mex/sources/libslicot/MB04IY.f @@ -0,0 +1,327 @@ + SUBROUTINE MB04IY( SIDE, TRANS, N, M, K, P, A, LDA, TAU, C, LDC, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To overwrite the real n-by-m matrix C with Q' * C, Q * C, +C C * Q', or C * Q, according to the following table +C +C SIDE = 'L' SIDE = 'R' +C TRANS = 'N': Q * C C * Q +C TRANS = 'T': Q'* C C * Q' +C +C where Q is a real orthogonal matrix defined as the product of +C k elementary reflectors +C +C Q = H(1) H(2) . . . H(k) +C +C as returned by SLICOT Library routine MB04ID. Q is of order n +C if SIDE = 'L' and of order m if SIDE = 'R'. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specify if Q or Q' is applied from the left or right, +C as follows: +C = 'L': apply Q or Q' from the left; +C = 'R': apply Q or Q' from the right. +C +C TRANS CHARACTER*1 +C Specify if Q or Q' is to be applied, as follows: +C = 'N': apply Q (No transpose); +C = 'T': apply Q' (Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of rows of the matrix C. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrix C. M >= 0. +C +C K (input) INTEGER +C The number of elementary reflectors whose product defines +C the matrix Q. +C N >= K >= 0, if SIDE = 'L'; +C M >= K >= 0, if SIDE = 'R'. +C +C P (input) INTEGER +C The order of the zero triagle (or the number of rows of +C the zero trapezoid) in the matrix triangularized by SLICOT +C Library routine MB04ID. P >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,K) +C On input, the elements in the rows i+1:min(n,n-p-1+i) of +C the i-th column, and TAU(i), represent the orthogonal +C reflector H(i), so that matrix Q is the product of +C elementary reflectors: Q = H(1) H(2) . . . H(k). +C A is modified by the routine but restored on exit. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= max(1,N), if SIDE = 'L'; +C LDA >= max(1,M), if SIDE = 'R'. +C +C TAU (input) DOUBLE PRECISION array, dimension (K) +C The scalar factors of the elementary reflectors. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix C. +C On exit, the leading N-by-M part of this array contains +C the updated matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,M), if SIDE = 'L'; +C LDWORK >= MAX(1,N), if SIDE = 'R'. +C For optimum performance LDWORK >= M*NB if SIDE = 'L', +C or LDWORK >= N*NB if SIDE = 'R', where NB is the optimal +C block size. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C If SIDE = 'L', each elementary reflector H(i) modifies +C n-p elements of each column of C, for i = 1:p+1, and +C n-i+1 elements, for i = p+2:k. +C If SIDE = 'R', each elementary reflector H(i) modifies +C m-p elements of each row of C, for i = 1:p+1, and +C m-i+1 elements, for i = p+2:k. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Matrix operations, QR decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +C .. Scalar Arguments .. + INTEGER INFO, K, LDA, LDC, LDWORK, M, N, P + CHARACTER SIDE, TRANS +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), TAU( * ) +C .. Local Scalars .. + LOGICAL LEFT, TRAN + INTEGER I + DOUBLE PRECISION AII, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARF, DORMQR, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C +C Check the scalar input arguments. +C + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + TRAN = LSAME( TRANS, 'T' ) +C + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. ( LEFT .AND. K.GT.N ) .OR. + $ ( .NOT.LEFT .AND. K.GT.M ) ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( ( LEFT .AND. LDA.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LEFT .AND. LDA.LT.MAX( 1, M ) ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( ( LEFT .AND. LDWORK.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.LEFT .AND. LDWORK.LT.MAX( 1, N ) ) ) THEN + INFO = -13 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04IY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 .OR. ( LEFT .AND. N.LT.P ) + $ .OR. ( .NOT.LEFT .AND. M.LT.P ) ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF( LEFT ) THEN + WRKOPT = DBLE( M ) + IF( TRAN ) THEN +C + DO 10 I = 1, MIN( K, P ) +C +C Apply H(i) to C(i:i+n-p-1,1:m), from the left. +C Workspace: need M. +C + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, N-P, M, A( I, I ), 1, TAU( I ), + $ C( I, 1 ), LDC, DWORK ) + A( I, I ) = AII + 10 CONTINUE +C + IF ( P.LE.MIN( N, K ) ) THEN +C +C Apply H(i) to C, i = p+1:k, from the left. +C Workspace: need M; prefer M*NB. +C + CALL DORMQR( SIDE, TRANS, N-P, M, K-P, A( P+1, P+1 ), + $ LDA, TAU( P+1 ), C( P+1, 1 ), LDC, DWORK, + $ LDWORK, I ) + WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) + END IF +C + ELSE +C + IF ( P.LE.MIN( N, K ) ) THEN +C +C Apply H(i) to C, i = k:p+1:-1, from the left. +C Workspace: need M; prefer M*NB. +C + CALL DORMQR( SIDE, TRANS, N-P, M, K-P, A( P+1, P+1 ), + $ LDA, TAU( P+1 ), C( P+1, 1 ), LDC, DWORK, + $ LDWORK, I ) + WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) + END IF +C + DO 20 I = MIN( K, P ), 1, -1 +C +C Apply H(i) to C(i:i+n-p-1,1:m), from the left. +C Workspace: need M. +C + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, N-P, M, A( I, I ), 1, TAU( I ), + $ C( I, 1 ), LDC, DWORK ) + A( I, I ) = AII + 20 CONTINUE + END IF +C + ELSE +C + WRKOPT = DBLE( N ) + IF( TRAN ) THEN +C + IF ( P.LE.MIN( M, K ) ) THEN +C +C Apply H(i) to C, i = k:p+1:-1, from the right. +C Workspace: need N; prefer N*NB. +C + CALL DORMQR( SIDE, TRANS, N, M-P, K-P, A( P+1, P+1 ), + $ LDA, TAU( P+1 ), C( 1, P+1 ), LDC, DWORK, + $ LDWORK, I ) + WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) + END IF +C + DO 30 I = MIN( K, P ), 1, -1 +C +C Apply H(i) to C(1:n,i:i+m-p-1), from the right. +C Workspace: need N. +C + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, N, M-P, A( I, I ), 1, TAU( I ), + $ C( 1, I ), LDC, DWORK ) + A( I, I ) = AII + 30 CONTINUE +C + ELSE +C + DO 40 I = 1, MIN( K, P ) +C +C Apply H(i) to C(1:n,i:i+m-p-1), from the right. +C Workspace: need N. +C + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, N, M-P, A( I, I ), 1, TAU( I ), + $ C( 1, I ), LDC, DWORK ) + A( I, I ) = AII + 40 CONTINUE +C + IF ( P.LE.MIN( M, K ) ) THEN +C +C Apply H(i) to C, i = p+1:k, from the right. +C Workspace: need N; prefer N*NB. +C + CALL DORMQR( SIDE, TRANS, N, M-P, K-P, A( P+1, P+1 ), + $ LDA, TAU( P+1 ), C( 1, P+1 ), LDC, DWORK, + $ LDWORK, I ) + WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) + END IF +C + END IF + END IF +C + DWORK( 1 ) = WRKOPT + RETURN +C +C *** Last line of MB04IY *** + END diff --git a/mex/sources/libslicot/MB04IZ.f b/mex/sources/libslicot/MB04IZ.f new file mode 100644 index 000000000..c9654a6a5 --- /dev/null +++ b/mex/sources/libslicot/MB04IZ.f @@ -0,0 +1,282 @@ + SUBROUTINE MB04IZ( N, M, P, L, A, LDA, B, LDB, TAU, ZWORK, LZWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a QR factorization of an n-by-m matrix A (A = Q * R), +C having a p-by-min(p,m) zero triangle in the lower left-hand side +C corner, as shown below, for n = 8, m = 7, and p = 2: +C +C [ x x x x x x x ] +C [ x x x x x x x ] +C [ x x x x x x x ] +C [ x x x x x x x ] +C A = [ x x x x x x x ], +C [ x x x x x x x ] +C [ 0 x x x x x x ] +C [ 0 0 x x x x x ] +C +C and optionally apply the transformations to an n-by-l matrix B +C (from the left). The problem structure is exploited. This +C computation is useful, for instance, in combined measurement and +C time update of one iteration of the time-invariant Kalman filter +C (square root information filter). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of rows of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrix A. M >= 0. +C +C P (input) INTEGER +C The order of the zero triagle. P >= 0. +C +C L (input) INTEGER +C The number of columns of the matrix B. L >= 0. +C +C A (input/output) COMPLEX*16 array, dimension (LDA,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix A. The elements corresponding to the +C zero P-by-MIN(P,M) lower trapezoidal/triangular part +C (if P > 0) are not referenced. +C On exit, the elements on and above the diagonal of this +C array contain the MIN(N,M)-by-M upper trapezoidal matrix +C R (R is upper triangular, if N >= M) of the QR +C factorization, and the relevant elements below the +C diagonal contain the trailing components (the vectors v, +C see Method) of the elementary reflectors used in the +C factorization. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) COMPLEX*16 array, dimension (LDB,L) +C On entry, the leading N-by-L part of this array must +C contain the matrix B. +C On exit, the leading N-by-L part of this array contains +C the updated matrix B. +C If L = 0, this array is not referenced. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,N) if L > 0; +C LDB >= 1 if L = 0. +C +C TAU (output) COMPLEX*16 array, dimension MIN(N,M) +C The scalar factors of the elementary reflectors used. +C +C Workspace +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C On exit, if INFO = 0, ZWORK(1) returns the optimal value +C of LZWORK. +C +C LZWORK The length of the array ZWORK. +C LZWORK >= MAX(1,M-1,M-P,L). +C For optimum performance LZWORK should be larger. +C +C If LZWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C ZWORK array, returns this value as the first entry of +C the ZWORK array, and no error message related to LZWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine uses min(N,M) Householder transformations exploiting +C the zero pattern of the matrix. A Householder matrix has the form +C +C ( 1 ), +C H = I - tau *u *u', u = ( v ) +C i i i i i ( i) +C +C where v is an (N-P+I-2)-vector. The components of v are stored +C i i +C in the i-th column of A, beginning from the location i+1, and +C tau is stored in TAU(i). +C i +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009. +C +C KEYWORDS +C +C Elementary reflector, QR factorization, unitary transformation. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +C .. Scalar Arguments .. + INTEGER INFO, L, LDA, LDB, LZWORK, M, N, P +C .. Array Arguments .. + COMPLEX*16 A(LDA,*), B(LDB,*), TAU(*), ZWORK(*) +C .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, NB, WRKOPT + COMPLEX*16 FIRST +C .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +C .. External Subroutines .. + EXTERNAL XERBLA, ZGEQRF, ZLARF, ZLARFG, ZUNMQR +C .. Intrinsic Functions .. + INTRINSIC DCONJG, INT, MAX, MIN +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LQUERY = ( LZWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( L.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.1 .OR. ( L.GT.0 .AND. LDB.LT.N ) ) THEN + INFO = -8 + ELSE + I = MAX( 1, M - 1, M - P, L ) + IF( LQUERY ) THEN + IF( M.GT.P ) THEN + NB = ILAENV( 1, 'ZGEQRF', ' ', N-P, M-P, -1, -1 ) + WRKOPT = MAX( I, ( M - P )*NB ) + IF ( L.GT.0 ) THEN + NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', N-P, L, + $ MIN(N,M)-P, -1 ) ) + WRKOPT = MAX( WRKOPT, MAX( 1, L )*NB ) + END IF + END IF + ELSE IF( LZWORK.LT.I ) THEN + INFO = -11 + END IF + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB04IZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + ZWORK(1) = WRKOPT + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( M, N ).EQ.0 ) THEN + ZWORK(1) = ONE + RETURN + ELSE IF( N.LE.P+1 ) THEN + DO 5 I = 1, MIN( N, M ) + TAU(I) = ZERO + 5 CONTINUE + ZWORK(1) = ONE + RETURN + END IF +C +C Annihilate the subdiagonal elements of A and apply the +C transformations to B, if L > 0. +C Workspace: need MAX(M-1,L). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of complex workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + DO 10 I = 1, MIN( P, M ) +C +C Exploit the structure of the I-th column of A. +C + CALL ZLARFG( N-P, A(I,I), A(I+1,I), 1, TAU(I) ) + IF( TAU(I).NE.ZERO ) THEN +C + FIRST = A(I,I) + A(I,I) = ONE +C + IF ( I.LT.M ) CALL ZLARF( 'Left', N-P, M-I, A(I,I), 1, + $ DCONJG( TAU(I) ), A(I,I+1), LDA, + $ ZWORK ) + IF ( L.GT.0 ) CALL ZLARF( 'Left', N-P, L, A(I,I), 1, + $ DCONJG( TAU(I) ), B(I,1), LDB, + $ ZWORK ) +C + A(I,I) = FIRST + END IF + 10 CONTINUE +C + WRKOPT = MAX( 1, M - 1, L ) +C +C Fast QR factorization of the remaining right submatrix, if any. +C Workspace: need M-P; prefer (M-P)*NB. +C + IF( M.GT.P ) THEN + CALL ZGEQRF( N-P, M-P, A(P+1,P+1), LDA, TAU(P+1), ZWORK, + $ LZWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) +C + IF ( L.GT.0 ) THEN +C +C Apply the transformations to B. +C Workspace: need L; prefer L*NB. +C + CALL ZUNMQR( 'Left', 'Conjugate', N-P, L, MIN(N,M)-P, + $ A(P+1,P+1), LDA, TAU(P+1), B(P+1,1), LDB, + $ ZWORK, LZWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) + END IF + END IF +C + ZWORK(1) = WRKOPT + RETURN +C *** Last line of MB04IZ *** + END diff --git a/mex/sources/libslicot/MB04JD.f b/mex/sources/libslicot/MB04JD.f new file mode 100644 index 000000000..8dc1a3b9b --- /dev/null +++ b/mex/sources/libslicot/MB04JD.f @@ -0,0 +1,248 @@ + SUBROUTINE MB04JD( N, M, P, L, A, LDA, B, LDB, TAU, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute an LQ factorization of an n-by-m matrix A (A = L * Q), +C having a min(n,p)-by-p zero triangle in the upper right-hand side +C corner, as shown below, for n = 8, m = 7, and p = 2: +C +C [ x x x x x 0 0 ] +C [ x x x x x x 0 ] +C [ x x x x x x x ] +C [ x x x x x x x ] +C A = [ x x x x x x x ], +C [ x x x x x x x ] +C [ x x x x x x x ] +C [ x x x x x x x ] +C +C and optionally apply the transformations to an l-by-m matrix B +C (from the right). The problem structure is exploited. This +C computation is useful, for instance, in combined measurement and +C time update of one iteration of the time-invariant Kalman filter +C (square root covariance filter). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of rows of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrix A. M >= 0. +C +C P (input) INTEGER +C The order of the zero triagle. P >= 0. +C +C L (input) INTEGER +C The number of rows of the matrix B. L >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix A. The elements corresponding to the +C zero MIN(N,P)-by-P upper trapezoidal/triangular part +C (if P > 0) are not referenced. +C On exit, the elements on and below the diagonal of this +C array contain the N-by-MIN(N,M) lower trapezoidal matrix +C L (L is lower triangular, if N <= M) of the LQ +C factorization, and the relevant elements above the +C diagonal contain the trailing components (the vectors v, +C see Method) of the elementary reflectors used in the +C factorization. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the matrix B. +C On exit, the leading L-by-M part of this array contains +C the updated matrix B. +C If L = 0, this array is not referenced. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,L). +C +C TAU (output) DOUBLE PRECISION array, dimension MIN(N,M) +C The scalar factors of the elementary reflectors used. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK The length of the array DWORK. +C LDWORK >= MAX(1,N-1,N-P,L). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine uses min(N,M) Householder transformations exploiting +C the zero pattern of the matrix. A Householder matrix has the form +C +C ( 1 ), +C H = I - tau *u *u', u = ( v ) +C i i i i i ( i) +C +C where v is an (M-P+I-2)-vector. The components of v are stored +C i i +C in the i-th row of A, beginning from the location i+1, and tau +C i +C is stored in TAU(i). +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary reflector, LQ factorization, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, L, LDA, LDB, LDWORK, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION FIRST, WRKOPT +C .. External Subroutines .. + EXTERNAL DGELQF, DLARF, DLARFG, DORMLQ, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( L.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, L ) ) THEN + INFO = -8 + ELSE IF( LDWORK.LT.MAX( 1, N - 1, N - P, L ) ) THEN + INFO = -11 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB04JD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( M, N ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + ELSE IF( M.LE.P+1 ) THEN + DO 5 I = 1, MIN( N, M ) + TAU(I) = ZERO + 5 CONTINUE + DWORK(1) = ONE + RETURN + END IF +C +C Annihilate the superdiagonal elements of A and apply the +C transformations to B, if L > 0. +C Workspace: need MAX(N-1,L). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + DO 10 I = 1, MIN( N, P ) +C +C Exploit the structure of the I-th row of A. +C + CALL DLARFG( M-P, A(I,I), A(I,I+1), LDA, TAU(I) ) + IF( TAU(I).NE.ZERO ) THEN +C + FIRST = A(I,I) + A(I,I) = ONE +C + IF ( I.LT.N ) CALL DLARF( 'Right', N-I, M-P, A(I,I), LDA, + $ TAU(I), A(I+1,I), LDA, DWORK ) + IF ( L.GT.0 ) CALL DLARF( 'Right', L, M-P, A(I,I), LDA, + $ TAU(I), B(1,I), LDB, DWORK ) +C + A(I,I) = FIRST + END IF + 10 CONTINUE +C + WRKOPT = MAX( ONE, DBLE( N - 1 ), DBLE( L ) ) +C +C Fast LQ factorization of the remaining trailing submatrix, if any. +C Workspace: need N-P; prefer (N-P)*NB. +C + IF( N.GT.P ) THEN + CALL DGELQF( N-P, M-P, A(P+1,P+1), LDA, TAU(P+1), DWORK, + $ LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, DWORK(1) ) +C + IF ( L.GT.0 ) THEN +C +C Apply the transformations to B. +C Workspace: need L; prefer L*NB. +C + CALL DORMLQ( 'Right', 'Transpose', L, M-P, MIN(N,M)-P, + $ A(P+1,P+1), LDA, TAU(P+1), B(1,P+1), LDB, + $ DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, DWORK(1) ) + END IF + END IF +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of MB04JD *** + END diff --git a/mex/sources/libslicot/MB04KD.f b/mex/sources/libslicot/MB04KD.f new file mode 100644 index 000000000..adcdcb6f9 --- /dev/null +++ b/mex/sources/libslicot/MB04KD.f @@ -0,0 +1,209 @@ + SUBROUTINE MB04KD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, + $ TAU, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate a QR factorization of the first block column and +C apply the orthogonal transformations (from the left) also to the +C second block column of a structured matrix, as follows +C _ +C [ R 0 ] [ R C ] +C Q' * [ ] = [ ] +C [ A B ] [ 0 D ] +C _ +C where R and R are upper triangular. The matrix A can be full or +C upper trapezoidal/triangular. The problem structure is exploited. +C This computation is useful, for instance, in combined measurement +C and time update of one iteration of the Kalman filter (square +C root information filter). +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Indicates if the matrix A is or not triangular as follows: +C = 'U': Matrix A is upper trapezoidal/triangular; +C = 'F': Matrix A is full. +C +C Input/Output Parameters +C +C N (input) INTEGER _ +C The order of the matrices R and R. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrices B, C and D. M >= 0. +C +C P (input) INTEGER +C The number of rows of the matrices A, B and D. P >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix R. +C On exit, the leading N-by-N upper triangular part of this +C _ +C array contains the upper triangular matrix R. +C The strict lower triangular part of this array is not +C referenced. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, if UPLO = 'F', the leading P-by-N part of this +C array must contain the matrix A. If UPLO = 'U', the +C leading MIN(P,N)-by-N part of this array must contain the +C upper trapezoidal (upper triangular if P >= N) matrix A, +C and the elements below the diagonal are not referenced. +C On exit, the leading P-by-N part (upper trapezoidal or +C triangular, if UPLO = 'U') of this array contains the +C trailing components (the vectors v, see Method) of the +C elementary reflectors used in the factorization. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,P). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading P-by-M part of this array must +C contain the matrix B. +C On exit, the leading P-by-M part of this array contains +C the computed matrix D. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,P). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,M) +C The leading N-by-M part of this array contains the +C computed matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The scalar factors of the elementary reflectors used. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C METHOD +C +C The routine uses N Householder transformations exploiting the zero +C pattern of the block matrix. A Householder matrix has the form +C +C ( 1 ), +C H = I - tau *u *u', u = ( v ) +C i i i i i ( i) +C +C where v is a P-vector, if UPLO = 'F', or an min(i,P)-vector, if +C i +C UPLO = 'U'. The components of v are stored in the i-th column +C i +C of A, and tau is stored in TAU(i). +C i +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary reflector, QR factorization, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, LDC, LDR, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ R(LDR,*), TAU(*) +C .. Local Scalars .. + LOGICAL LUPLO + INTEGER I, IM +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLARFG, DSCAL +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C + IF( MIN( N, P ).EQ.0 ) + $ RETURN +C + LUPLO = LSAME( UPLO, 'U' ) + IM = P +C + DO 10 I = 1, N +C +C Annihilate the I-th column of A and apply the transformations +C to the entire block matrix, exploiting its structure. +C + IF( LUPLO ) IM = MIN( I, P ) + CALL DLARFG( IM+1, R(I,I), A(1,I), 1, TAU(I) ) + IF( TAU(I).NE.ZERO ) THEN +C +C [ R(I,I+1:N) 0 ] +C [ w C(I,:) ] := [ 1 v' ] * [ ] +C [ A(1:IM,I+1:N) B(1:IM,:) ] +C + IF( I.LT.N ) THEN + CALL DCOPY( N-I, R(I,I+1), LDR, DWORK, 1 ) + CALL DGEMV( 'Transpose', IM, N-I, ONE, A(1,I+1), LDA, + $ A(1,I), 1, ONE, DWORK, 1 ) + END IF + CALL DGEMV( 'Transpose', IM, M, ONE, B, LDB, A(1,I), 1, + $ ZERO, C(I,1), LDC ) +C +C [ R(I,I+1:N) C(I,:) ] [ R(I,I+1:N) 0 ] +C [ ] := [ ] +C [ A(1:IM,I+1:N) D(1:IM,:) ] [ A(1:IM,I+1:N) B(1:IM,:) ] +C +C [ 1 ] +C - tau * [ ] * [ w C(I,:) ] +C [ v ] +C + IF( I.LT.N ) THEN + CALL DAXPY( N-I, -TAU(I), DWORK, 1, R(I,I+1), LDR ) + CALL DGER( IM, N-I, -TAU(I), A(1,I), 1, DWORK, 1, + $ A(1,I+1), LDA ) + END IF + CALL DSCAL( M, -TAU(I), C(I,1), LDC ) + CALL DGER( IM, M, ONE, A(1,I), 1, C(I,1), LDC, B, LDB ) + END IF + 10 CONTINUE +C + RETURN +C *** Last line of MB04KD *** + END diff --git a/mex/sources/libslicot/MB04LD.f b/mex/sources/libslicot/MB04LD.f new file mode 100644 index 000000000..7931437f5 --- /dev/null +++ b/mex/sources/libslicot/MB04LD.f @@ -0,0 +1,209 @@ + SUBROUTINE MB04LD( UPLO, N, M, P, L, LDL, A, LDA, B, LDB, C, LDC, + $ TAU, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate an LQ factorization of the first block row and apply +C the orthogonal transformations (from the right) also to the second +C block row of a structured matrix, as follows +C _ +C [ L A ] [ L 0 ] +C [ ]*Q = [ ] +C [ 0 B ] [ C D ] +C _ +C where L and L are lower triangular. The matrix A can be full or +C lower trapezoidal/triangular. The problem structure is exploited. +C This computation is useful, for instance, in combined measurement +C and time update of one iteration of the Kalman filter (square +C root covariance filter). +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Indicates if the matrix A is or not triangular as follows: +C = 'L': Matrix A is lower trapezoidal/triangular; +C = 'F': Matrix A is full. +C +C Input/Output Parameters +C +C N (input) INTEGER _ +C The order of the matrices L and L. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrices A, B and D. M >= 0. +C +C P (input) INTEGER +C The number of rows of the matrices B, C and D. P >= 0. +C +C L (input/output) DOUBLE PRECISION array, dimension (LDL,N) +C On entry, the leading N-by-N lower triangular part of this +C array must contain the lower triangular matrix L. +C On exit, the leading N-by-N lower triangular part of this +C _ +C array contains the lower triangular matrix L. +C The strict upper triangular part of this array is not +C referenced. +C +C LDL INTEGER +C The leading dimension of array L. LDL >= MAX(1,N). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) +C On entry, if UPLO = 'F', the leading N-by-M part of this +C array must contain the matrix A. If UPLO = 'L', the +C leading N-by-MIN(N,M) part of this array must contain the +C lower trapezoidal (lower triangular if N <= M) matrix A, +C and the elements above the diagonal are not referenced. +C On exit, the leading N-by-M part (lower trapezoidal or +C triangular, if UPLO = 'L') of this array contains the +C trailing components (the vectors v, see Method) of the +C elementary reflectors used in the factorization. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading P-by-M part of this array must +C contain the matrix B. +C On exit, the leading P-by-M part of this array contains +C the computed matrix D. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,P). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array contains the +C computed matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The scalar factors of the elementary reflectors used. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C METHOD +C +C The routine uses N Householder transformations exploiting the zero +C pattern of the block matrix. A Householder matrix has the form +C +C ( 1 ), +C H = I - tau *u *u', u = ( v ) +C i i i i i ( i) +C +C where v is an M-vector, if UPLO = 'F', or an min(i,M)-vector, if +C i +C UPLO = 'L'. The components of v are stored in the i-th row of A, +C i +C and tau is stored in TAU(i). +C i +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary reflector, LQ factorization, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, LDC, LDL, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ L(LDL,*), TAU(*) +C .. Local Scalars .. + LOGICAL LUPLO + INTEGER I, IM +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLARFG, DSCAL +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C + IF( MIN( M, N ).EQ.0 ) + $ RETURN +C + LUPLO = LSAME( UPLO, 'L' ) + IM = M +C + DO 10 I = 1, N +C +C Annihilate the I-th row of A and apply the transformations to +C the entire block matrix, exploiting its structure. +C + IF( LUPLO ) IM = MIN( I, M ) + CALL DLARFG( IM+1, L(I,I), A(I,1), LDA, TAU(I) ) + IF( TAU(I).NE.ZERO ) THEN +C +C [ w ] [ L(I+1:N,I) A(I+1:N,1:IM) ] [ 1 ] +C [ ] := [ ] * [ ] +C [ C(:,I) ] [ 0 B(:,1:IM) ] [ v ] +C + IF( I.LT.N ) THEN + CALL DCOPY( N-I, L(I+1,I), 1, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, IM, ONE, A(I+1,1), LDA, + $ A(I,1), LDA, ONE, DWORK, 1 ) + END IF + CALL DGEMV( 'No transpose', P, IM, ONE, B, LDB, A(I,1), + $ LDA, ZERO, C(1,I), 1 ) +C +C [ L(I+1:N,I) A(I+1:N,1:IM) ] [ L(I+1:N,I) A(I+1:N,1:IM) ] +C [ ] := [ ] +C [ C(:,I) D(:,1:IM) ] [ 0 B(:,1:IM) ] +C +C [ w ] +C - tau * [ ] * [ 1 , v'] +C [ C(:,I) ] +C + IF( I.LT.N ) THEN + CALL DAXPY( N-I, -TAU(I), DWORK, 1, L(I+1,I), 1 ) + CALL DGER( N-I, IM, -TAU(I), DWORK, 1, A(I,1), LDA, + $ A(I+1,1), LDA ) + END IF + CALL DSCAL( P, -TAU(I), C(1,I), 1 ) + CALL DGER( P, IM, ONE, C(1,I), 1, A(I,1), LDA, B, LDB ) + END IF + 10 CONTINUE +C + RETURN +C *** Last line of MB04LD *** + END diff --git a/mex/sources/libslicot/MB04MD.f b/mex/sources/libslicot/MB04MD.f new file mode 100644 index 000000000..8a9055af2 --- /dev/null +++ b/mex/sources/libslicot/MB04MD.f @@ -0,0 +1,290 @@ + SUBROUTINE MB04MD( N, MAXRED, A, LDA, SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the 1-norm of a general real matrix A by balancing. +C This involves diagonal similarity transformations applied +C iteratively to A to make the rows and columns as close in norm as +C possible. +C +C This routine can be used instead LAPACK Library routine DGEBAL, +C when no reduction of the 1-norm of the matrix is possible with +C DGEBAL, as for upper triangular matrices. LAPACK Library routine +C DGEBAK, with parameters ILO = 1, IHI = N, and JOB = 'S', should +C be used to apply the backward transformation. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C MAXRED (input/output) DOUBLE PRECISION +C On entry, the maximum allowed reduction in the 1-norm of +C A (in an iteration) if zero rows or columns are +C encountered. +C If MAXRED > 0.0, MAXRED must be larger than one (to enable +C the norm reduction). +C If MAXRED <= 0.0, then the value 10.0 for MAXRED is +C used. +C On exit, if the 1-norm of the given matrix A is non-zero, +C the ratio between the 1-norm of the given matrix and the +C 1-norm of the balanced matrix. Usually, this ratio will be +C larger than one, but it can sometimes be one, or even less +C than one (for instance, for some companion matrices). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the input matrix A. +C On exit, the leading N-by-N part of this array contains +C the balanced matrix. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C SCALE (output) DOUBLE PRECISION array, dimension (N) +C The scaling factors applied to A. If D(j) is the scaling +C factor applied to row and column j, then SCALE(j) = D(j), +C for j = 1,...,N. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Balancing consists of applying a diagonal similarity +C transformation inv(D) * A * D to make the 1-norms of each row +C of A and its corresponding column nearly equal. +C +C Information about the diagonal matrix D is returned in the vector +C SCALE. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. +C Supersedes Release 2.0 routine MB04AD by T.W.C. Williams, +C Kingston Polytechnic, United Kingdom, October 1984. +C This subroutine is based on LAPACK routine DGEBAL, and routine +C BALABC (A. Varga, German Aerospace Research Establishment, DLR). +C +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Balancing, eigenvalue, matrix algebra, matrix operations, +C similarity transformation. +C +C ********************************************************************* +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION SCLFAC + PARAMETER ( SCLFAC = 1.0D+1 ) + DOUBLE PRECISION FACTOR, MAXR + PARAMETER ( FACTOR = 0.95D+0, MAXR = 10.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, N + DOUBLE PRECISION MAXRED +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), SCALE( * ) +C .. +C .. Local Scalars .. + LOGICAL NOCONV + INTEGER I, ICA, IRA, J + DOUBLE PRECISION ANORM, C, CA, F, G, MAXNRM, R, RA, S, SFMAX1, + $ SFMAX2, SFMIN1, SFMIN2, SRED +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, IDAMAX +C .. +C .. External Subroutines .. + EXTERNAL DSCAL, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the scalar input arguments. +C + INFO = 0 +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( MAXRED.GT.ZERO .AND. MAXRED.LT.ONE ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04MD', -INFO ) + RETURN + END IF +C + IF( N.EQ.0 ) + $ RETURN +C + DO 10 I = 1, N + SCALE( I ) = ONE + 10 CONTINUE +C +C Compute the 1-norm of matrix A and exit if it is zero. +C + ANORM = DLANGE( '1-norm', N, N, A, LDA, SCALE ) + IF( ANORM.EQ.ZERO ) + $ RETURN +C +C Set some machine parameters and the maximum reduction in the +C 1-norm of A if zero rows or columns are encountered. +C + SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) + SFMAX1 = ONE / SFMIN1 + SFMIN2 = SFMIN1*SCLFAC + SFMAX2 = ONE / SFMIN2 +C + SRED = MAXRED + IF( SRED.LE.ZERO ) SRED = MAXR +C + MAXNRM = MAX( ANORM/SRED, SFMIN1 ) +C +C Balance the matrix. +C +C Iterative loop for norm reduction. +C + 20 CONTINUE + NOCONV = .FALSE. +C + DO 80 I = 1, N + C = ZERO + R = ZERO +C + DO 30 J = 1, N + IF( J.EQ.I ) + $ GO TO 30 + C = C + ABS( A( J, I ) ) + R = R + ABS( A( I, J ) ) + 30 CONTINUE + ICA = IDAMAX( N, A( 1, I ), 1 ) + CA = ABS( A( ICA, I ) ) + IRA = IDAMAX( N, A( I, 1 ), LDA ) + RA = ABS( A( I, IRA ) ) +C +C Special case of zero C and/or R. +C + IF( C.EQ.ZERO .AND. R.EQ.ZERO ) + $ GO TO 80 + IF( C.EQ.ZERO ) THEN + IF( R.LE.MAXNRM) + $ GO TO 80 + C = MAXNRM + END IF + IF( R.EQ.ZERO ) THEN + IF( C.LE.MAXNRM ) + $ GO TO 80 + R = MAXNRM + END IF +C +C Guard against zero C or R due to underflow. +C + G = R / SCLFAC + F = ONE + S = C + R + 40 CONTINUE + IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. + $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 50 + F = F*SCLFAC + C = C*SCLFAC + CA = CA*SCLFAC + R = R / SCLFAC + G = G / SCLFAC + RA = RA / SCLFAC + GO TO 40 +C + 50 CONTINUE + G = C / SCLFAC + 60 CONTINUE + IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. + $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 70 + F = F / SCLFAC + C = C / SCLFAC + G = G / SCLFAC + CA = CA / SCLFAC + R = R*SCLFAC + RA = RA*SCLFAC + GO TO 60 +C +C Now balance. +C + 70 CONTINUE + IF( ( C+R ).GE.FACTOR*S ) + $ GO TO 80 + IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN + IF( F*SCALE( I ).LE.SFMIN1 ) + $ GO TO 80 + END IF + IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN + IF( SCALE( I ).GE.SFMAX1 / F ) + $ GO TO 80 + END IF + G = ONE / F + SCALE( I ) = SCALE( I )*F + NOCONV = .TRUE. +C + CALL DSCAL( N, G, A( I, 1 ), LDA ) + CALL DSCAL( N, F, A( 1, I ), 1 ) +C + 80 CONTINUE +C + IF( NOCONV ) + $ GO TO 20 +C +C Set the norm reduction parameter. +C + MAXRED = ANORM/DLANGE( '1-norm', N, N, A, LDA, SCALE ) +C + RETURN +C *** End of MB04MD *** + END diff --git a/mex/sources/libslicot/MB04ND.f b/mex/sources/libslicot/MB04ND.f new file mode 100644 index 000000000..2a7e0725e --- /dev/null +++ b/mex/sources/libslicot/MB04ND.f @@ -0,0 +1,257 @@ + SUBROUTINE MB04ND( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, + $ TAU, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate an RQ factorization of the first block row and +C apply the orthogonal transformations (from the right) also to the +C second block row of a structured matrix, as follows +C _ +C [ A R ] [ 0 R ] +C [ ] * Q' = [ _ _ ] +C [ C B ] [ C B ] +C _ +C where R and R are upper triangular. The matrix A can be full or +C upper trapezoidal/triangular. The problem structure is exploited. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Indicates if the matrix A is or not triangular as follows: +C = 'U': Matrix A is upper trapezoidal/triangular; +C = 'F': Matrix A is full. +C +C Input/Output Parameters +C +C N (input) INTEGER _ +C The order of the matrices R and R. N >= 0. +C +C M (input) INTEGER +C The number of rows of the matrices B and C. M >= 0. +C +C P (input) INTEGER +C The number of columns of the matrices A and C. P >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix R. +C On exit, the leading N-by-N upper triangular part of this +C _ +C array contains the upper triangular matrix R. +C The strict lower triangular part of this array is not +C referenced. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,P) +C On entry, if UPLO = 'F', the leading N-by-P part of this +C array must contain the matrix A. For UPLO = 'U', if +C N <= P, the upper triangle of the subarray A(1:N,P-N+1:P) +C must contain the N-by-N upper triangular matrix A, and if +C N >= P, the elements on and above the (N-P)-th subdiagonal +C must contain the N-by-P upper trapezoidal matrix A. +C On exit, if UPLO = 'F', the leading N-by-P part of this +C array contains the trailing components (the vectors v, see +C METHOD) of the elementary reflectors used in the +C factorization. If UPLO = 'U', the upper triangle of the +C subarray A(1:N,P-N+1:P) (if N <= P), or the elements on +C and above the (N-P)-th subdiagonal (if N >= P), contain +C the trailing components (the vectors v, see METHOD) of the +C elementary reflectors used in the factorization. +C The remaining elements are not referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix B. +C On exit, the leading M-by-N part of this array contains +C _ +C the computed matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,P) +C On entry, the leading M-by-P part of this array must +C contain the matrix C. +C On exit, the leading M-by-P part of this array contains +C _ +C the computed matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The scalar factors of the elementary reflectors used. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (MAX(N-1,M)) +C +C METHOD +C +C The routine uses N Householder transformations exploiting the zero +C pattern of the block matrix. A Householder matrix has the form +C +C ( 1 ) +C H = I - tau *u *u', u = ( v ), +C i i i i i ( i) +C +C where v is a P-vector, if UPLO = 'F', or a min(N-i+1,P)-vector, +C i +C if UPLO = 'U'. The components of v are stored in the i-th row +C i +C of A, and tau is stored in TAU(i), i = N,N-1,...,1. +C i +C In-line code for applying Householder transformations is used +C whenever possible (see MB04NY routine). +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary reflector, RQ factorization, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, LDC, LDR, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ R(LDR,*), TAU(*) +C .. Local Scalars .. + LOGICAL LUPLO + INTEGER I, IM, IP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARFG, MB04NY +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked. +C + IF( MIN( N, P ).EQ.0 ) + $ RETURN +C + LUPLO = LSAME( UPLO, 'U' ) + IF ( LUPLO ) THEN +C + DO 10 I = N, 1, -1 +C +C Annihilate the I-th row of A and apply the transformations +C to the entire block matrix, exploiting its structure. +C + IM = MIN( N-I+1, P ) + IP = MAX( P-N+I, 1 ) + CALL DLARFG( IM+1, R(I,I), A(I,IP), LDA, TAU(I) ) +C +C Compute +C [ 1 ] +C w := [ R(1:I-1,I) A(1:I-1,IP:P) ] * [ ], +C [ v ] +C +C [ R(1:I-1,I) A(1:I-1,IP:P) ] = +C [ R(1:I-1,I) A(1:I-1,IP:P) ] - tau * w * [ 1 v' ]. +C + IF ( I.GT.0 ) +C + $ CALL MB04NY( I-1, IM, A(I,IP), LDA, TAU(I), R(1,I), LDR, + $ A(1,IP), LDA, DWORK ) +C +C Compute +C [ 1 ] +C w := [ B(:,I) C(:,IP:P) ] * [ ], +C [ v ] +C +C [ B(:,I) C(:,IP:P) ] = [ B(:,I) C(:,IP:P) ] - +C tau * w * [ 1 v' ]. +C + IF ( M.GT.0 ) + $ CALL MB04NY( M, IM, A(I,IP), LDA, TAU(I), B(1,I), LDB, + $ C(1,IP), LDC, DWORK ) + 10 CONTINUE +C + ELSE +C + DO 20 I = N, 2 , -1 +C +C Annihilate the I-th row of A and apply the transformations +C to the first block row, exploiting its structure. +C + CALL DLARFG( P+1, R(I,I), A(I,1), LDA, TAU(I) ) +C +C Compute +C [ 1 ] +C w := [ R(1:I-1,I) A(1:I-1,:) ] * [ ], +C [ v ] +C +C [ R(1:I-1,I) A(1:I-1,:) ] = [ R(1:I-1,I) A(1:I-1,:) ] - +C tau * w * [ 1 v' ]. +C + CALL MB04NY( I-1, P, A(I,1), LDA, TAU(I), R(1,I), LDR, A, + $ LDA, DWORK ) + 20 CONTINUE +C + CALL DLARFG( P+1, R(1,1), A(1,1), LDA, TAU(1) ) + IF ( M.GT.0 ) THEN +C +C Apply the transformations to the second block row. +C + DO 30 I = N, 1, -1 +C +C Compute +C [ 1 ] +C w := [ B(:,I) C ] * [ ], +C [ v ] +C +C [ B(:,I) C ] = [ B(:,I) C ] - tau * w * [ 1 v' ]. +C + CALL MB04NY( M, P, A(I,1), LDA, TAU(I), B(1,I), LDB, C, + $ LDC, DWORK ) + 30 CONTINUE +C + END IF + END IF + RETURN +C *** Last line of MB04ND *** + END diff --git a/mex/sources/libslicot/MB04NY.f b/mex/sources/libslicot/MB04NY.f new file mode 100644 index 000000000..4e884454c --- /dev/null +++ b/mex/sources/libslicot/MB04NY.f @@ -0,0 +1,437 @@ + SUBROUTINE MB04NY( M, N, V, INCV, TAU, A, LDA, B, LDB, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply a real elementary reflector H to a real m-by-(n+1) +C matrix C = [ A B ], from the right, where A has one column. H is +C represented in the form +C ( 1 ) +C H = I - tau * u *u', u = ( ), +C ( v ) +C where tau is a real scalar and v is a real n-vector. +C +C If tau = 0, then H is taken to be the unit matrix. +C +C In-line code is used if H has order < 11. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices A and B. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix B. N >= 0. +C +C V (input) DOUBLE PRECISION array, dimension +C (1+(N-1)*ABS( INCV )) +C The vector v in the representation of H. +C +C INCV (input) INTEGER +C The increment between the elements of v. INCV <> 0. +C +C TAU (input) DOUBLE PRECISION +C The scalar factor of the elementary reflector H. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,1) +C On entry, the leading M-by-1 part of this array must +C contain the matrix A. +C On exit, the leading M-by-1 part of this array contains +C the updated matrix A (the first column of C * H). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix B. +C On exit, the leading M-by-N part of this array contains +C the updated matrix B (the last n columns of C * H). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (M) +C DWORK is not referenced if H has order less than 11. +C +C METHOD +C +C The routine applies the elementary reflector H, taking the special +C structure of C into account. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998. +C Based on LAPACK routines DLARFX and DLATZM. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, elementary reflector, orthogonal +C transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INCV, LDA, LDB, M, N + DOUBLE PRECISION TAU +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), V( * ) +C .. Local Scalars .. + INTEGER IV, J + DOUBLE PRECISION SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, V1, V2, + $ V3, V4, V5, V6, V7, V8, V9 +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER +C +C .. Executable Statements .. +C + IF( TAU.EQ.ZERO ) + $ RETURN +C +C Form C * H, where H has order n+1. +C + GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, + $ 170, 190 ) N+1 +C +C Code for general N. Compute +C +C w := C*u, C := C - tau * w * u'. +C + CALL DCOPY( M, A, 1, DWORK, 1 ) + CALL DGEMV( 'No transpose', M, N, ONE, B, LDB, V, INCV, ONE, + $ DWORK, 1 ) + CALL DAXPY( M, -TAU, DWORK, 1, A, 1 ) + CALL DGER( M, N, -TAU, DWORK, 1, V, INCV, B, LDB ) + GO TO 210 + 10 CONTINUE +C +C Special code for 1 x 1 Householder +C + T1 = ONE - TAU + DO 20 J = 1, M + A( J, 1 ) = T1*A( J, 1 ) + 20 CONTINUE + GO TO 210 + 30 CONTINUE +C +C Special code for 2 x 2 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + DO 40 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + 40 CONTINUE + GO TO 210 + 50 CONTINUE +C +C Special code for 3 x 3 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + DO 60 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + 60 CONTINUE + GO TO 210 + 70 CONTINUE +C +C Special code for 4 x 4 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + DO 80 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + 80 CONTINUE + GO TO 210 + 90 CONTINUE +C +C Special code for 5 x 5 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + DO 100 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + 100 CONTINUE + GO TO 210 + 110 CONTINUE +C +C Special code for 6 x 6 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + IV = IV + INCV + V5 = V( IV ) + T5 = TAU*V5 + DO 120 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + V5*B( J, 5 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + B( J, 5 ) = B( J, 5 ) - SUM*T5 + 120 CONTINUE + GO TO 210 + 130 CONTINUE +C +C Special code for 7 x 7 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + IV = IV + INCV + V5 = V( IV ) + T5 = TAU*V5 + IV = IV + INCV + V6 = V( IV ) + T6 = TAU*V6 + DO 140 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + B( J, 5 ) = B( J, 5 ) - SUM*T5 + B( J, 6 ) = B( J, 6 ) - SUM*T6 + 140 CONTINUE + GO TO 210 + 150 CONTINUE +C +C Special code for 8 x 8 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + IV = IV + INCV + V5 = V( IV ) + T5 = TAU*V5 + IV = IV + INCV + V6 = V( IV ) + T6 = TAU*V6 + IV = IV + INCV + V7 = V( IV ) + T7 = TAU*V7 + DO 160 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + + $ V7*B( J, 7 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + B( J, 5 ) = B( J, 5 ) - SUM*T5 + B( J, 6 ) = B( J, 6 ) - SUM*T6 + B( J, 7 ) = B( J, 7 ) - SUM*T7 + 160 CONTINUE + GO TO 210 + 170 CONTINUE +C +C Special code for 9 x 9 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + IV = IV + INCV + V5 = V( IV ) + T5 = TAU*V5 + IV = IV + INCV + V6 = V( IV ) + T6 = TAU*V6 + IV = IV + INCV + V7 = V( IV ) + T7 = TAU*V7 + IV = IV + INCV + V8 = V( IV ) + T8 = TAU*V8 + DO 180 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + + $ V7*B( J, 7 ) + V8*B( J, 8 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + B( J, 5 ) = B( J, 5 ) - SUM*T5 + B( J, 6 ) = B( J, 6 ) - SUM*T6 + B( J, 7 ) = B( J, 7 ) - SUM*T7 + B( J, 8 ) = B( J, 8 ) - SUM*T8 + 180 CONTINUE + GO TO 210 + 190 CONTINUE +C +C Special code for 10 x 10 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + IV = IV + INCV + V5 = V( IV ) + T5 = TAU*V5 + IV = IV + INCV + V6 = V( IV ) + T6 = TAU*V6 + IV = IV + INCV + V7 = V( IV ) + T7 = TAU*V7 + IV = IV + INCV + V8 = V( IV ) + T8 = TAU*V8 + IV = IV + INCV + V9 = V( IV ) + T9 = TAU*V9 + DO 200 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + + $ V7*B( J, 7 ) + V8*B( J, 8 ) + V9*B( J, 9 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + B( J, 5 ) = B( J, 5 ) - SUM*T5 + B( J, 6 ) = B( J, 6 ) - SUM*T6 + B( J, 7 ) = B( J, 7 ) - SUM*T7 + B( J, 8 ) = B( J, 8 ) - SUM*T8 + B( J, 9 ) = B( J, 9 ) - SUM*T9 + 200 CONTINUE + 210 CONTINUE + RETURN +C *** Last line of MB04NY *** + END diff --git a/mex/sources/libslicot/MB04OD.f b/mex/sources/libslicot/MB04OD.f new file mode 100644 index 000000000..694c81d75 --- /dev/null +++ b/mex/sources/libslicot/MB04OD.f @@ -0,0 +1,257 @@ + SUBROUTINE MB04OD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, + $ TAU, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate a QR factorization of the first block column and +C apply the orthogonal transformations (from the left) also to the +C second block column of a structured matrix, as follows +C _ _ +C [ R B ] [ R B ] +C Q' * [ ] = [ _ ] +C [ A C ] [ 0 C ] +C _ +C where R and R are upper triangular. The matrix A can be full or +C upper trapezoidal/triangular. The problem structure is exploited. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Indicates if the matrix A is or not triangular as follows: +C = 'U': Matrix A is upper trapezoidal/triangular; +C = 'F': Matrix A is full. +C +C Input/Output Parameters +C +C N (input) INTEGER _ +C The order of the matrices R and R. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrices B and C. M >= 0. +C +C P (input) INTEGER +C The number of rows of the matrices A and C. P >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix R. +C On exit, the leading N-by-N upper triangular part of this +C _ +C array contains the upper triangular matrix R. +C The strict lower triangular part of this array is not +C referenced. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, if UPLO = 'F', the leading P-by-N part of this +C array must contain the matrix A. If UPLO = 'U', the +C leading MIN(P,N)-by-N part of this array must contain the +C upper trapezoidal (upper triangular if P >= N) matrix A, +C and the elements below the diagonal are not referenced. +C On exit, the leading P-by-N part (upper trapezoidal or +C triangular, if UPLO = 'U') of this array contains the +C trailing components (the vectors v, see Method) of the +C elementary reflectors used in the factorization. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,P). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix B. +C On exit, the leading N-by-M part of this array contains +C _ +C the computed matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading P-by-M part of this array must +C contain the matrix C. +C On exit, the leading P-by-M part of this array contains +C _ +C the computed matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The scalar factors of the elementary reflectors used. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (MAX(N-1,M)) +C +C METHOD +C +C The routine uses N Householder transformations exploiting the zero +C pattern of the block matrix. A Householder matrix has the form +C +C ( 1 ) +C H = I - tau *u *u', u = ( v ), +C i i i i i ( i) +C +C where v is a P-vector, if UPLO = 'F', or a min(i,P)-vector, if +C i +C UPLO = 'U'. The components of v are stored in the i-th column +C i +C of A, and tau is stored in TAU(i). +C i +C In-line code for applying Householder transformations is used +C whenever possible (see MB04OY routine). +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C +C REVISIONS +C +C Dec. 1997. +C +C KEYWORDS +C +C Elementary reflector, QR factorization, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, LDC, LDR, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ R(LDR,*), TAU(*) +C .. Local Scalars .. + LOGICAL LUPLO + INTEGER I, IM +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARFG, MB04OY +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked. +C + IF( MIN( N, P ).EQ.0 ) + $ RETURN +C + LUPLO = LSAME( UPLO, 'U' ) + IF ( LUPLO ) THEN +C + DO 10 I = 1, N +C +C Annihilate the I-th column of A and apply the +C transformations to the entire block matrix, exploiting +C its structure. +C + IM = MIN( I, P ) + CALL DLARFG( IM+1, R(I,I), A(1,I), 1, TAU(I) ) +C +C Compute +C [ R(I,I+1:N) ] +C w := [ 1 v' ] * [ ], +C [ A(1:IM,I+1:N) ] +C +C [ R(I,I+1:N) ] [ R(I,I+1:N) ] [ 1 ] +C [ ] := [ ] - tau * [ ] * w . +C [ A(1:IM,I+1:N) ] [ A(1:IM,I+1:N) ] [ v ] +C + IF ( N-I.GT.0 ) + $ CALL MB04OY( IM, N-I, A(1,I), TAU(I), R(I,I+1), LDR, + $ A(1,I+1), LDA, DWORK ) +C +C Compute +C [ B(I,:) ] +C w := [ 1 v' ] * [ ], +C [ C(1:IM,:) ] +C +C [ B(I,:) ] [ B(I,:) ] [ 1 ] +C [ ] := [ ] - tau * [ ] * w. +C [ C(1:IM,:) ] [ C(1:IM,:) ] [ v ] +C +C + IF ( M.GT.0 ) + $ CALL MB04OY( IM, M, A(1,I), TAU(I), B(I,1), LDB, C, LDC, + $ DWORK ) + 10 CONTINUE +C + ELSE +C + DO 20 I = 1, N - 1 +C +C Annihilate the I-th column of A and apply the +C transformations to the first block column, exploiting its +C structure. +C + CALL DLARFG( P+1, R(I,I), A(1,I), 1, TAU(I) ) +C +C Compute +C [ R(I,I+1:N) ] +C w := [ 1 v' ] * [ ], +C [ A(:,I+1:N) ] +C +C [ R(I,I+1:N) ] [ R(I,I+1:N) ] [ 1 ] +C [ ] := [ ] - tau * [ ] * w . +C [ A(:,I+1:N) ] [ A(:,I+1:N) ] [ v ] +C + CALL MB04OY( P, N-I, A(1,I), TAU(I), R(I,I+1), LDR, + $ A(1,I+1), LDA, DWORK ) + 20 CONTINUE +C + CALL DLARFG( P+1, R(N,N), A(1,N), 1, TAU(N) ) + IF ( M.GT.0 ) THEN +C +C Apply the transformations to the second block column. +C + DO 30 I = 1, N +C +C Compute +C [ B(I,:) ] +C w := [ 1 v' ] * [ ], +C [ C ] +C +C [ B(I,:) ] [ B(I,:) ] [ 1 ] +C [ ] := [ ] - tau * [ ] * w. +C [ C ] [ C ] [ v ] +C + CALL MB04OY( P, M, A(1,I), TAU(I), B(I,1), LDB, C, LDC, + $ DWORK ) + 30 CONTINUE +C + END IF + END IF + RETURN +C *** Last line of MB04OD *** + END diff --git a/mex/sources/libslicot/MB04OW.f b/mex/sources/libslicot/MB04OW.f new file mode 100644 index 000000000..ab5940943 --- /dev/null +++ b/mex/sources/libslicot/MB04OW.f @@ -0,0 +1,251 @@ + SUBROUTINE MB04OW( M, N, P, A, LDA, T, LDT, X, INCX, B, LDB, + $ C, LDC, D, INCD ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the QR factorization +C +C ( U ) = Q*( R ), where U = ( U1 U2 ), R = ( R1 R2 ), +C ( x' ) ( 0 ) ( 0 T ) ( 0 R3 ) +C +C where U and R are (m+n)-by-(m+n) upper triangular matrices, x is +C an m+n element vector, U1 is m-by-m, T is n-by-n, stored +C separately, and Q is an (m+n+1)-by-(m+n+1) orthogonal matrix. +C +C The matrix ( U1 U2 ) must be supplied in the m-by-(m+n) upper +C trapezoidal part of the array A and this is overwritten by the +C corresponding part ( R1 R2 ) of R. The remaining upper triangular +C part of R, R3, is overwritten on the array T. +C +C The transformations performed are also applied to the (m+n+1)-by-p +C matrix ( B' C' d )' (' denotes transposition), where B, C, and d' +C are m-by-p, n-by-p, and 1-by-p matrices, respectively. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix ( U1 U2 ). M >= 0. +C +C N (input) INTEGER +C The order of the matrix T. N >= 0. +C +C P (input) INTEGER +C The number of columns of the matrices B and C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading M-by-(M+N) upper trapezoidal part of +C this array must contain the upper trapezoidal matrix +C ( U1 U2 ). +C On exit, the leading M-by-(M+N) upper trapezoidal part of +C this array contains the upper trapezoidal matrix ( R1 R2 ). +C The strict lower triangle of A is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C T (input/output) DOUBLE PRECISION array, dimension (LDT,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix T. +C On exit, the leading N-by-N upper triangular part of this +C array contains the upper triangular matrix R3. +C The strict lower triangle of T is not referenced. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= max(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension +C (1+(M+N-1)*INCX), if M+N > 0, or dimension (0), if M+N = 0. +C On entry, the incremented array X must contain the +C vector x. On exit, the content of X is changed. +C +C INCX (input) INTEGER +C Specifies the increment for the elements of X. INCX > 0. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,P) +C On entry, the leading M-by-P part of this array must +C contain the matrix B. +C On exit, the leading M-by-P part of this array contains +C the transformed matrix B. +C If M = 0 or P = 0, this array is not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= max(1,M), if P > 0; +C LDB >= 1, if P = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,P) +C On entry, the leading N-by-P part of this array must +C contain the matrix C. +C On exit, the leading N-by-P part of this array contains +C the transformed matrix C. +C If N = 0 or P = 0, this array is not referenced. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= max(1,N), if P > 0; +C LDC >= 1, if P = 0. +C +C D (input/output) DOUBLE PRECISION array, dimension +C (1+(P-1)*INCD), if P > 0, or dimension (0), if P = 0. +C On entry, the incremented array D must contain the +C vector d. +C On exit, this incremented array contains the transformed +C vector d. +C If P = 0, this array is not referenced. +C +C INCD (input) INTEGER +C Specifies the increment for the elements of D. INCD > 0. +C +C METHOD +C +C Let q = m+n. The matrix Q is formed as a sequence of plane +C rotations in planes (1, q+1), (2, q+1), ..., (q, q+1), the +C rotation in the (j, q+1)th plane, Q(j), being chosen to +C annihilate the jth element of x. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0((M+N)*(M+N+P)) operations and is backward +C stable. +C +C FURTHER COMMENTS +C +C For P = 0, this routine produces the same result as SLICOT Library +C routine MB04OX, but matrix T may not be stored in the array A. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Matrix operations, plane rotations. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INCD, INCX, LDA, LDB, LDC, LDT, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*), T(LDT,*), + $ X(*) +C .. Local Scalars .. + DOUBLE PRECISION CI, SI, TEMP + INTEGER I, IX, MN +C .. External Subroutines .. + EXTERNAL DLARTG, DROT +C +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked. +C + MN = M + N + IF ( INCX.GT.1 ) THEN +C +C Code for increment INCX > 1. +C + IX = 1 + IF ( M.GT.0 ) THEN +C + DO 10 I = 1, M - 1 + CALL DLARTG( A(I,I), X(IX), CI, SI, TEMP ) + A(I,I) = TEMP + IX = IX + INCX + CALL DROT( MN-I, A(I,I+1), LDA, X(IX), INCX, CI, SI ) + IF ( P.GT.0 ) + $ CALL DROT( P, B(I,1), LDB, D, INCD, CI, SI ) + 10 CONTINUE +C + CALL DLARTG( A(M,M), X(IX), CI, SI, TEMP ) + A(M,M) = TEMP + IX = IX + INCX + IF ( N.GT.0 ) + $ CALL DROT( N, A(M,M+1), LDA, X(IX), INCX, CI, SI ) + IF ( P.GT.0 ) + $ CALL DROT( P, B(M,1), LDB, D, INCD, CI, SI ) + END IF +C + IF ( N.GT.0 ) THEN +C + DO 20 I = 1, N - 1 + CALL DLARTG( T(I,I), X(IX), CI, SI, TEMP ) + T(I,I) = TEMP + IX = IX + INCX + CALL DROT( N-I, T(I,I+1), LDT, X(IX), INCX, CI, SI ) + IF ( P.GT.0 ) + $ CALL DROT( P, C(I,1), LDC, D, INCD, CI, SI ) + 20 CONTINUE +C + CALL DLARTG( T(N,N), X(IX), CI, SI, TEMP ) + T(N,N) = TEMP + IF ( P.GT.0 ) + $ CALL DROT( P, C(N,1), LDC, D, INCD, CI, SI ) + END IF +C + ELSEIF ( INCX.EQ.1 ) THEN +C +C Code for increment INCX = 1. +C + IF ( M.GT.0 ) THEN +C + DO 30 I = 1, M - 1 + CALL DLARTG( A(I,I), X(I), CI, SI, TEMP ) + A(I,I) = TEMP + CALL DROT( MN-I, A(I,I+1), LDA, X(I+1), 1, CI, SI ) + IF ( P.GT.0 ) + $ CALL DROT( P, B(I,1), LDB, D, INCD, CI, SI ) + 30 CONTINUE +C + CALL DLARTG( A(M,M), X(M), CI, SI, TEMP ) + A(M,M) = TEMP + IF ( N.GT.0 ) + $ CALL DROT( N, A(M,M+1), LDA, X(M+1), 1, CI, SI ) + IF ( P.GT.0 ) + $ CALL DROT( P, B(M,1), LDB, D, INCD, CI, SI ) + END IF +C + IF ( N.GT.0 ) THEN + IX = M + 1 +C + DO 40 I = 1, N - 1 + CALL DLARTG( T(I,I), X(IX), CI, SI, TEMP ) + T(I,I) = TEMP + IX = IX + 1 + CALL DROT( N-I, T(I,I+1), LDT, X(IX), 1, CI, SI ) + IF ( P.GT.0 ) + $ CALL DROT( P, C(I,1), LDC, D, INCD, CI, SI ) + 40 CONTINUE +C + CALL DLARTG( T(N,N), X(IX), CI, SI, TEMP ) + T(N,N) = TEMP + IF ( P.GT.0 ) + $ CALL DROT( P, C(N,1), LDC, D, INCD, CI, SI ) + END IF + END IF +C + RETURN +C *** Last line of MB04OW *** + END diff --git a/mex/sources/libslicot/MB04OX.f b/mex/sources/libslicot/MB04OX.f new file mode 100644 index 000000000..b8d02919e --- /dev/null +++ b/mex/sources/libslicot/MB04OX.f @@ -0,0 +1,106 @@ + SUBROUTINE MB04OX( N, A, LDA, X, INCX ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the QR factorization +C +C (U ) = Q*(R), +C (x') (0) +C +C where U and R are n-by-n upper triangular matrices, x is an +C n element vector and Q is an (n+1)-by-(n+1) orthogonal matrix. +C +C U must be supplied in the n-by-n upper triangular part of the +C array A and this is overwritten by R. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of elements of X and the order of the square +C matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix U. +C On exit, the leading N-by-N upper triangular part of this +C array contains the upper triangular matrix R. +C The strict lower triangle of A is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension +C (1+(N-1)*INCX) +C On entry, the incremented array X must contain the +C vector x. On exit, the content of X is changed. +C +C INCX (input) INTEGER. +C Specifies the increment for the elements of X. INCX > 0. +C +C METHOD +C +C The matrix Q is formed as a sequence of plane rotations in planes +C (1, n+1), (2, n+1), ..., (n, n+1), the rotation in the (j, n+1)th +C plane, Q(j), being chosen to annihilate the jth element of x. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine DUTUPD. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INCX, LDA, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), X(*) +C .. Local Scalars .. + DOUBLE PRECISION CI, SI, TEMP + INTEGER I, IX +C .. External Subroutines .. + EXTERNAL DLARTG, DROT +C +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked. +C + IX = 1 +C + DO 20 I = 1, N - 1 + CALL DLARTG( A(I,I), X(IX), CI, SI, TEMP ) + A(I,I) = TEMP + IX = IX + INCX + CALL DROT( N-I, A(I,I+1), LDA, X(IX), INCX, CI, SI ) + 20 CONTINUE +C + CALL DLARTG( A(N,N), X(IX), CI, SI, TEMP ) + A(N,N) = TEMP +C + RETURN +C *** Last line of MB04OX *** + END diff --git a/mex/sources/libslicot/MB04OY.f b/mex/sources/libslicot/MB04OY.f new file mode 100644 index 000000000..d77d28372 --- /dev/null +++ b/mex/sources/libslicot/MB04OY.f @@ -0,0 +1,370 @@ + SUBROUTINE MB04OY( M, N, V, TAU, A, LDA, B, LDB, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply a real elementary reflector H to a real (m+1)-by-n +C matrix C = [ A ], from the left, where A has one row. H is +C [ B ] +C represented in the form +C ( 1 ) +C H = I - tau * u *u', u = ( ), +C ( v ) +C where tau is a real scalar and v is a real m-vector. +C +C If tau = 0, then H is taken to be the unit matrix. +C +C In-line code is used if H has order < 11. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix B. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrices A and B. N >= 0. +C +C V (input) DOUBLE PRECISION array, dimension (M) +C The vector v in the representation of H. +C +C TAU (input) DOUBLE PRECISION +C The scalar factor of the elementary reflector H. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading 1-by-N part of this array must +C contain the matrix A. +C On exit, the leading 1-by-N part of this array contains +C the updated matrix A (the first row of H * C). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= 1. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix B. +C On exit, the leading M-by-N part of this array contains +C the updated matrix B (the last m rows of H * C). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C DWORK is not referenced if H has order less than 11. +C +C METHOD +C +C The routine applies the elementary reflector H, taking the special +C structure of C into account. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Based on LAPACK routines DLARFX and DLATZM. +C +C REVISIONS +C +C Dec. 1997. +C +C KEYWORDS +C +C Elementary matrix operations, elementary reflector, orthogonal +C transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER LDA, LDB, M, N + DOUBLE PRECISION TAU +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), V( * ) +C .. Local Scalars .. + INTEGER J + DOUBLE PRECISION SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, V1, V2, + $ V3, V4, V5, V6, V7, V8, V9 +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER +C +C .. Executable Statements .. +C + IF( TAU.EQ.ZERO ) + $ RETURN +C +C Form H * C, where H has order m+1. +C + GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, + $ 170, 190 ) M+1 +C +C Code for general M. Compute +C +C w := C'*u, C := C - tau * u * w'. +C + CALL DCOPY( N, A, LDA, DWORK, 1 ) + CALL DGEMV( 'Transpose', M, N, ONE, B, LDB, V, 1, ONE, DWORK, 1 ) + CALL DAXPY( N, -TAU, DWORK, 1, A, LDA ) + CALL DGER( M, N, -TAU, V, 1, DWORK, 1, B, LDB ) + GO TO 210 + 10 CONTINUE +C +C Special code for 1 x 1 Householder +C + T1 = ONE - TAU + DO 20 J = 1, N + A( 1, J ) = T1*A( 1, J ) + 20 CONTINUE + GO TO 210 + 30 CONTINUE +C +C Special code for 2 x 2 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + DO 40 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + 40 CONTINUE + GO TO 210 + 50 CONTINUE +C +C Special code for 3 x 3 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + DO 60 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + 60 CONTINUE + GO TO 210 + 70 CONTINUE +C +C Special code for 4 x 4 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + DO 80 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + 80 CONTINUE + GO TO 210 + 90 CONTINUE +C +C Special code for 5 x 5 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + DO 100 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + 100 CONTINUE + GO TO 210 + 110 CONTINUE +C +C Special code for 6 x 6 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + DO 120 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + V5*B( 5, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + B( 5, J ) = B( 5, J ) - SUM*T5 + 120 CONTINUE + GO TO 210 + 130 CONTINUE +C +C Special code for 7 x 7 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + DO 140 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + B( 5, J ) = B( 5, J ) - SUM*T5 + B( 6, J ) = B( 6, J ) - SUM*T6 + 140 CONTINUE + GO TO 210 + 150 CONTINUE +C +C Special code for 8 x 8 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + DO 160 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + + $ V7*B( 7, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + B( 5, J ) = B( 5, J ) - SUM*T5 + B( 6, J ) = B( 6, J ) - SUM*T6 + B( 7, J ) = B( 7, J ) - SUM*T7 + 160 CONTINUE + GO TO 210 + 170 CONTINUE +C +C Special code for 9 x 9 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + DO 180 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + + $ V7*B( 7, J ) + V8*B( 8, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + B( 5, J ) = B( 5, J ) - SUM*T5 + B( 6, J ) = B( 6, J ) - SUM*T6 + B( 7, J ) = B( 7, J ) - SUM*T7 + B( 8, J ) = B( 8, J ) - SUM*T8 + 180 CONTINUE + GO TO 210 + 190 CONTINUE +C +C Special code for 10 x 10 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + V9 = V( 9 ) + T9 = TAU*V9 + DO 200 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + + $ V7*B( 7, J ) + V8*B( 8, J ) + V9*B( 9, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + B( 5, J ) = B( 5, J ) - SUM*T5 + B( 6, J ) = B( 6, J ) - SUM*T6 + B( 7, J ) = B( 7, J ) - SUM*T7 + B( 8, J ) = B( 8, J ) - SUM*T8 + B( 9, J ) = B( 9, J ) - SUM*T9 + 200 CONTINUE + 210 CONTINUE + RETURN +C *** Last line of MB04OY *** + END diff --git a/mex/sources/libslicot/MB04PA.f b/mex/sources/libslicot/MB04PA.f new file mode 100644 index 000000000..8ee27d01e --- /dev/null +++ b/mex/sources/libslicot/MB04PA.f @@ -0,0 +1,1105 @@ + SUBROUTINE MB04PA( LHAM, N, K, NB, A, LDA, QG, LDQG, XA, LDXA, + $ XG, LDXG, XQ, LDXQ, YA, LDYA, CS, TAU, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce a Hamiltonian like matrix +C +C [ A G ] T T +C H = [ T ] , G = G , Q = Q, +C [ Q -A ] +C +C or a skew-Hamiltonian like matrix +C +C [ A G ] T T +C W = [ T ] , G = -G , Q = -Q, +C [ Q A ] +C +C so that elements below the (k+1)-th subdiagonal in the first nb +C columns of the (k+n)-by-n matrix A, and offdiagonal elements +C in the first nb columns and rows of the n-by-n matrix Q are zero. +C +C The reduction is performed by an orthogonal symplectic +C transformation UU'*H*UU and matrices U, XA, XG, XQ, and YA are +C returned so that +C +C [ Aout + U*XA'+ YA*U' Gout + U*XG'+ XG*U' ] +C UU'*H*UU = [ ]. +C [ Qout + U*XQ'+ XQ*U' -Aout'- XA*U'- U*YA' ] +C +C Similarly, +C +C [ Aout + U*XA'+ YA*U' Gout + U*XG'- XG*U' ] +C UU'*W*UU = [ ]. +C [ Qout + U*XQ'- XQ*U' Aout'+ XA*U'+ U*YA' ] +C +C This is an auxiliary routine called by MB04PB. +C +C ARGUMENTS +C +C Mode Parameters +C +C LHAM LOGICAL +C Specifies the type of matrix to be reduced: +C = .FALSE. : skew-Hamiltonian like W; +C = .TRUE. : Hamiltonian like H. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C K (input) INTEGER +C The offset of the reduction. Elements below the (K+1)-th +C subdiagonal in the first NB columns of A are reduced +C to zero. K >= 0. +C +C NB (input) INTEGER +C The number of columns/rows to be reduced. N > NB >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading (K+N)-by-N part of this array must +C contain the matrix A. +C On exit, the leading (K+N)-by-N part of this array +C contains the matrix Aout and in the zero part +C information about the elementary reflectors used to +C compute the reduction. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,K+N). +C +C QG (input/output) DOUBLE PRECISION array, dimension +C (LDQG,N+1) +C On entry, the leading N+K-by-N+1 part of this array must +C contain in the bottom left part the lower triangular part +C of the N-by-N matrix Q and in the remainder the upper +C trapezoidal part of the last N columns of the N+K-by-N+K +C matrix G. +C On exit, the leading N+K-by-N+1 part of this array +C contains parts of the matrices Q and G in the same fashion +C as on entry only that the zero parts of Q contain +C information about the elementary reflectors used to +C compute the reduction. Note that if LHAM = .FALSE. then +C the (K-1)-th and K-th subdiagonals are not referenced. +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= MAX(1,N+K). +C +C XA (output) DOUBLE PRECISION array, dimension (LDXA,2*NB) +C On exit, the leading N-by-(2*NB) part of this array +C contains the matrix XA. +C +C LDXA INTEGER +C The leading dimension of the array XA. LDXA >= MAX(1,N). +C +C XG (output) DOUBLE PRECISION array, dimension (LDXG,2*NB) +C On exit, the leading (K+N)-by-(2*NB) part of this array +C contains the matrix XG. +C +C LDXG INTEGER +C The leading dimension of the array XG. LDXG >= MAX(1,K+N). +C +C XQ (output) DOUBLE PRECISION array, dimension (LDXQ,2*NB) +C On exit, the leading N-by-(2*NB) part of this array +C contains the matrix XQ. +C +C LDXQ INTEGER +C The leading dimension of the array XQ. LDXQ >= MAX(1,N). +C +C YA (output) DOUBLE PRECISION array, dimension (LDYA,2*NB) +C On exit, the leading (K+N)-by-(2*NB) part of this array +C contains the matrix YA. +C +C LDYA INTEGER +C The leading dimension of the array YA. LDYA >= MAX(1,K+N). +C +C CS (output) DOUBLE PRECISION array, dimension (2*NB) +C On exit, the first 2*NB elements of this array contain the +C cosines and sines of the symplectic Givens rotations used +C to compute the reduction. +C +C TAU (output) DOUBLE PRECISION array, dimension (NB) +C On exit, the first NB elements of this array contain the +C scalar factors of some of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (3*NB) +C +C METHOD +C +C For details regarding the representation of the orthogonal +C symplectic matrix UU within the arrays A, QG, CS, TAU see the +C description of MB04PU. +C +C The contents of A and QG on exit are illustrated by the following +C example with n = 5, k = 2 and nb = 2: +C +C ( a r r a a ) ( g g r r g g ) +C ( a r r a a ) ( g g r r g g ) +C ( a r r a a ) ( q g r r g g ) +C A = ( r r r r r ), QG = ( t r r r r r ), +C ( u2 r r r r ) ( u1 t r r r r ) +C ( u2 u2 r a a ) ( u1 u1 r q g g ) +C ( u2 u2 r a a ) ( u1 u1 r q q g ) +C +C where a, g and q denote elements of the original matrices, r +C denotes a modified element, t denotes a scalar factor of an +C applied elementary reflector and ui denote elements of the +C matrix U. +C +C REFERENCES +C +C [1] C. F. VAN LOAN: +C A symplectic method for approximating all the eigenvalues of +C a Hamiltonian matrix. +C Linear Algebra and its Applications, 61, pp. 233-251, 1984. +C +C [2] D. KRESSNER: +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C CONTRIBUTORS +C +C D. Kressner (Technical Univ. Berlin, Germany) and +C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. +C +C REVISIONS +C +C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DLAPVL). +C +C KEYWORDS +C +C Elementary matrix operations, Hamiltonian matrix, +C skew-Hamiltonian matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D+0 ) +C .. Scalar Arguments .. + LOGICAL LHAM + INTEGER K, LDA, LDQG, LDXA, LDXG, LDXQ, LDYA, N, NB +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*), + $ XA(LDXA,*), XG(LDXG,*), XQ(LDXQ,*), YA(LDYA,*) +C .. Local Scalars .. + INTEGER I, J, NB1, NB2 + DOUBLE PRECISION AKI, ALPHA, C, S, TAUQ, TEMP, TTEMP +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL DAXPY, DGEMV, DLARFG, DLARTG, DROT, DSCAL, + $ DSYMV, MB01MD +C .. Intrinsic Functions .. + INTRINSIC MIN +C +C .. Executable Statements .. +C +C Quick return if possible. +C + IF ( N+K.LE.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + NB1 = NB + 1 + NB2 = NB + NB1 +C + IF ( LHAM ) THEN + DO 50 I = 1, NB +C +C Transform i-th columns of A and Q. See routine MB04PU. +C + ALPHA = QG(K+I+1,I) + CALL DLARFG( N-I, ALPHA, QG(K+MIN( I+2, N ),I), 1, TAUQ ) + QG(K+I+1,I) = ONE + TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) + CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) + AKI = A(K+I+1,I) + CALL DLARTG( AKI, ALPHA, C, S, A(K+I+1,I) ) + AKI = A(K+I+1,I) + CALL DLARFG( N-I, AKI, A(K+MIN( I+2, N ),I), 1, TAU(I) ) + A(K+I+1,I) = ONE +C +C Update XA with first Householder reflection. +C +C xa = H(1:n,1:n)'*u1 + CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, + $ QG(K+I+1,I), 1, ZERO, XA(I+1,I), 1 ) +C w1 = U1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, QG(K+I+1,1), LDQG, + $ QG(K+I+1,I), 1, ZERO, DWORK, 1 ) +C xa = xa + XA1*w1 + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, + $ DWORK, 1, ONE, XA(I+1,I), 1 ) +C w2 = U2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ QG(K+I+1,I), 1, ZERO, DWORK(NB1), 1 ) +C xa = xa + XA2*w2 + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB1), 1, ONE, XA(I+1,I), 1 ) +C temp = YA1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, + $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) +C xa = xa + U1*temp + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), + $ LDQG, XA(1,I), 1, ONE, XA(I+1,I), 1 ) +C temp = YA2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, + $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) +C xa = xa + U2*temp + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) +C xa = -tauq*xa + CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) +C +C Update YA with first Householder reflection. +C +C ya = H(1:n,1:n)*u1 + CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, + $ QG(K+I+1,I), 1, ZERO, YA(1,I), 1 ) +C temp = XA1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, + $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) +C ya = ya + U1*temp + CALL DGEMV( 'No transpose', N-I, I-1, ONE, QG(K+I+1,1), + $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) +C temp = XA2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,NB1), LDXA, + $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) +C ya = ya + U2*temp + CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) +C ya = ya + YA1*w1 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, + $ DWORK, 1, ONE, YA(1,I), 1 ) +C ya = ya + YA2*w2 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB1), 1, ONE, YA(1,I), 1 ) +C ya = -tauq*ya + CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) +C temp = -tauq*ya'*u1 + TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) +C ya = ya + temp*u1 + CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) +C +C Update (i+1)-th column of A. +C +C A(:,i+1) = A(:,i+1) + U1 * XA1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, + $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) +C A(:,i+1) = A(:,i+1) + U2 * XA2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) +C A(:,i+1) = A(:,i+1) + YA1 * U1(i+1,:)'; + CALL DGEMV( 'No transpose', N+K, I, ONE, YA, LDYA, + $ QG(K+I+1,1), LDQG, ONE, A(1,I+1), 1 ) +C A(:,i+1) = A(:,i+1) + YA2 * U2(i+1,:)'; + CALL DGEMV( 'No transpose', N+K, I-1, ONE, YA(1,NB1), LDYA, + $ A(K+I+1,1), LDA, ONE, A(1,I+1), 1 ) +C +C Update (i+1)-th row of A. +C + IF ( N.GT.I+1 ) THEN +C A(i+1,i+2:n) = A(i+1,i+2:n) + U1(i+1,:)*XA1(i+2:n,:)' + CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), + $ LDXA, QG(K+I+1,1), LDQG, ONE, A(K+I+1,I+2), + $ LDA ) +C A(i+1,i+2:n) = A(i+1,i+2:n) + U2(i+1,:)*XA2(i+2:n,:)' + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), + $ LDXA, A(K+I+1,1), LDA, ONE, A(K+I+1,I+2), + $ LDA ) +C A(i+1,i+2:n) = A(i+1,i+2:n) + YA1(i+1,:) * U1(i+2:n,:)' + CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, YA(K+I+1,1), LDYA, ONE, A(K+I+1,I+2), + $ LDA ) +C A(i+1,i+2:n) = A(i+1,i+2:n) + YA2(i+1,:) * U2(i+2:n,:)' + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, YA(K+I+1,NB1), LDYA, ONE, A(K+I+1,I+2), + $ LDA ) + END IF +C +C Annihilate updated parts in YA. +C + DO 10 J = 1, I + YA(K+I+1,J) = ZERO + 10 CONTINUE + DO 20 J = 1, I-1 + YA(K+I+1,NB+J) = ZERO + 20 CONTINUE +C +C Update XQ with first Householder reflection. +C +C xq = Q*u1 + CALL DSYMV( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, + $ QG(K+I+1,I), 1, ZERO, XQ(I+1,I), 1 ) +C xq = xq + XQ1*w1 + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, + $ DWORK, 1, ONE, XQ(I+1,I), 1 ) +C xq = xq + XQ2*w2 + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+1,I), 1 ) +C temp = XQ1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, + $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) +C xq = xq + U1*temp + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), + $ LDQG, XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) +C temp = XQ2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,NB1), LDXQ, + $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) +C xq = xq + U2*temp + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) +C xq = -tauq*xq + CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) +C temp = -tauq/2*xq'*u1 + TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) +C xq = xq + temp*u1 + CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) +C +C Update (i+1)-th column and row of Q. +C +C Q(:,i+1) = Q(:,i+1) + U1 * XQ1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, + $ XQ(I+1,1), LDXQ, ONE, QG(K+I+1,I+1), 1 ) +C Q(:,i+1) = Q(:,i+1) + U2 * XQ2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ XQ(I+1,NB1), LDXQ, ONE, QG(K+I+1,I+1), 1 ) +C Q(:,i+1) = Q(:,i+1) + XQ1 * U1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+1), 1 ) +C Q(:,i+1) = Q(:,i+1) + XQ2 * U2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, A(K+I+1,1), LDA, ONE, QG(K+I+1,I+1), 1 ) +C +C Update XG with first Householder reflection. +C +C xg = G*u1 + CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, + $ QG(K+I+1,I), 1, ZERO, XG(1,I), 1 ) + CALL DSYMV( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, + $ QG(K+I+1,I), 1, ZERO, XG(K+I+1,I), 1 ) +C xg = xg + XG1*w1 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, + $ DWORK, 1, ONE, XG(1,I), 1 ) +C xg = xg + XG2*w2 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB1), 1, ONE, XG(1,I), 1 ) +C temp = XG1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,1), LDXQ, + $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) +C xg = xg + U1*temp + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), + $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) +C temp = XG2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,NB1), + $ LDXQ, QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) +C xg = xg + U2*temp + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) +C xg = -tauq*xg + CALL DSCAL( N+K, -TAUQ, XG(1,I), 1 ) +C temp = -tauq/2*xq'*u1 + TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XG(K+I+1,I), + $ 1 ) +C xg = xg + temp*u1 + CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XG(K+I+1,I), 1 ) +C +C Update (i+1)-th column and row of G. +C +C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; + CALL DGEMV( 'No transpose', K+I, I, ONE, XG, LDXG, + $ QG(K+I+1,1), LDQG, ONE, QG(1,I+2), 1 ) +C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; + CALL DGEMV( 'No transpose', K+I, I-1, ONE, XG(1,NB1), LDXG, + $ A(K+I+1,1), LDA, ONE, QG(1,I+2), 1 ) +C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, + $ QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+2), LDQG ) +C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XG(K+I+1,NB1), + $ LDXG, A(K+I+1,1), LDA, ONE, QG(K+I+1,I+2), + $ LDQG ) +C G(:,i+1) = G(:,i+1) + U1 * XG1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, + $ XG(K+I+1,1), LDXG, ONE, QG(K+I+1,I+2), LDQG ) +C G(:,i+1) = G(:,i+1) + U2 * XG2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ XG(K+I+1,NB1), LDXG, ONE, QG(K+I+1,I+2), LDQG ) +C +C Annihilate updated parts in XG. +C + DO 30 J = 1, I + XG(K+I+1,J) = ZERO + 30 CONTINUE + DO 40 J = 1, I-1 + XG(K+I+1,NB+J) = ZERO + 40 CONTINUE +C +C Apply orthogonal symplectic Givens rotation. +C + CALL DROT( K+I, A(1,I+1), 1, QG(1,I+2), 1, C, S ) + IF ( N.GT.I+1 ) THEN + CALL DROT( N-I-1, A(K+I+2,I+1), 1, QG(K+I+1,I+3), LDQG, + $ C, S ) + CALL DROT( N-I-1, A(K+I+1,I+2), LDA, QG(K+I+2,I+1), 1, C, + $ S ) + END IF + TEMP = A(K+I+1,I+1) + TTEMP = QG(K+I+1,I+2) + A(K+I+1,I+1) = C*TEMP + S*QG(K+I+1,I+1) + QG(K+I+1,I+2) = C*TTEMP - S*TEMP + QG(K+I+1,I+1) = -S*TEMP + C*QG(K+I+1,I+1) + TTEMP = -S*TTEMP - C*TEMP + TEMP = A(K+I+1,I+1) + QG(K+I+1,I+1) = C*QG(K+I+1,I+1) + S*TTEMP + A(K+I+1,I+1) = C*TEMP + S*QG(K+I+1,I+2) + QG(K+I+1,I+2) = -S*TEMP + C*QG(K+I+1,I+2) + CS(2*I-1) = C + CS(2*I) = S + QG(K+I+1,I) = TAUQ +C +C Update XA with second Householder reflection. +C +C xa = H(1:n,1:n)'*u2 + CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, + $ A(K+I+1,I), 1, ZERO, XA(I+1,NB+I), 1 ) + IF ( N.GT.I+1 ) THEN +C w1 = U1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, A(K+I+2,I), 1, ZERO, DWORK, 1 ) +C xa = xa + XA1*w1 + CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), + $ LDXA, DWORK, 1, ONE, XA(I+2,NB+I), 1 ) +C w2 = U2'*u2 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, A(K+I+2,I), 1, ZERO, DWORK(NB1), 1 ) +C xa = xa + XA2*w2 + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), + $ LDXA, DWORK(NB1), 1, ONE, XA(I+2,NB+I), 1 ) +C temp = YA1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, YA(K+I+2,1), + $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) +C xa = xa + U1*temp + CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) +C temp = YA2'*u1 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, YA(K+I+2,NB1), + $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) +C xa = xa + U2*temp + CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) + END IF +C xa = -tau*xa + CALL DSCAL( N-I, -TAU(I), XA(I+1,NB+I), 1 ) +C +C Update YA with second Householder reflection. +C +C ya = H(1:n,1:n)*u2 + CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, + $ A(K+I+1,I), 1, ZERO, YA(1,NB+I), 1 ) + IF ( N.GT.I+1 ) THEN +C temp = XA1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, + $ A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) +C ya = ya + U1*temp + CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) +C temp = XA2'*u1 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XA(I+2,NB1), + $ LDXA, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) +C ya = ya + U2*temp + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) + END IF +C ya = ya + YA1*w1 + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ DWORK, 1, ONE, YA(1,NB+I), 1 ) +C ya = ya + YA2*w2 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB1), 1, ONE, YA(1,NB+I), 1 ) +C ya = -tau*ya + CALL DSCAL( K+N, -TAU(I), YA(1,NB+I), 1 ) +C temp = -tau*ya'*u2 + TEMP = -TAU(I)*DDOT( N-I, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) +C ya = ya + temp*u2 + CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) +C +C Update (i+1)-th column of A. +C +C H(1:n,i+1) = H(1:n,i+1) + ya + CALL DAXPY( K+N, ONE, YA(1,NB+I), 1, A(1,I+1), 1 ) +C H(1:n,i+1) = H(1:n,i+1) + xa(i+1)*u2 + CALL DAXPY( N-I, XA(I+1,NB+I), A(K+I+1,I), 1, A(K+I+1,I+1), + $ 1 ) +C +C Update (i+1)-th row of A. +C + IF ( N.GT.I+1 ) THEN +C H(i+1,i+2:n) = H(i+1,i+2:n) + xa(i+2:n)'; + CALL DAXPY( N-I-1, ONE, XA(I+2,NB+I), 1, A(K+I+1,I+2), + $ LDA ) +C H(i+1,i+2:n) = H(i+1,i+2:n) + YA(i+1,:) * U(i+2:n,:)' + CALL DAXPY( N-I-1, YA(K+I+1,NB+I), A(K+I+2,I), 1, + $ A(K+I+1,I+2), LDA ) + END IF +C +C Annihilate updated parts in YA. +C + YA(K+I+1,NB+I) = ZERO +C +C Update XQ with second Householder reflection. +C +C xq = Q*u2 + CALL DSYMV( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, + $ A(K+I+1,I), 1, ZERO, XQ(I+1,NB+I), 1 ) + IF ( N.GT.I+1 ) THEN +C xq = xq + XQ1*w1 + CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1), + $ LDXQ, DWORK, 1, ONE, XQ(I+2,NB+I), 1 ) +C xq = xq + XQ2*w2 + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), + $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+2,NB+I), 1 ) +C temp = XQ1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, + $ A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) +C xq = xq + U1*temp + CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) +C temp = XQ2'*u2 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), + $ LDXQ, A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) +C xq = xq + U2*temp + CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) + END IF +C xq = -tauq*xq + CALL DSCAL( N-I, -TAU(I), XQ(I+1,NB+I), 1 ) +C temp = -tauq/2*xq'*u2 + TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, XQ(I+1,NB+I), + $ 1 ) +C xq = xq + temp*u2 + CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XQ(I+1,NB+I), 1 ) +C +C Update (i+1)-th column and row of Q. +C + CALL DAXPY( N-I, ONE, XQ(I+1,NB+I), 1, QG(K+I+1,I+1), 1 ) +C H(1:n,n+i+1) = H(1:n,n+i+1) + U * XQ(i+1,:)'; + CALL DAXPY( N-I, XQ(I+1,NB+I), A(K+I+1,I), 1, + $ QG(K+I+1,I+1), 1 ) +C +C Update XG with second Householder reflection. +C +C xg = G*u2 + CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, + $ A(K+I+1,I), 1, ZERO, XG(1,NB+I), 1 ) + CALL DSYMV( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, + $ A(K+I+1,I), 1, ZERO, XG(K+I+1,NB+I), 1 ) +C xg = xg + XG1*w1 + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ DWORK, 1, ONE, XG(1,NB+I), 1 ) +C xg = xg + XG2*w2 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB1), 1, ONE, XG(1,NB+I), 1 ) + IF ( N.GT.I+1 ) THEN +C temp = XG1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), + $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) +C xg = xg + U1*temp + CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) +C temp = XG2'*u2 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XG(K+I+2,NB1), + $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) +C xg = xg + U2*temp + CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) + END IF +C xg = -tauq*xg + CALL DSCAL( N+K, -TAU(I), XG(1,NB+I), 1 ) +C temp = -tauq/2*xg'*u1 + TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, + $ XG(K+I+1,NB+I), 1 ) +C xg = xg + temp*u1 + CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XG(K+I+1,NB+I), 1 ) +C +C Update (i+1)-th column and row of G. +C + CALL DAXPY( K+I, ONE, XG(1,NB+I), 1, QG(1,I+2), 1 ) + CALL DAXPY( N-I, ONE, XG(K+I+1,NB+I), 1, QG(K+I+1,I+2), + $ LDQG ) + CALL DAXPY( N-I, XG(K+I+1,NB+I), A(K+I+1,I), 1, + $ QG(K+I+1,I+2), LDQG ) +C +C Annihilate updated parts in XG. +C + XG(K+I+1,NB+I) = ZERO +C + A(K+I+1,I) = AKI + 50 CONTINUE + ELSE + DO 100 I = 1, NB +C +C Transform i-th columns of A and Q. +C + ALPHA = QG(K+I+1,I) + CALL DLARFG( N-I, ALPHA, QG(K+MIN( I+2, N ),I), 1, TAUQ ) + QG(K+I+1,I) = ONE + TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) + CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) + AKI = A(K+I+1,I) + CALL DLARTG( AKI, ALPHA, C, S, A(K+I+1,I) ) + AKI = A(K+I+1,I) + CALL DLARFG( N-I, AKI, A(K+MIN( I+2, N ),I), 1, TAU(I) ) + A(K+I+1,I) = ONE +C +C Update XA with first Householder reflection. +C +C xa = H(1:n,1:n)'*u1 + CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, + $ QG(K+I+1,I), 1, ZERO, XA(I+1,I), 1 ) +C w1 = U1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, QG(K+I+1,1), LDQG, + $ QG(K+I+1,I), 1, ZERO, DWORK, 1 ) +C xa = xa + XA1*w1 + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, + $ DWORK, 1, ONE, XA(I+1,I), 1 ) +C w2 = U2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ QG(K+I+1,I), 1, ZERO, DWORK(NB1), 1 ) +C xa = xa + XA2*w2 + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB1), 1, ONE, XA(I+1,I), 1 ) +C temp = YA1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, + $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) +C xa = xa + U1*temp + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), + $ LDQG, XA(1,I), 1, ONE, XA(I+1,I), 1 ) +C temp = YA2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, + $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) +C xa = xa + U2*temp + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) +C xa = -tauq*xa + CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) +C +C Update YA with first Householder reflection. +C +C ya = H(1:n,1:n)*u1 + CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, + $ QG(K+I+1,I), 1, ZERO, YA(1,I), 1 ) +C temp = XA1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, + $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) +C ya = ya + U1*temp + CALL DGEMV( 'No transpose', N-I, I-1, ONE, QG(K+I+1,1), + $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) +C temp = XA2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,NB1), LDXA, + $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) +C ya = ya + U2*temp + CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) +C ya = ya + YA1*w1 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, + $ DWORK, 1, ONE, YA(1,I), 1 ) +C ya = ya + YA2*w2 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB1), 1, ONE, YA(1,I), 1 ) +C ya = -tauq*ya + CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) +C temp = -tauq*ya'*u1 + TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) +C ya = ya + temp*u1 + CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) +C +C Update (i+1)-th column of A. +C +C A(:,i+1) = A(:,i+1) + U1 * XA1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, + $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) +C A(:,i+1) = A(:,i+1) + U2 * XA2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) +C A(:,i+1) = A(:,i+1) + YA1 * U1(i+1,:)'; + CALL DGEMV( 'No transpose', N+K, I, ONE, YA, LDYA, + $ QG(K+I+1,1), LDQG, ONE, A(1,I+1), 1 ) +C A(:,i+1) = A(:,i+1) + YA2 * U2(i+1,:)'; + CALL DGEMV( 'No transpose', N+K, I-1, ONE, YA(1,NB1), LDYA, + $ A(K+I+1,1), LDA, ONE, A(1,I+1), 1 ) +C +C Update (i+1)-th row of A. +C + IF ( N.GT.I+1 ) THEN +C A(i+1,i+2:n) = A(i+1,i+2:n) + U1(i+1,:)*XA1(i+2:n,:)' + CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), + $ LDXA, QG(K+I+1,1), LDQG, ONE, A(K+I+1,I+2), + $ LDA ) +C A(i+1,i+2:n) = A(i+1,i+2:n) + U2(i+1,:)*XA2(i+2:n,:)' + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), + $ LDXA, A(K+I+1,1), LDA, ONE, A(K+I+1,I+2), + $ LDA ) +C A(i+1,i+2:n) = A(i+1,i+2:n) + YA1(i+1,:) * U1(i+2:n,:)' + CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, YA(K+I+1,1), LDYA, ONE, A(K+I+1,I+2), + $ LDA ) +C A(i+1,i+2:n) = A(i+1,i+2:n) + YA2(i+1,:) * U2(i+2:n,:)' + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, YA(K+I+1,NB1), LDYA, ONE, A(K+I+1,I+2), + $ LDA ) + END IF +C +C Annihilate updated parts in YA. +C + DO 60 J = 1, I + YA(K+I+1,J) = ZERO + 60 CONTINUE + DO 70 J = 1, I-1 + YA(K+I+1,NB+J) = ZERO + 70 CONTINUE +C +C Update XQ with first Householder reflection. +C +C xq = Q*u1 + CALL MB01MD( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, + $ QG(K+I+1,I), 1, ZERO, XQ(I+1,I), 1 ) +C xq = xq + XQ1*w1 + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, + $ DWORK, 1, ONE, XQ(I+1,I), 1 ) +C xq = xq + XQ2*w2 + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+1,I), 1 ) +C temp = XQ1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, + $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) +C xq = xq - U1*temp + CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, QG(K+I+1,1), + $ LDQG, XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) +C temp = XQ2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,NB1), LDXQ, + $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) +C xq = xq - U2*temp + CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, A(K+I+1,1), LDA, + $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) +C xq = -tauq*xq + CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) +C temp = -tauq/2*xq'*u1 + TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) +C xq = xq + temp*u1 + CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) +C +C Update (i+1)-th column and row of Q. +C + IF ( N.GT.I+1 ) THEN +C Q(:,i+1) = Q(:,i+1) - U1 * XQ1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I-1, I, -ONE, QG(K+I+2,1), + $ LDQG, XQ(I+1,1), LDXQ, ONE, QG(K+I+2,I+1), + $ 1 ) +C Q(:,i+1) = Q(:,i+1) - U2 * XQ2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I-1, I-1, -ONE, A(K+I+2,1), + $ LDA, XQ(I+1,NB1), LDXQ, ONE, QG(K+I+2,I+1), + $ 1 ) +C Q(:,i+1) = Q(:,i+1) + XQ1 * U1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1), + $ LDXQ, QG(K+I+1,1), LDQG, ONE, QG(K+I+2,I+1), + $ 1 ) +C Q(:,i+1) = Q(:,i+1) + XQ2 * U2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), + $ LDXQ, A(K+I+1,1), LDA, ONE, QG(K+I+2,I+1), + $ 1 ) + END IF +C +C Update XG with first Householder reflection. +C +C xg = G*u1 + CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, + $ QG(K+I+1,I), 1, ZERO, XG(1,I), 1 ) + CALL MB01MD( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, + $ QG(K+I+1,I), 1, ZERO, XG(K+I+1,I), 1 ) +C xg = xg + XG1*w1 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, + $ DWORK, 1, ONE, XG(1,I), 1 ) +C xg = xg + XG2*w2 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB1), 1, ONE, XG(1,I), 1 ) +C temp = XG1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,1), LDXQ, + $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) +C xg = xg - U1*temp + CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, QG(K+I+1,1), + $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) +C temp = XG2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,NB1), + $ LDXQ, QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) +C xg = xg - U2*temp + CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, A(K+I+1,1), LDA, + $ DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) +C xg = -tauq*xg + CALL DSCAL( N+K, -TAUQ, XG(1,I), 1 ) +C temp = -tauq/2*xq'*u1 + TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XG(K+I+1,I), + $ 1 ) +C xg = xg + temp*u1 + CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XG(K+I+1,I), 1 ) +C +C Update (i+1)-th column and row of G. +C +C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; + CALL DGEMV( 'No transpose', K+I, I, ONE, XG, LDXG, + $ QG(K+I+1,1), LDQG, ONE, QG(1,I+2), 1 ) +C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; + CALL DGEMV( 'No transpose', K+I, I-1, ONE, XG(1,NB1), LDXG, + $ A(K+I+1,1), LDA, ONE, QG(1,I+2), 1 ) + IF ( N.GT.I+1 ) THEN +C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I-1, I, -ONE, XG(K+I+2,1), + $ LDXG, QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+3), + $ LDQG ) +C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I-1, I-1, -ONE, + $ XG(K+I+2,NB1), LDXG, A(K+I+1,1), LDA, ONE, + $ QG(K+I+1,I+3), LDQG ) +C G(:,i+1) = G(:,i+1) + U1 * XG1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, XG(K+I+1,1), LDXG, ONE, QG(K+I+1,I+3), + $ LDQG ) +C G(:,i+1) = G(:,i+1) + U2 * XG2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, XG(K+I+1,NB1), LDXG, ONE, QG(K+I+1,I+3), + $ LDQG ) + END IF +C +C Annihilate updated parts in XG. +C + DO 80 J = 1, I + XG(K+I+1,J) = ZERO + 80 CONTINUE + DO 90 J = 1, I-1 + XG(K+I+1,NB+J) = ZERO + 90 CONTINUE +C +C Apply orthogonal symplectic Givens rotation. +C + CALL DROT( K+I, A(1,I+1), 1, QG(1,I+2), 1, C, S ) + IF ( N.GT.I+1 ) THEN + CALL DROT( N-I-1, A(K+I+2,I+1), 1, QG(K+I+1,I+3), LDQG, + $ C, -S ) + CALL DROT( N-I-1, A(K+I+1,I+2), LDA, QG(K+I+2,I+1), 1, + $ C, -S ) + END IF + CS(2*I-1) = C + CS(2*I) = S + QG(K+I+1,I) = TAUQ +C +C Update XA with second Householder reflection. +C +C xa = H(1:n,1:n)'*u2 + CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, + $ A(K+I+1,I), 1, ZERO, XA(I+1,NB+I), 1 ) + IF ( N.GT.I+1 ) THEN +C w1 = U1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, A(K+I+2,I), 1, ZERO, DWORK, 1 ) +C xa = xa + XA1*w1 + CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), + $ LDXA, DWORK, 1, ONE, XA(I+2,NB+I), 1 ) +C w2 = U2'*u2 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, A(K+I+2,I), 1, ZERO, DWORK(NB1), 1 ) +C xa = xa + XA2*w2 + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), + $ LDXA, DWORK(NB1), 1, ONE, XA(I+2,NB+I), 1 ) +C temp = YA1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, YA(K+I+2,1), + $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) +C xa = xa + U1*temp + CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) +C temp = YA2'*u1 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, YA(K+I+2,NB1), + $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) +C xa = xa + U2*temp + CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) + END IF +C xa = -tau*xa + CALL DSCAL( N-I, -TAU(I), XA(I+1,NB+I), 1 ) +C +C Update YA with second Householder reflection. +C +C ya = H(1:n,1:n)*u2 + CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, + $ A(K+I+1,I), 1, ZERO, YA(1,NB+I), 1 ) + IF ( N.GT.I+1 ) THEN +C temp = XA1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, + $ A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) +C ya = ya + U1*temp + CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) +C temp = XA2'*u1 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XA(I+2,NB1), + $ LDXA, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) +C ya = ya + U2*temp + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) + END IF +C ya = ya + YA1*w1 + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ DWORK, 1, ONE, YA(1,NB+I), 1 ) +C ya = ya + YA2*w2 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB1), 1, ONE, YA(1,NB+I), 1 ) +C ya = -tau*ya + CALL DSCAL( K+N, -TAU(I), YA(1,NB+I), 1 ) +C temp = -tau*ya'*u2 + TEMP = -TAU(I)*DDOT( N-I, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) +C ya = ya + temp*u2 + CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) +C +C Update (i+1)-th column of A. +C +C H(1:n,i+1) = H(1:n,i+1) + ya + CALL DAXPY( K+N, ONE, YA(1,NB+I), 1, A(1,I+1), 1 ) +C H(1:n,i+1) = H(1:n,i+1) + xa(i+1)*u2 + CALL DAXPY( N-I, XA(I+1,NB+I), A(K+I+1,I), 1, A(K+I+1,I+1), + $ 1 ) +C +C Update (i+1)-th row of A. +C + IF ( N.GT.I+1 ) THEN +C H(i+1,i+2:n) = H(i+1,i+2:n) + xa(i+2:n)'; + CALL DAXPY( N-I-1, ONE, XA(I+2,NB+I), 1, A(K+I+1,I+2), + $ LDA ) +C H(i+1,i+2:n) = H(i+1,i+2:n) + YA(i+1,:) * U(i+2:n,:)' + CALL DAXPY( N-I-1, YA(K+I+1,NB+I), A(K+I+2,I), 1, + $ A(K+I+1,I+2), LDA ) + END IF +C +C Annihilate updated parts in YA. +C + YA(K+I+1,NB+I) = ZERO +C +C Update XQ with second Householder reflection. +C +C xq = Q*u2 + CALL MB01MD( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, + $ A(K+I+1,I), 1, ZERO, XQ(I+1,NB+I), 1 ) + IF ( N.GT.I+1 ) THEN +C xq = xq + XQ1*w1 + CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1), + $ LDXQ, DWORK, 1, ONE, XQ(I+2,NB+I), 1 ) +C xq = xq + XQ2*w2 + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), + $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+2,NB+I), 1 ) +C temp = XQ1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, + $ A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) +C xq = xq - U1*temp + CALL DGEMV( 'No Transpose', N-I-1, I, -ONE, QG(K+I+2,1), + $ LDQG, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) +C temp = XQ2'*u2 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), + $ LDXQ, A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) +C xq = xq - U2*temp + CALL DGEMV( 'No Transpose', N-I-1, I-1, -ONE, A(K+I+2,1), + $ LDA, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) + END IF +C xq = -tauq*xq + CALL DSCAL( N-I, -TAU(I), XQ(I+1,NB+I), 1 ) +C temp = -tauq/2*xq'*u2 + TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, XQ(I+1,NB+I), + $ 1 ) +C xq = xq + temp*u2 + CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XQ(I+1,NB+I), 1 ) +C +C Update (i+1)-th column and row of Q. +C + IF ( N.GT.I+1 ) THEN + CALL DAXPY( N-I-1, ONE, XQ(I+2,NB+I), 1, QG(K+I+2,I+1), + $ 1 ) +C H(1:n,n+i+1) = H(1:n,n+i+1) - U * XQ(i+1,:)'; + CALL DAXPY( N-I-1, -XQ(I+1,NB+I), A(K+I+2,I), 1, + $ QG(K+I+2,I+1), 1 ) + END IF +C +C Update XG with second Householder reflection. +C +C xg = G*u2 + CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, + $ A(K+I+1,I), 1, ZERO, XG(1,NB+I), 1 ) + CALL MB01MD( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, + $ A(K+I+1,I), 1, ZERO, XG(K+I+1,NB+I), 1 ) +C xg = xg + XG1*w1 + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ DWORK, 1, ONE, XG(1,NB+I), 1 ) +C xg = xg + XG2*w2 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB1), 1, ONE, XG(1,NB+I), 1 ) + IF ( N.GT.I+1 ) THEN +C temp = XG1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), + $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) +C xg = xg - U1*temp + CALL DGEMV( 'No Transpose', N-I-1, I, -ONE, QG(K+I+2,1), + $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) +C temp = XG2'*u2 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XG(K+I+2,NB1), + $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) +C xg = xg - U2*temp + CALL DGEMV( 'No Transpose', N-I-1, I-1, -ONE, A(K+I+2,1), + $ LDA, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) + END IF +C xg = -tauq*xg + CALL DSCAL( N+K, -TAU(I), XG(1,NB+I), 1 ) +C temp = -tauq/2*xg'*u1 + TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, + $ XG(K+I+1,NB+I), 1 ) +C xg = xg + temp*u1 + CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XG(K+I+1,NB+I), 1 ) +C +C Update (i+1)-th column and row of G. +C + CALL DAXPY( K+I, ONE, XG(1,NB+I), 1, QG(1,I+2), 1 ) + IF ( N.GT.I+1 ) THEN + CALL DAXPY( N-I-1, -ONE, XG(K+I+2,NB+I), 1, + $ QG(K+I+1,I+3), LDQG ) + CALL DAXPY( N-I-1, XG(K+I+1,NB+I), A(K+I+2,I), 1, + $ QG(K+I+1,I+3), LDQG ) + END IF +C +C Annihilate updated parts in XG. +C + XG(K+I+1,NB+I) = ZERO +C + A(K+I+1,I) = AKI + 100 CONTINUE + END IF +C + RETURN +C *** Last line of MB04PA *** + END diff --git a/mex/sources/libslicot/MB04PB.f b/mex/sources/libslicot/MB04PB.f new file mode 100644 index 000000000..3948eee1e --- /dev/null +++ b/mex/sources/libslicot/MB04PB.f @@ -0,0 +1,333 @@ + SUBROUTINE MB04PB( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce a Hamiltonian matrix, +C +C [ A G ] +C H = [ T ] , +C [ Q -A ] +C +C where A is an N-by-N matrix and G,Q are N-by-N symmetric matrices, +C to Paige/Van Loan (PVL) form. That is, an orthogonal symplectic U +C is computed so that +C +C T [ Aout Gout ] +C U H U = [ T ] , +C [ Qout -Aout ] +C +C where Aout is upper Hessenberg and Qout is diagonal. +C Blocked version. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C ILO (input) INTEGER +C It is assumed that A is already upper triangular and Q is +C zero in rows and columns 1:ILO-1. ILO is normally set by a +C previous call to MB04DD; otherwise it should be set to 1. +C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, the leading N-by-N part of this array contains +C the matrix Aout and, in the zero part of Aout, +C information about the elementary reflectors used to +C compute the PVL factorization. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C QG (input/output) DOUBLE PRECISION array, dimension +C (LDQG,N+1) +C On entry, the leading N-by-N+1 part of this array must +C contain the lower triangular part of the matrix Q and +C the upper triangular part of the matrix G. +C On exit, the leading N-by-N+1 part of this array contains +C the diagonal of the matrix Qout, the upper triangular part +C of the matrix Gout and, in the zero parts of Qout, +C information about the elementary reflectors used to +C compute the PVL factorization. +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= MAX(1,N). +C +C CS (output) DOUBLE PRECISION array, dimension (2N-2) +C On exit, the first 2N-2 elements of this array contain the +C cosines and sines of the symplectic Givens rotations used +C to compute the PVL factorization. +C +C TAU (output) DOUBLE PRECISION array, dimension (N-1) +C On exit, the first N-1 elements of this array contain the +C scalar factors of some of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK, 8*N*NB + 3*NB, where NB is the optimal +C block size determined by the function UE01MD. +C On exit, if INFO = -10, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N-1). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix U is represented as a product of symplectic reflectors +C and Givens rotators +C +C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) +C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) +C .... +C diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ). +C +C Each H(i) has the form +C +C H(i) = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in +C QG(i+2:n,i), and tau in QG(i+1,i). +C +C Each F(i) has the form +C +C F(i) = I - nu * w * w' +C +C where nu is a real scalar, and w is a real vector with +C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in +C A(i+2:n,i), and nu in TAU(i). +C +C Each G(i) is a Givens rotator acting on rows i+1 and n+i+1, +C where the cosine is stored in CS(2*i-1) and the sine in +C CS(2*i). +C +C NUMERICAL ASPECTS +C +C The algorithm requires O(N**3) floating point operations and is +C strongly backward stable. +C +C REFERENCES +C +C [1] C. F. VAN LOAN: +C A symplectic method for approximating all the eigenvalues of +C a Hamiltonian matrix. +C Linear Algebra and its Applications, 61, pp. 233-251, 1984. +C +C [2] D. KRESSNER: +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C CONTRIBUTORS +C +C D. Kressner (Technical Univ. Berlin, Germany) and +C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. +C +C REVISIONS +C +C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DHAPVB). +C +C KEYWORDS +C +C Elementary matrix operations, Hamiltonian matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER ILO, INFO, LDA, LDQG, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*) +C .. Local Scalars .. + INTEGER I, IB, IERR, NB, NBMIN, NH, NIB, NNB, NX, PDW, + $ PXA, PXG, PXQ, PYA, WRKOPT +C .. External Functions .. + INTEGER UE01MD + EXTERNAL UE01MD +C .. External Subroutines .. + EXTERNAL DGEMM, DSYR2K, MB04PA, MB04PU, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + IF ( N.LT.0 ) THEN + INFO = -1 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF ( LDWORK.LT.MAX( 1, N-1 ) ) THEN + DWORK(1) = DBLE( MAX( 1, N-1 ) ) + INFO = -10 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04PB', -INFO ) + RETURN + END IF +C +C Set elements 1:ILO-1 of TAU and CS. +C + DO 10 I = 1, ILO - 1 + TAU( I ) = ZERO + CS(2*I-1) = ONE + CS(2*I) = ZERO + 10 CONTINUE +C +C Quick return if possible. +C + IF ( N.LE.ILO ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Determine the block size. +C + NH = N - ILO + 1 + NB = UE01MD( 1, 'MB04PB', ' ', N, ILO, -1 ) + NBMIN = 2 + WRKOPT = N-1 + IF ( NB.GT.1 .AND. NB.LT.NH ) THEN +C +C Determine when to cross over from blocked to unblocked code. +C + NX = MAX( NB, UE01MD( 3, 'MB04PB', ' ', N, ILO, -1 ) ) + IF ( NX.LT.NH ) THEN +C +C Check whether workspace is large enough for blocked code. +C + WRKOPT = 8*N*NB + 3*NB + IF ( LDWORK.LT.WRKOPT ) THEN +C +C Not enough workspace available. Determine minimum value +C of NB, and reduce NB. +C + NBMIN = MAX( 2, UE01MD( 2, 'MB04PB', ' ', N, ILO, -1 ) ) + NB = LDWORK / ( 8*N + 3 ) + END IF + END IF + END IF +C + NNB = N*NB + PXA = 1 + PYA = PXA + 2*NNB + PXQ = PYA + 2*NNB + PXG = PXQ + 2*NNB + PDW = PXG + 2*NNB +C + IF ( NB.LT.NBMIN .OR. NB.GE.NH ) THEN +C +C Use unblocked code. +C + I = ILO +C + ELSE + DO 20 I = ILO, N-NX-1, NB + IB = MIN( NB, N-I ) + NIB = N*IB +C +C Reduce rows and columns i:i+nb-1 to PVL form and return the +C matrices XA, XG, XQ, and YA which are needed to update the +C unreduced parts of the matrices. +C + CALL MB04PA( .TRUE., N-I+1, I-1, IB, A(1,I), LDA, QG(1,I), + $ LDQG, DWORK(PXA), N, DWORK(PXG), N, + $ DWORK(PXQ), N, DWORK(PYA), N, CS(2*I-1), + $ TAU(I), DWORK(PDW) ) + IF ( N.GT.I+IB ) THEN +C +C Update the submatrix A(1:n,i+ib+1:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB, + $ IB, ONE, QG(I+IB+1,I), LDQG, DWORK(PXA+IB+1), + $ N, ONE, A(I+IB+1,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB, + $ IB, ONE, A(I+IB+1,I), LDA, + $ DWORK(PXA+NIB+IB+1), N, ONE, + $ A(I+IB+1,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYA), N, QG(I+IB+1,I), LDQG, ONE, + $ A(1,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYA+NIB), N, A(I+IB+1,I), LDA, + $ ONE, A(1,I+IB+1), LDA ) +C +C Update the submatrix Q(i+ib+1:n,i+ib+1:n). +C + CALL DSYR2K( 'Lower', 'No Transpose', N-I-IB, IB, ONE, + $ DWORK(PXQ+IB+1), N, QG(I+IB+1,I), LDQG, ONE, + $ QG(I+IB+1,I+IB+1), LDQG ) + CALL DSYR2K( 'Lower', 'No Transpose', N-I-IB, IB, ONE, + $ DWORK(PXQ+NIB+IB+1), N, A(I+IB+1,I), LDA, + $ ONE, QG(I+IB+1,I+IB+1), LDQG ) +C +C Update the submatrix G(1:n,1:n). +C + CALL DGEMM( 'No transpose', 'Transpose', I+IB, N-I-IB, + $ IB, ONE, DWORK(PXG), N, QG(I+IB+1,I), LDQG, + $ ONE, QG(1,I+IB+2), LDQG ) + CALL DGEMM( 'No transpose', 'Transpose', I+IB, N-I-IB, + $ IB, ONE, DWORK(PXG+NIB), N, A(I+IB+1,I), LDA, + $ ONE, QG(1,I+IB+2), LDQG ) + CALL DSYR2K( 'Upper', 'No Transpose', N-I-IB, IB, ONE, + $ DWORK(PXG+IB+I), N, QG(I+IB+1,I), LDQG, ONE, + $ QG(I+IB+1,I+IB+2), LDQG ) + CALL DSYR2K( 'Upper', 'No Transpose', N-I-IB, IB, ONE, + $ DWORK(PXG+NIB+IB+I), N, A(I+IB+1,I), LDA, + $ ONE, QG(I+IB+1,I+IB+2), LDQG ) + END IF + 20 CONTINUE + END IF +C +C Unblocked code to reduce the rest of the matrices. +C + CALL MB04PU( N, I, A, LDA, QG, LDQG, CS, TAU, DWORK, LDWORK, + $ IERR ) +C + DWORK( 1 ) = DBLE( WRKOPT ) +C + RETURN +C *** Last line of MB04PB *** + END diff --git a/mex/sources/libslicot/MB04PU.f b/mex/sources/libslicot/MB04PU.f new file mode 100644 index 000000000..2c13e6636 --- /dev/null +++ b/mex/sources/libslicot/MB04PU.f @@ -0,0 +1,369 @@ + SUBROUTINE MB04PU( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce a Hamiltonian matrix, +C +C [ A G ] +C H = [ T ] , +C [ Q -A ] +C +C where A is an N-by-N matrix and G,Q are N-by-N symmetric matrices, +C to Paige/Van Loan (PVL) form. That is, an orthogonal symplectic U +C is computed so that +C +C T [ Aout Gout ] +C U H U = [ T ] , +C [ Qout -Aout ] +C +C where Aout is upper Hessenberg and Qout is diagonal. +C Unblocked version. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C ILO (input) INTEGER +C It is assumed that A is already upper triangular and Q is +C zero in rows and columns 1:ILO-1. ILO is normally set by a +C previous call to MB04DD; otherwise it should be set to 1. +C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, the leading N-by-N part of this array contains +C the matrix Aout and, in the zero part of Aout, +C information about the elementary reflectors used to +C compute the PVL factorization. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C QG (input/output) DOUBLE PRECISION array, dimension +C (LDQG,N+1) +C On entry, the leading N-by-N+1 part of this array must +C contain the lower triangular part of the matrix Q and +C the upper triangular part of the matrix G. +C On exit, the leading N-by-N+1 part of this array contains +C the diagonal of the matrix Qout, the upper triangular part +C of the matrix Gout and, in the zero parts of Qout, +C information about the elementary reflectors used to +C compute the PVL factorization. +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= MAX(1,N). +C +C CS (output) DOUBLE PRECISION array, dimension (2N-2) +C On exit, the first 2N-2 elements of this array contain the +C cosines and sines of the symplectic Givens rotations used +C to compute the PVL factorization. +C +C TAU (output) DOUBLE PRECISION array, dimension (N-1) +C On exit, the first N-1 elements of this array contain the +C scalar factors of some of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -10, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N-1). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix U is represented as a product of symplectic reflectors +C and Givens rotators +C +C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) +C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) +C .... +C diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ). +C +C Each H(i) has the form +C +C H(i) = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in +C QG(i+2:n,i), and tau in QG(i+1,i). +C +C Each F(i) has the form +C +C F(i) = I - nu * w * w' +C +C where nu is a real scalar, and w is a real vector with +C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in +C A(i+2:n,i), and nu in TAU(i). +C +C Each G(i) is a Givens rotator acting on rows i+1 and n+i+1, +C where the cosine is stored in CS(2*i-1) and the sine in +C CS(2*i). +C +C NUMERICAL ASPECTS +C +C The algorithm requires 40/3 N**3 + O(N) floating point operations +C and is strongly backward stable. +C +C REFERENCES +C +C [1] C. F. VAN LOAN: +C A symplectic method for approximating all the eigenvalues of +C a Hamiltonian matrix. +C Linear Algebra and its Applications, 61, pp. 233-251, 1984. +C +C CONTRIBUTORS +C +C D. Kressner (Technical Univ. Berlin, Germany) and +C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. +C +C REVISIONS +C +C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DHAPVL). +C +C KEYWORDS +C +C Elementary matrix operations, Hamiltonian matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER ILO, INFO, LDA, LDQG, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION ALPHA, C, MU, NU, S, TEMP, TTEMP +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL DAXPY, DLARF, DLARFG, DLARTG, DROT, DSYMV, + $ DSYR2, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + IF ( N.LT.0 ) THEN + INFO = -1 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF ( LDWORK.LT.MAX( 1, N-1 ) ) THEN + DWORK(1) = DBLE( MAX( 1, N-1 ) ) + INFO = -10 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04PU', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.LE.ILO ) THEN + DWORK(1) = ONE + RETURN + END IF +C + DO 10 I = ILO, N-1 +C +C Generate elementary reflector H(i) to annihilate QG(i+2:n,i). +C + ALPHA = QG(I+1,I) + CALL DLARFG( N-I, ALPHA, QG(MIN( I+2,N ),I), 1, NU ) + IF ( NU.NE.ZERO ) THEN + QG(I+1,I) = ONE +C +C Apply H(i) from both sides to QG(i+1:n,i+1:n). +C Compute x := nu * QG(i+1:n,i+1:n) * v. +C + CALL DSYMV( 'Lower', N-I, NU, QG(I+1,I+1), LDQG, QG(I+1,I), + $ 1, ZERO, DWORK, 1 ) +C +C Compute w := x - 1/2 * nu * (x'*v) * v. +C + MU = -HALF*NU*DDOT( N-I, DWORK, 1, QG(I+1,I), 1 ) + CALL DAXPY( N-I, MU, QG(I+1,I), 1, DWORK, 1 ) +C +C Apply the transformation as a rank-2 update: +C QG := QG - v * w' - w * v'. +C + CALL DSYR2( 'Lower', N-I, -ONE, QG(I+1,I), 1, DWORK, 1, + $ QG(I+1,I+1), LDQG ) +C +C Apply H(i) from the right hand side to QG(1:i,i+2:n+1). +C + CALL DLARF( 'Right', I, N-I, QG(I+1,I), 1, NU, QG(1,I+2), + $ LDQG, DWORK ) +C +C Apply H(i) from both sides to QG(i+1:n,i+2:n+1). +C Compute x := nu * QG(i+1:n,i+2:n+1) * v. +C + CALL DSYMV( 'Upper', N-I, NU, QG(I+1,I+2), LDQG, QG(I+1,I), + $ 1, ZERO, DWORK, 1 ) +C +C Compute w := x - 1/2 * nu * (x'*v) * v. +C + MU = -HALF*NU*DDOT( N-I, DWORK, 1, QG(I+1,I), 1 ) + CALL DAXPY( N-I, MU, QG(I+1,I), 1, DWORK, 1 ) +C +C Apply the transformation as a rank-2 update: +C QG(i+1:n,i+2:n+1) := QG(i+1:n,i+2:n+1) - v * w' - w * v'. +C + CALL DSYR2( 'Upper', N-I, -ONE, QG(I+1,I), 1, DWORK, 1, + $ QG(I+1,I+2), LDQG ) +C +C Apply H(i) from the left hand side to A(i+1:n,i:n). +C + CALL DLARF( 'Left', N-I, N-I+1, QG(I+1,I), 1, NU, + $ A(I+1,I), LDA, DWORK ) +C +C Apply H(i) from the right hand side to A(1:n,i+1:n). +C + CALL DLARF( 'Right', N, N-I, QG(I+1,I), 1, NU, + $ A(1,I+1), LDA, DWORK ) + END IF + QG(I+1,I) = NU +C +C Generate symplectic Givens rotation G(i) to annihilate +C QG(i+1,i). +C + TEMP = A(I+1,I) + CALL DLARTG( TEMP, ALPHA, C, S, A(I+1,I) ) +C +C Apply G(i) to [A(I+1,I+2:N); QG(I+2:N,I+1)']. +C + CALL DROT( N-I-1, A(I+1,I+2), LDA, QG(I+2,I+1), 1, C, S ) +C +C Apply G(i) to [A(1:I,I+1) QG(1:I,I+2)]. +C + CALL DROT(I, A(1,I+1), 1, QG(1,I+2), 1, C, S ) +C +C Apply G(i) to [A(I+2:N,I+1) QG(I+1, I+3:N+1)'] from the right. +C + CALL DROT(N-I-1, A(I+2,I+1), 1, QG(I+1,I+3), LDQG, C, S ) +C +C Fix the diagonal part. +C + TEMP = A(I+1,I+1) + TTEMP = QG(I+1,I+2) + A(I+1,I+1) = C*TEMP + S*QG(I+1,I+1) + QG(I+1,I+2) = C*TTEMP - S * TEMP + QG(I+1,I+1) = -S*TEMP + C*QG(I+1,I+1) + TTEMP = -S*TTEMP - C*TEMP + TEMP = A(I+1,I+1) + QG(I+1,I+1) = C*QG(I+1,I+1) + S*TTEMP + A(I+1,I+1) = C*TEMP + S*QG(I+1,I+2) + QG(I+1,I+2) = -S*TEMP + C*QG(I+1,I+2) + CS(2*I-1) = C + CS(2*I) = S +C +C Generate elementary reflector F(i) to annihilate A(i+2:n,i). +C + CALL DLARFG( N-I, A(I+1,I), A(MIN( I+2,N ),I), 1, NU ) + IF ( NU.NE.ZERO ) THEN + TEMP = A(I+1,I) + A(I+1,I) = ONE +C +C Apply F(i) from the left hand side to A(i+1:n,i+1:n). +C + CALL DLARF( 'Left', N-I, N-I, A(I+1,I), 1, NU, A(I+1,I+1), + $ LDA, DWORK ) +C +C Apply G(i) from the right hand side to A(1:n,i+1:n). +C + CALL DLARF( 'Right', N, N-I, A(I+1,I), 1, NU, + $ A(1,I+1), LDA, DWORK ) +C +C Apply G(i) from both sides to QG(i+1:n,i+1:n). +C Compute x := nu * QG(i+1:n,i+1:n) * v. +C + CALL DSYMV( 'Lower', N-I, NU, QG(I+1,I+1), LDQG, A(I+1,I), + $ 1, ZERO, DWORK, 1 ) +C +C Compute w := x - 1/2 * tau * (x'*v) * v. +C + MU = -HALF*NU*DDOT( N-I, DWORK, 1, A(I+1,I), 1 ) + CALL DAXPY( N-I, MU, A(I+1,I), 1, DWORK, 1 ) +C +C Apply the transformation as a rank-2 update: +C QG := QG - v * w' - w * v'. +C + CALL DSYR2( 'Lower', N-I, -ONE, A(I+1,I), 1, DWORK, 1, + $ QG(I+1,I+1), LDQG ) +C +C Apply G(i) from the right hand side to QG(1:i,i+2:n+1). +C + CALL DLARF( 'Right', I, N-I, A(I+1,I), 1, NU, QG(1,I+2), + $ LDQG, DWORK ) +C +C Apply G(i) from both sides to QG(i+1:n,i+2:n+1). +C Compute x := nu * QG(i+1:n,i+2:n+1) * v. +C + CALL DSYMV( 'Upper', N-I, NU, QG(I+1,I+2), LDQG, A(I+1,I), + $ 1, ZERO, DWORK, 1 ) +C +C Compute w := x - 1/2 * tau * (x'*v) * v. +C + MU = -HALF*NU*DDOT( N-I, DWORK, 1, A(I+1,I), 1 ) + CALL DAXPY( N-I, MU, A(I+1,I), 1, DWORK, 1 ) +C +C Apply the transformation as a rank-2 update: +C QG(i+1:n,i+2:n+1) := QG(i+1:n,i+2:n+1) - v * w' - w * v'. +C + CALL DSYR2( 'Upper', N-I, -ONE, A(I+1,I), 1, DWORK, 1, + $ QG(I+1,I+2), LDQG ) + A(I+1,I) = TEMP + END IF + TAU(I) = NU + 10 CONTINUE + DWORK(1) = DBLE( MAX( 1, N-1 ) ) + RETURN +C *** Last line of MB04PU *** + END diff --git a/mex/sources/libslicot/MB04PY.f b/mex/sources/libslicot/MB04PY.f new file mode 100644 index 000000000..09b5a17d7 --- /dev/null +++ b/mex/sources/libslicot/MB04PY.f @@ -0,0 +1,648 @@ + SUBROUTINE MB04PY( SIDE, M, N, V, TAU, C, LDC, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply a real elementary reflector H to a real m-by-n matrix +C C, from either the left or the right. H is represented in the form +C ( 1 ) +C H = I - tau * u *u', u = ( ), +C ( v ) +C where tau is a real scalar and v is a real vector. +C +C If tau = 0, then H is taken to be the unit matrix. +C +C In-line code is used if H has order < 11. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Indicates whether the elementary reflector should be +C applied from the left or from the right, as follows: +C = 'L': Compute H * C; +C = 'R': Compute C * H. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix C. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix C. N >= 0. +C +C V (input) DOUBLE PRECISION array, dimension +C (M-1), if SIDE = 'L', or +C (N-1), if SIDE = 'R'. +C The vector v in the representation of H. +C +C TAU (input) DOUBLE PRECISION +C The scalar factor of the elementary reflector H. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix C. +C On exit, the leading M-by-N part of this array contains +C the matrix H * C, if SIDE = 'L', or C * H, if SIDE = 'R'. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N), if SIDE = 'L', or +C (M), if SIDE = 'R'. +C DWORK is not referenced if H has order less than 11. +C +C METHOD +C +C The routine applies the elementary reflector H, taking its special +C structure into account. The multiplications by the first component +C of u (which is 1) are avoided, to increase the efficiency. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999. +C This is a modification of LAPACK Library routine DLARFX. +* +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, elementary reflector, orthogonal +C transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER SIDE + INTEGER LDC, M, N + DOUBLE PRECISION TAU +C .. +C .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), DWORK( * ), V( * ) +C .. +C .. Local Scalars .. + INTEGER J + DOUBLE PRECISION SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, + $ V1, V2, V3, V4, V5, V6, V7, V8, V9 +C .. +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER +C .. +C .. Executable Statements .. +C + IF( TAU.EQ.ZERO ) + $ RETURN + IF( LSAME( SIDE, 'L' ) ) THEN +C +C Form H * C, where H has order m. +C + GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, + $ 170, 190 ) M +C +C Code for general M. +C +C w := C'*u. +C + CALL DCOPY( N, C, LDC, DWORK, 1 ) + CALL DGEMV( 'Transpose', M-1, N, ONE, C( 2, 1 ), LDC, V, 1, + $ ONE, DWORK, 1 ) +C +C C := C - tau * u * w'. +C + CALL DAXPY( N, -TAU, DWORK, 1, C, LDC ) + CALL DGER( M-1, N, -TAU, V, 1, DWORK, 1, C( 2, 1 ), LDC ) + GO TO 410 + 10 CONTINUE +C +C Special code for 1 x 1 Householder. +C + T1 = ONE - TAU + DO 20 J = 1, N + C( 1, J ) = T1*C( 1, J ) + 20 CONTINUE + GO TO 410 + 30 CONTINUE +C +C Special code for 2 x 2 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + DO 40 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + 40 CONTINUE + GO TO 410 + 50 CONTINUE +C +C Special code for 3 x 3 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + DO 60 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + C( 3, J ) = C( 3, J ) - SUM*T2 + 60 CONTINUE + GO TO 410 + 70 CONTINUE +C +C Special code for 4 x 4 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + DO 80 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + + $ V3*C( 4, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + C( 3, J ) = C( 3, J ) - SUM*T2 + C( 4, J ) = C( 4, J ) - SUM*T3 + 80 CONTINUE + GO TO 410 + 90 CONTINUE +C +C Special code for 5 x 5 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + DO 100 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + + $ V3*C( 4, J ) + V4*C( 5, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + C( 3, J ) = C( 3, J ) - SUM*T2 + C( 4, J ) = C( 4, J ) - SUM*T3 + C( 5, J ) = C( 5, J ) - SUM*T4 + 100 CONTINUE + GO TO 410 + 110 CONTINUE +C +C Special code for 6 x 6 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + DO 120 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + + $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + C( 3, J ) = C( 3, J ) - SUM*T2 + C( 4, J ) = C( 4, J ) - SUM*T3 + C( 5, J ) = C( 5, J ) - SUM*T4 + C( 6, J ) = C( 6, J ) - SUM*T5 + 120 CONTINUE + GO TO 410 + 130 CONTINUE +C +C Special code for 7 x 7 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + DO 140 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + + $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + + $ V6*C( 7, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + C( 3, J ) = C( 3, J ) - SUM*T2 + C( 4, J ) = C( 4, J ) - SUM*T3 + C( 5, J ) = C( 5, J ) - SUM*T4 + C( 6, J ) = C( 6, J ) - SUM*T5 + C( 7, J ) = C( 7, J ) - SUM*T6 + 140 CONTINUE + GO TO 410 + 150 CONTINUE +C +C Special code for 8 x 8 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + DO 160 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + + $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + + $ V6*C( 7, J ) + V7*C( 8, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + C( 3, J ) = C( 3, J ) - SUM*T2 + C( 4, J ) = C( 4, J ) - SUM*T3 + C( 5, J ) = C( 5, J ) - SUM*T4 + C( 6, J ) = C( 6, J ) - SUM*T5 + C( 7, J ) = C( 7, J ) - SUM*T6 + C( 8, J ) = C( 8, J ) - SUM*T7 + 160 CONTINUE + GO TO 410 + 170 CONTINUE +C +C Special code for 9 x 9 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + DO 180 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + + $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + + $ V6*C( 7, J ) + V7*C( 8, J ) + V8*C( 9, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + C( 3, J ) = C( 3, J ) - SUM*T2 + C( 4, J ) = C( 4, J ) - SUM*T3 + C( 5, J ) = C( 5, J ) - SUM*T4 + C( 6, J ) = C( 6, J ) - SUM*T5 + C( 7, J ) = C( 7, J ) - SUM*T6 + C( 8, J ) = C( 8, J ) - SUM*T7 + C( 9, J ) = C( 9, J ) - SUM*T8 + 180 CONTINUE + GO TO 410 + 190 CONTINUE +C +C Special code for 10 x 10 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + V9 = V( 9 ) + T9 = TAU*V9 + DO 200 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + + $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + + $ V6*C( 7, J ) + V7*C( 8, J ) + V8*C( 9, J ) + + $ V9*C( 10, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + C( 3, J ) = C( 3, J ) - SUM*T2 + C( 4, J ) = C( 4, J ) - SUM*T3 + C( 5, J ) = C( 5, J ) - SUM*T4 + C( 6, J ) = C( 6, J ) - SUM*T5 + C( 7, J ) = C( 7, J ) - SUM*T6 + C( 8, J ) = C( 8, J ) - SUM*T7 + C( 9, J ) = C( 9, J ) - SUM*T8 + C( 10, J ) = C( 10, J ) - SUM*T9 + 200 CONTINUE + GO TO 410 + ELSE +C +C Form C * H, where H has order n. +C + GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, + $ 370, 390 ) N +C +C Code for general N. +C +C w := C * u. +C + CALL DCOPY( M, C, 1, DWORK, 1 ) + CALL DGEMV( 'No transpose', M, N-1, ONE, C( 1, 2 ), LDC, V, 1, + $ ONE, DWORK, 1 ) +C +C C := C - tau * w * u'. +C + CALL DAXPY( M, -TAU, DWORK, 1, C, 1 ) + CALL DGER( M, N-1, -TAU, DWORK, 1, V, 1, C( 1, 2 ), LDC ) + GO TO 410 + 210 CONTINUE +C +C Special code for 1 x 1 Householder. +C + T1 = ONE - TAU + DO 220 J = 1, M + C( J, 1 ) = T1*C( J, 1 ) + 220 CONTINUE + GO TO 410 + 230 CONTINUE +C +C Special code for 2 x 2 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + DO 240 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + 240 CONTINUE + GO TO 410 + 250 CONTINUE +C +C Special code for 3 x 3 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + DO 260 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + C( J, 3 ) = C( J, 3 ) - SUM*T2 + 260 CONTINUE + GO TO 410 + 270 CONTINUE +C +C Special code for 4 x 4 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + DO 280 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + + $ V3*C( J, 4 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + C( J, 3 ) = C( J, 3 ) - SUM*T2 + C( J, 4 ) = C( J, 4 ) - SUM*T3 + 280 CONTINUE + GO TO 410 + 290 CONTINUE +C +C Special code for 5 x 5 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + DO 300 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + + $ V3*C( J, 4 ) + V4*C( J, 5 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + C( J, 3 ) = C( J, 3 ) - SUM*T2 + C( J, 4 ) = C( J, 4 ) - SUM*T3 + C( J, 5 ) = C( J, 5 ) - SUM*T4 + 300 CONTINUE + GO TO 410 + 310 CONTINUE +C +C Special code for 6 x 6 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + DO 320 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + + $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + C( J, 3 ) = C( J, 3 ) - SUM*T2 + C( J, 4 ) = C( J, 4 ) - SUM*T3 + C( J, 5 ) = C( J, 5 ) - SUM*T4 + C( J, 6 ) = C( J, 6 ) - SUM*T5 + 320 CONTINUE + GO TO 410 + 330 CONTINUE +C +C Special code for 7 x 7 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + DO 340 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + + $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + + $ V6*C( J, 7 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + C( J, 3 ) = C( J, 3 ) - SUM*T2 + C( J, 4 ) = C( J, 4 ) - SUM*T3 + C( J, 5 ) = C( J, 5 ) - SUM*T4 + C( J, 6 ) = C( J, 6 ) - SUM*T5 + C( J, 7 ) = C( J, 7 ) - SUM*T6 + 340 CONTINUE + GO TO 410 + 350 CONTINUE +C +C Special code for 8 x 8 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + DO 360 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + + $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + + $ V6*C( J, 7 ) + V7*C( J, 8 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + C( J, 3 ) = C( J, 3 ) - SUM*T2 + C( J, 4 ) = C( J, 4 ) - SUM*T3 + C( J, 5 ) = C( J, 5 ) - SUM*T4 + C( J, 6 ) = C( J, 6 ) - SUM*T5 + C( J, 7 ) = C( J, 7 ) - SUM*T6 + C( J, 8 ) = C( J, 8 ) - SUM*T7 + 360 CONTINUE + GO TO 410 + 370 CONTINUE +C +C Special code for 9 x 9 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + DO 380 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + + $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + + $ V6*C( J, 7 ) + V7*C( J, 8 ) + V8*C( J, 9 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + C( J, 3 ) = C( J, 3 ) - SUM*T2 + C( J, 4 ) = C( J, 4 ) - SUM*T3 + C( J, 5 ) = C( J, 5 ) - SUM*T4 + C( J, 6 ) = C( J, 6 ) - SUM*T5 + C( J, 7 ) = C( J, 7 ) - SUM*T6 + C( J, 8 ) = C( J, 8 ) - SUM*T7 + C( J, 9 ) = C( J, 9 ) - SUM*T8 + 380 CONTINUE + GO TO 410 + 390 CONTINUE +C +C Special code for 10 x 10 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + V9 = V( 9 ) + T9 = TAU*V9 + DO 400 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + + $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + + $ V6*C( J, 7 ) + V7*C( J, 8 ) + V8*C( J, 9 ) + + $ V9*C( J, 10 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + C( J, 3 ) = C( J, 3 ) - SUM*T2 + C( J, 4 ) = C( J, 4 ) - SUM*T3 + C( J, 5 ) = C( J, 5 ) - SUM*T4 + C( J, 6 ) = C( J, 6 ) - SUM*T5 + C( J, 7 ) = C( J, 7 ) - SUM*T6 + C( J, 8 ) = C( J, 8 ) - SUM*T7 + C( J, 9 ) = C( J, 9 ) - SUM*T8 + C( J, 10 ) = C( J, 10 ) - SUM*T9 + 400 CONTINUE + GO TO 410 + END IF + 410 CONTINUE + RETURN +C +C *** Last line of MB04PY *** + END diff --git a/mex/sources/libslicot/MB04QB.f b/mex/sources/libslicot/MB04QB.f new file mode 100644 index 000000000..6cb9e6777 --- /dev/null +++ b/mex/sources/libslicot/MB04QB.f @@ -0,0 +1,454 @@ + SUBROUTINE MB04QB( TRANC, TRAND, TRANQ, STOREV, STOREW, M, N, K, + $ V, LDV, W, LDW, C, LDC, D, LDD, CS, TAU, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To overwrite general real m-by-n matrices C and D, or their +C transposes, with +C +C [ op(C) ] +C Q * [ ] if TRANQ = 'N', or +C [ op(D) ] +C +C T [ op(C) ] +C Q * [ ] if TRANQ = 'T', +C [ op(D) ] +C +C where Q is defined as the product of symplectic reflectors and +C Givens rotators, +C +C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) +C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) +C .... +C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). +C +C Blocked version. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANC CHARACTER*1 +C Specifies the form of op( C ) as follows: +C = 'N': op( C ) = C; +C = 'T': op( C ) = C'; +C = 'C': op( C ) = C'. +C +C TRAND CHARACTER*1 +C Specifies the form of op( D ) as follows: +C = 'N': op( D ) = D; +C = 'T': op( D ) = D'; +C = 'C': op( D ) = D'. +C +C TRANQ CHARACTER*1 +C = 'N': apply Q; +C = 'T': apply Q'. +C +C STOREV CHARACTER*1 +C Specifies how the vectors which define the concatenated +C Householder reflectors contained in V are stored: +C = 'C': columnwise; +C = 'R': rowwise. +C +C STOREW CHARACTER*1 +C Specifies how the vectors which define the concatenated +C Householder reflectors contained in W are stored: +C = 'C': columnwise; +C = 'R': rowwise. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices op(C) and op(D). +C M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrices op(C) and op(D). +C N >= 0. +C +C K (input) INTEGER +C The number of elementary reflectors whose product defines +C the matrix Q. M >= K >= 0. +C +C V (input) DOUBLE PRECISION array, dimension +C (LDV,K) if STOREV = 'C', +C (LDV,M) if STOREV = 'R' +C On entry with STOREV = 'C', the leading M-by-K part of +C this array must contain in its columns the vectors which +C define the elementary reflectors F(i). +C On entry with STOREV = 'R', the leading K-by-M part of +C this array must contain in its rows the vectors which +C define the elementary reflectors F(i). +C +C LDV INTEGER +C The leading dimension of the array V. +C LDV >= MAX(1,M), if STOREV = 'C'; +C LDV >= MAX(1,K), if STOREV = 'R'. +C +C W (input) DOUBLE PRECISION array, dimension +C (LDW,K) if STOREW = 'C', +C (LDW,M) if STOREW = 'R' +C On entry with STOREW = 'C', the leading M-by-K part of +C this array must contain in its columns the vectors which +C define the elementary reflectors H(i). +C On entry with STOREW = 'R', the leading K-by-M part of +C this array must contain in its rows the vectors which +C define the elementary reflectors H(i). +C +C LDW INTEGER +C The leading dimension of the array W. +C LDW >= MAX(1,M), if STOREW = 'C'; +C LDW >= MAX(1,K), if STOREW = 'R'. +C +C C (input/output) DOUBLE PRECISION array, dimension +C (LDC,N) if TRANC = 'N', +C (LDC,M) if TRANC = 'T' or TRANC = 'C' +C On entry with TRANC = 'N', the leading M-by-N part of +C this array must contain the matrix C. +C On entry with TRANC = 'C' or TRANC = 'T', the leading +C N-by-M part of this array must contain the transpose of +C the matrix C. +C On exit with TRANC = 'N', the leading M-by-N part of +C this array contains the updated matrix C. +C On exit with TRANC = 'C' or TRANC = 'T', the leading +C N-by-M part of this array contains the transpose of the +C updated matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= MAX(1,M), if TRANC = 'N'; +C LDC >= MAX(1,N), if TRANC = 'T' or TRANC = 'C'. +C +C D (input/output) DOUBLE PRECISION array, dimension +C (LDD,N) if TRAND = 'N', +C (LDD,M) if TRAND = 'T' or TRAND = 'C' +C On entry with TRAND = 'N', the leading M-by-N part of +C this array must contain the matrix D. +C On entry with TRAND = 'C' or TRAND = 'T', the leading +C N-by-M part of this array must contain the transpose of +C the matrix D. +C On exit with TRAND = 'N', the leading M-by-N part of +C this array contains the updated matrix D. +C On exit with TRAND = 'C' or TRAND = 'T', the leading +C N-by-M part of this array contains the transpose of the +C updated matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= MAX(1,M), if TRAND = 'N'; +C LDD >= MAX(1,N), if TRAND = 'T' or TRAND = 'C'. +C +C CS (input) DOUBLE PRECISION array, dimension (2*K) +C On entry, the first 2*K elements of this array must +C contain the cosines and sines of the symplectic Givens +C rotators G(i). +C +C TAU (input) DOUBLE PRECISION array, dimension (K) +C On entry, the first K elements of this array must +C contain the scalar factors of the elementary reflectors +C F(i). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -20, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Kressner, D. +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSMSB). +C +C KEYWORDS +C +C Elementary matrix operations, orthogonal symplectic matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +C .. Scalar Arguments .. + CHARACTER STOREV, STOREW, TRANC, TRAND, TRANQ + INTEGER INFO, K, LDC, LDD, LDV, LDW, LDWORK, M, N +C .. Array Arguments .. + DOUBLE PRECISION C(LDC,*), CS(*), D(LDD,*), DWORK(*), TAU(*), + $ V(LDV,*), W(LDW,*) +C .. Local Scalars .. + LOGICAL LCOLV, LCOLW, LTRC, LTRD, LTRQ + INTEGER I, IB, IC, ID, IERR, JC, JD, KI, KK, NB, NBMIN, + $ NX, PDRS, PDT, PDW, WRKOPT +C .. External Functions .. + INTEGER UE01MD + LOGICAL LSAME + EXTERNAL LSAME, UE01MD +C .. External Subroutines .. + EXTERNAL MB04QC, MB04QF, MB04QU, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + LCOLV = LSAME( STOREV, 'C' ) + LCOLW = LSAME( STOREW, 'C' ) + LTRC = LSAME( TRANC, 'T' ) .OR. LSAME( TRANC, 'C' ) + LTRD = LSAME( TRAND, 'T' ) .OR. LSAME( TRAND, 'C' ) + LTRQ = LSAME( TRANQ, 'T' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( LTRC .OR. LSAME( TRANC, 'N' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( LTRD .OR. LSAME( TRAND, 'N' ) ) ) THEN + INFO = -2 + ELSE IF ( .NOT.( LTRQ .OR. LSAME( TRANQ, 'N' ) ) ) THEN + INFO = -3 + ELSE IF ( .NOT.( LCOLV .OR. LSAME( STOREV, 'R' ) ) ) THEN + INFO = -4 + ELSE IF ( .NOT.( LCOLW .OR. LSAME( STOREW, 'R' ) ) ) THEN + INFO = -5 + ELSE IF ( M.LT.0 ) THEN + INFO = -6 + ELSE IF ( N.LT.0 ) THEN + INFO = -7 + ELSE IF ( K.LT.0 .OR. K.GT.M ) THEN + INFO = -8 + ELSE IF ( ( LCOLV .AND. LDV.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.LCOLV .AND. LDV.LT.MAX( 1, K ) ) ) THEN + INFO = -10 + ELSE IF ( ( LCOLW .AND. LDW.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.LCOLW .AND. LDW.LT.MAX( 1, K ) ) ) THEN + INFO = -12 + ELSE IF ( ( LTRC .AND. LDC.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LTRC .AND. LDC.LT.MAX( 1, M ) ) ) THEN + INFO = -14 + ELSE IF ( ( LTRD .AND. LDD.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LTRD .AND. LDD.LT.MAX( 1, M ) ) ) THEN + INFO = -16 + ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN + DWORK(1) = DBLE( MAX( 1, N ) ) + INFO = -20 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04QB', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( K, M, N ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + NBMIN = 2 + NX = 0 + WRKOPT = N + NB = UE01MD( 1, 'MB04QB', TRANC // TRAND // TRANQ, M, N, K ) + IF ( NB.GT.1 .AND. NB.LT.K ) THEN +C +C Determine when to cross over from blocked to unblocked code. +C + NX = MAX( 0, UE01MD( 3, 'MB04QB', TRANC // TRAND // TRANQ, M, + $ N, K ) ) + IF ( NX.LT.K ) THEN +C +C Determine if workspace is large enough for blocked code. +C + WRKOPT = MAX( WRKOPT, 9*N*NB + 15*NB*NB ) + IF ( LDWORK.LT.WRKOPT ) THEN +C +C Not enough workspace to use optimal NB: reduce NB and +C determine the minimum value of NB. +C + NB = INT( ( SQRT( DBLE( 81*N*N + 60*LDWORK ) ) + $ - DBLE( 9*N ) ) / 30.0D0 ) + NBMIN = MAX( 2, UE01MD( 2, 'MB04QB', TRANC // TRAND // + $ TRANQ, M, N, K ) ) + END IF + END IF + END IF +C + PDRS = 1 + PDT = PDRS + 6*NB*NB + PDW = PDT + 9*NB*NB + IC = 1 + JC = 1 + ID = 1 + JD = 1 +C + IF ( LTRQ ) THEN +C +C Use blocked code initially. +C + IF ( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN + DO 10 I = 1, K - NX, NB + IB = MIN( K-I+1, NB ) +C +C Form the triangular factors of the symplectic block +C reflector SH. +C + CALL MB04QF( 'Forward', STOREV, STOREW, M-I+1, IB, + $ V(I,I), LDV, W(I,I), LDW, CS(2*I-1), TAU(I), + $ DWORK(PDRS), NB, DWORK(PDT), NB, + $ DWORK(PDW) ) +C +C Apply SH' to [ op(C)(i:m,:); op(D)(i:m,:) ] from the +C left. +C + IF ( LTRC ) THEN + JC = I + ELSE + IC = I + END IF + IF ( LTRD ) THEN + JD = I + ELSE + ID = I + END IF + CALL MB04QC( 'No Structure', TRANC, TRAND, TRANQ, + $ 'Forward', STOREV, STOREW, M-I+1, N, IB, + $ V(I,I), LDV, W(I,I), LDW, DWORK(PDRS), NB, + $ DWORK(PDT), NB, C(IC,JC), LDC, D(ID,JD), + $ LDD, DWORK(PDW) ) + 10 CONTINUE + ELSE + I = 1 + END IF +C +C Use unblocked code to update last or only block. +C + IF ( I.LE.K ) THEN + IF ( LTRC ) THEN + JC = I + ELSE + IC = I + END IF + IF ( LTRD ) THEN + JD = I + ELSE + ID = I + END IF + CALL MB04QU( TRANC, TRAND, TRANQ, STOREV, STOREW, M-I+1, N, + $ K-I+1, V(I,I), LDV, W(I,I), LDW, C(IC,JC), LDC, + $ D(ID,JD), LDD, CS(2*I-1), TAU(I), DWORK, + $ LDWORK, IERR ) + END IF + ELSE + IF ( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +C +C Use blocked code after the last block. +C The first kk columns are handled by the block method. +C + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) + ELSE + KK = 0 + END IF +C +C Use unblocked code for the last or only block. +C + IF ( KK.LT.K ) THEN + IF ( LTRC ) THEN + JC = KK + 1 + ELSE + IC = KK + 1 + END IF + IF ( LTRD ) THEN + JD = KK + 1 + ELSE + ID = KK + 1 + END IF + CALL MB04QU( TRANC, TRAND, TRANQ, STOREV, STOREW, M-KK, N, + $ K-KK, V(KK+1,KK+1), LDV, W(KK+1,KK+1), LDW, + $ C(IC,JC), LDC, D(ID,JD), LDD, CS(2*KK+1), + $ TAU(KK+1), DWORK, LDWORK, IERR ) + END IF +C +C Blocked code. +C + IF ( KK.GT.0 ) THEN + DO 20 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) +C +C Form the triangular factors of the symplectic block +C reflector SH. +C + CALL MB04QF( 'Forward', STOREV, STOREW, M-I+1, IB, + $ V(I,I), LDV, W(I,I), LDW, CS(2*I-1), TAU(I), + $ DWORK(PDRS), NB, DWORK(PDT), NB, + $ DWORK(PDW) ) +C +C Apply SH to [ op(C)(i:m,:); op(D)(i:m,:) ] from +C the left. +C + IF ( LTRC ) THEN + JC = I + ELSE + IC = I + END IF + IF ( LTRD ) THEN + JD = I + ELSE + ID = I + END IF + CALL MB04QC( 'No Structure', TRANC, TRAND, TRANQ, + $ 'Forward', STOREV, STOREW, M-I+1, N, IB, + $ V(I,I), LDV, W(I,I), LDW, DWORK(PDRS), NB, + $ DWORK(PDT), NB, C(IC,JC), LDC, D(ID,JD), + $ LDD, DWORK(PDW) ) + 20 CONTINUE + END IF + END IF + DWORK(1) = DBLE( WRKOPT ) +C + RETURN +C *** Last line of MB04QB *** + END diff --git a/mex/sources/libslicot/MB04QC.f b/mex/sources/libslicot/MB04QC.f new file mode 100644 index 000000000..44d6a9ebd --- /dev/null +++ b/mex/sources/libslicot/MB04QC.f @@ -0,0 +1,1223 @@ + SUBROUTINE MB04QC( STRUCT, TRANA, TRANB, TRANQ, DIRECT, STOREV, + $ STOREW, M, N, K, V, LDV, W, LDW, RS, LDRS, T, + $ LDT, A, LDA, B, LDB, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply the orthogonal symplectic block reflector +C +C [ I+V*T*V' V*R*S*V' ] +C Q = [ ] +C [ -V*R*S*V' I+V*T*V' ] +C +C or its transpose to a real 2m-by-n matrix [ op(A); op(B) ] from +C the left. +C The k-by-k upper triangular blocks of the matrices +C +C [ S1 ] [ T11 T12 T13 ] +C R = [ R1 R2 R3 ], S = [ S2 ], T = [ T21 T22 T23 ], +C [ S3 ] [ T31 T32 T33 ] +C +C with R2 unit and S1, R3, T21, T31, T32 strictly upper triangular, +C are stored rowwise in the arrays RS and T, respectively. +C +C ARGUMENTS +C +C Mode Parameters +C +C STRUCT CHARACTER*1 +C Specifies the structure of the first blocks of A and B: +C = 'Z': the leading K-by-N submatrices of op(A) and op(B) +C are (implicitly) assumed to be zero; +C = 'N'; no structure to mention. +C +C TRANA CHARACTER*1 +C Specifies the form of op( A ) as follows: +C = 'N': op( A ) = A; +C = 'T': op( A ) = A'; +C = 'C': op( A ) = A'. +C +C TRANB CHARACTER*1 +C Specifies the form of op( B ) as follows: +C = 'N': op( B ) = B; +C = 'T': op( B ) = B'; +C = 'C': op( B ) = B'. +C +C DIRECT CHARACTER*1 +C This is a dummy argument, which is reserved for future +C extensions of this subroutine. Not referenced. +C +C TRANQ CHARACTER*1 +C = 'N': apply Q; +C = 'T': apply Q'. +C +C STOREV CHARACTER*1 +C Specifies how the vectors which define the concatenated +C Householder reflectors contained in V are stored: +C = 'C': columnwise; +C = 'R': rowwise. +C +C STOREW CHARACTER*1 +C Specifies how the vectors which define the concatenated +C Householder reflectors contained in W are stored: +C = 'C': columnwise; +C = 'R': rowwise. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices op(A) and op(B). +C M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrices op(A) and op(B). +C N >= 0. +C +C K (input) INTEGER +C The order of the triangular matrices defining R, S and T. +C M >= K >= 0. +C +C V (input) DOUBLE PRECISION array, dimension +C (LDV,K) if STOREV = 'C', +C (LDV,M) if STOREV = 'R' +C On entry with STOREV = 'C', the leading M-by-K part of +C this array must contain in its columns the vectors which +C define the elementary reflector used to form parts of Q. +C On entry with STOREV = 'R', the leading K-by-M part of +C this array must contain in its rows the vectors which +C define the elementary reflector used to form parts of Q. +C +C LDV INTEGER +C The leading dimension of the array V. +C LDV >= MAX(1,M), if STOREV = 'C'; +C LDV >= MAX(1,K), if STOREV = 'R'. +C +C W (input) DOUBLE PRECISION array, dimension +C (LDW,K) if STOREW = 'C', +C (LDW,M) if STOREW = 'R' +C On entry with STOREW = 'C', the leading M-by-K part of +C this array must contain in its columns the vectors which +C define the elementary reflector used to form parts of Q. +C On entry with STOREW = 'R', the leading K-by-M part of +C this array must contain in its rows the vectors which +C define the elementary reflector used to form parts of Q. +C +C LDW INTEGER +C The leading dimension of the array W. +C LDW >= MAX(1,M), if STOREW = 'C'; +C LDW >= MAX(1,K), if STOREW = 'R'. +C +C RS (input) DOUBLE PRECISION array, dimension (K,6*K) +C On entry, the leading K-by-6*K part of this array must +C contain the upper triangular matrices defining the factors +C R and S of the symplectic block reflector Q. The +C (strictly) lower portions of this array are not +C referenced. +C +C LDRS INTEGER +C The leading dimension of the array RS. LDRS >= MAX(1,K). +C +C T (input) DOUBLE PRECISION array, dimension (K,9*K) +C On entry, the leading K-by-9*K part of this array must +C contain the upper triangular matrices defining the factor +C T of the symplectic block reflector Q. The (strictly) +C lower portions of this array are not referenced. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= MAX(1,K). +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA,N) if TRANA = 'N', +C (LDA,M) if TRANA = 'C' or TRANA = 'T' +C On entry with TRANA = 'N', the leading M-by-N part of this +C array must contain the matrix A. +C On entry with TRANA = 'T' or TRANA = 'C', the leading +C N-by-M part of this array must contain the matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,M), if TRANA = 'N'; +C LDA >= MAX(1,N), if TRANA = 'C' or TRANA = 'T'. +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,N) if TRANB = 'N', +C (LDB,M) if TRANB = 'C' or TRANB = 'T' +C On entry with TRANB = 'N', the leading M-by-N part of this +C array must contain the matrix B. +C On entry with TRANB = 'T' or TRANB = 'C', the leading +C N-by-M part of this array must contain the matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,M), if TRANB = 'N'; +C LDB >= MAX(1,N), if TRANB = 'C' or TRANB = 'T'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK), where +C LDWORK >= 8*N*K, if STRUCT = 'Z', +C LDWORK >= 9*N*K, if STRUCT = 'N'. +C +C REFERENCES +C +C [1] Kressner, D. +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 16*( M - K )*N + ( 26*K - 4 )*K*N floating +C point operations if STRUCT = 'Z' and additional ( 12*K + 2 )*K*N +C floating point operations if STRUCT = 'N'. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAESB). +C +C KEYWORDS +C +C Elementary matrix operations, orthogonal symplectic matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DIRECT, STOREV, STOREW, STRUCT, TRANA, TRANB, + $ TRANQ + INTEGER K, LDA, LDB, LDRS, LDT, LDV, LDW, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), RS(LDRS,*), + $ T(LDT,*), V(LDV,*), W(LDW,*) +C .. Local Scalars .. + LOGICAL LA1B1, LCOLV, LCOLW, LTRA, LTRB, LTRQ + INTEGER I, ITEMP, PDW1, PDW2, PDW3, PDW4, PDW5, PDW6, + $ PDW7, PDW8, PDW9, PR1, PR2, PR3, PS1, PS2, PS3, + $ PT11, PT12, PT13, PT21, PT22, PT23, PT31, PT32, + $ PT33 + DOUBLE PRECISION FACT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DLASET, DTRMM +C +C .. Executable Statements .. +C +C Quick return if possible. +C + IF ( M.LE.0 .OR. N.LE.0 ) + $ RETURN + LA1B1 = LSAME( STRUCT, 'N' ) + LCOLV = LSAME( STOREV, 'C' ) + LCOLW = LSAME( STOREW, 'C' ) + LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) + LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) + LTRQ = LSAME( TRANQ, 'T' ) .OR. LSAME( TRANQ, 'C' ) +C + PR1 = 1 + PR2 = PR1 + K + PR3 = PR2 + K + PS1 = PR3 + K + PS2 = PS1 + K + PS3 = PS2 + K + PT11 = 1 + PT12 = PT11 + K + PT13 = PT12 + K + PT21 = PT13 + K + PT22 = PT21 + K + PT23 = PT22 + K + PT31 = PT23 + K + PT32 = PT31 + K + PT33 = PT32 + K + PDW1 = 1 + PDW2 = PDW1 + N*K + PDW3 = PDW2 + N*K + PDW4 = PDW3 + N*K + PDW5 = PDW4 + N*K + PDW6 = PDW5 + N*K + PDW7 = PDW6 + N*K + PDW8 = PDW7 + N*K + PDW9 = PDW8 + N*K +C +C Update the matrix A. +C + IF ( LA1B1 ) THEN +C +C NZ1) DW7 := A1' +C + IF ( LTRA ) THEN + DO 10 I = 1, K + CALL DCOPY( N, A(1,I), 1, DWORK(PDW7+(I-1)*N), 1 ) + 10 CONTINUE + ELSE + DO 20 I = 1, N + CALL DCOPY( K, A(1,I), 1, DWORK(PDW7+I-1), N ) + 20 CONTINUE + END IF +C +C NZ2) DW1 := DW7*W1 +C + CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW1), 1 ) + IF ( LCOLW ) THEN + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, W, LDW, DWORK(PDW1), N ) + ELSE + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, + $ K, ONE, W, LDW, DWORK(PDW1), N ) + END IF +C +C NZ3) DW2 := DW7*V1 +C + CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW2), 1 ) + IF ( LCOLV ) THEN + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, DWORK(PDW2), N ) + ELSE + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, + $ K, ONE, V, LDV, DWORK(PDW2), N ) + END IF + FACT = ONE + ELSE + FACT = ZERO + END IF +C +C 1) DW1 := A2'*W2 +C + IF ( M.GT.K ) THEN + IF ( LTRA.AND.LCOLW ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, + $ A(1,K+1), LDA, W(K+1,1), LDW, FACT, DWORK(PDW1), + $ N ) + ELSE IF ( LTRA ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, + $ A(1,K+1), LDA, W(1,K+1), LDW, FACT, DWORK(PDW1), + $ N ) + ELSE IF ( LCOLW ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, + $ A(K+1,1), LDA, W(K+1,1), LDW, FACT, DWORK(PDW1), + $ N ) + ELSE + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ A(K+1,1), LDA, W(1,K+1), LDW, FACT, DWORK(PDW1), + $ N ) + END IF + ELSE IF ( .NOT.LA1B1 ) THEN + CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW1), N ) + END IF +C +C 2) DW2 := A2'*V2 +C + IF ( M.GT.K ) THEN + IF ( LTRA.AND.LCOLV ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, + $ A(1,K+1), LDA, V(K+1,1), LDV, FACT, DWORK(PDW2), + $ N ) + ELSE IF ( LTRA ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, + $ A(1,K+1), LDA, V(1,K+1), LDV, FACT, DWORK(PDW2), + $ N ) + ELSE IF ( LCOLV ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, + $ A(K+1,1), LDA, V(K+1,1), LDV, FACT, DWORK(PDW2), + $ N ) + ELSE + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ A(K+1,1), LDA, V(1,K+1), LDV, FACT, DWORK(PDW2), + $ N ) + END IF + ELSE IF ( .NOT.LA1B1 ) THEN + CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW2), N ) + END IF +C + IF ( LTRQ ) THEN +C +C 3) DW3 := DW1*T11 +C + CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) +C +C 4) DW4 := DW2*T31 +C + CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, T(1,PT31+1), LDT, DWORK(PDW4), N ) +C +C 5) DW3 := DW3 + DW4 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ4) DW8 := DW7*T21 +C + CALL DCOPY( N*(K-1), DWORK(PDW7), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, T(1,PT21+1), LDT, DWORK(PDW8), N ) +C +C NZ5) DW3 := DW3 + DW8 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) + END IF +C +C 6) DW4 := DW1*T12 +C + CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K, ONE, T(1,PT12), LDT, DWORK(PDW4), N ) +C +C 7) DW5 := DW2*T32 +C + CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW5), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW5), N ) +C +C 8) DW4 := DW4 + DW5 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4+N), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ6) DW8 := DW7*T22 +C + CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K, ONE, T(1,PT22), LDT, DWORK(PDW8), N ) +C +C NZ7) DW4 := DW4 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) + END IF +C +C 9) DW5 := DW2*T33 +C + CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT33), LDT, DWORK(PDW5), N ) +C +C 10) DW6 := DW1*T13 +C + CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW6), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K, ONE, T(1,PT13), LDT, DWORK(PDW6), N ) +C +C 11) DW5 := DW5 + DW6 +C + CALL DAXPY( N*K, ONE, DWORK(PDW6), 1, DWORK(PDW5), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ8) DW8 := DW7*T23 +C + CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K, ONE, T(1,PT23), LDT, DWORK(PDW8), N ) +C +C NZ9) DW5 := DW5 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) + END IF +C +C 12) DW1 := DW1*R1 +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PR1), LDRS, DWORK(PDW1), N ) +C +C 13) DW2 := DW2*R3 +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, RS(1,PR3+1), LDRS, DWORK(PDW2), N ) +C +C 14) DW1 := DW1 + DW2 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW2), 1, DWORK(PDW1+N), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ10) DW7 := DW7*R2 +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, + $ ONE, RS(1,PR2), LDRS, DWORK(PDW7), N ) +C +C NZ11) DW1 := DW1 + DW7 +C + CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW1), 1 ) + END IF +C +C Swap Pointers PDW1 <-> PDW2 +C + ITEMP = PDW2 + PDW2 = PDW1 + PDW1 = ITEMP + ELSE +C +C 3) DW3 := DW1*T11' +C + CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) +C +C 4) DW4 := DW2*T13' +C + CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT13), LDT, DWORK(PDW4), N ) +C +C 5) DW3 := DW3 + DW4 +C + CALL DAXPY( N*K, ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ4) DW8 := DW7*T12' +C + CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT12), LDT, DWORK(PDW8), N ) +C +C NZ5) DW3 := DW3 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) + END IF +C +C 6) DW4 := DW2*T23' +C + CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT23), LDT, DWORK(PDW4), N ) +C +C 7) DW5 := DW1*T21' +C + CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW5), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, + $ ONE, T(1,PT21+1), LDT, DWORK(PDW5), N ) +C +C 8) DW4 := DW4 + DW5 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ6) DW8 := DW7*T22' +C + CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT22), LDT, DWORK(PDW8), N ) +C +C NZ7) DW4 := DW4 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) + END IF +C +C 9) DW5 := DW2*T33' +C + CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT33), LDT, DWORK(PDW5), N ) +C +C 10) DW6 := DW1*T31' +C + CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW6), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, + $ ONE, T(1,PT31+1), LDT, DWORK(PDW6), N ) +C +C 11) DW5 := DW5 + DW6 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW6), 1, DWORK(PDW5), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ8) DW8 := DW7*T32' +C + CALL DCOPY( N*(K-1), DWORK(PDW7+N), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, + $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW8), N ) +C +C NZ9) DW5 := DW5 + DW8 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) + END IF +C +C 12) DW1 := DW1*S1' +C + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, + $ ONE, RS(1,PS1+1), LDRS, DWORK(PDW1+N), N ) +C +C 13) DW2 := DW2*S3' +C + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PS3), LDRS, DWORK(PDW2), N ) +C +C 14) DW2 := DW1 + DW2 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW1+N), 1, DWORK(PDW2), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ10) DW7 := DW7*S2' +C + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PS2), LDRS, DWORK(PDW7), N ) +C +C NZ11) DW2 := DW2 + DW7 +C + CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW2), 1 ) + END IF + END IF +C + IF ( LA1B1 ) THEN +C +C NZ12) DW9 := B1' +C + IF ( LTRB ) THEN + DO 30 I = 1, K + CALL DCOPY( N, B(1,I), 1, DWORK(PDW9+(I-1)*N), 1 ) + 30 CONTINUE + ELSE + DO 40 I = 1, N + CALL DCOPY( K, B(1,I), 1, DWORK(PDW9+I-1), N ) + 40 CONTINUE + END IF +C +C NZ13) DW1 := DW9*W1 +C + CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW1), 1 ) + IF ( LCOLW ) THEN + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, W, LDW, DWORK(PDW1), N ) + ELSE + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, + $ K, ONE, W, LDW, DWORK(PDW1), N ) + END IF +C +C NZ14) DW6 := DW9*V1 +C + CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW6), 1 ) + IF ( LCOLV ) THEN + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, DWORK(PDW6), N ) + ELSE + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, + $ K, ONE, V, LDV, DWORK(PDW6), N ) + END IF + END IF +C +C 15) DW1 := B2'*W2 +C + IF ( M.GT.K ) THEN + IF ( LTRB.AND.LCOLW ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, + $ B(1,K+1), LDB, W(K+1,1), LDW, FACT, DWORK(PDW1), + $ N ) + ELSE IF ( LTRB ) THEN +C +C Critical Position +C + CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, + $ B(1,K+1), LDB, W(1,K+1), LDW, FACT, DWORK(PDW1), + $ N ) + ELSE IF ( LCOLW ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, + $ B(K+1,1), LDB, W(K+1,1), LDW, FACT, DWORK(PDW1), + $ N ) + ELSE + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ B(K+1,1), LDB, W(1,K+1), LDW, FACT, DWORK(PDW1), + $ N ) + END IF + ELSE IF ( .NOT.LA1B1 ) THEN + CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW1), N ) + END IF +C +C 16) DW6 := B2'*V2 +C + IF ( M.GT.K ) THEN + IF ( LTRB.AND.LCOLV ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, + $ B(1,K+1), LDB, V(K+1,1), LDV, FACT, DWORK(PDW6), + $ N ) + ELSE IF ( LTRB ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, + $ B(1,K+1), LDB, V(1,K+1), LDV, FACT, DWORK(PDW6), + $ N ) + ELSE IF ( LCOLV ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, + $ B(K+1,1), LDB, V(K+1,1), LDV, FACT, DWORK(PDW6), + $ N ) + ELSE + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ B(K+1,1), LDB, V(1,K+1), LDV, FACT, DWORK(PDW6), + $ N ) + END IF + ELSE IF ( .NOT.LA1B1 ) THEN + CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW6), N ) + END IF +C + IF ( LTRQ ) THEN +C +C 17) DW7 := DW1*R1 +C + CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW7), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PR1), LDRS, DWORK(PDW7), N ) +C +C 18) DW8 := DW6*R3 +C + CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, RS(1,PR3+1), LDRS, DWORK(PDW8), N ) +C +C 19) DW7 := DW7 + DW8 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW7+N), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ15) DW8 := DW9*R2 +C + CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, + $ ONE, RS(1,PR2), LDRS, DWORK(PDW8), N ) +C +C NZ16) DW7 := DW7 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) + END IF +C +C 20) DW8 := DW7*S1 +C + CALL DCOPY( N*(K-1), DWORK(PDW7), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, RS(1,PS1+1), LDRS, DWORK(PDW8), N ) +C +C 21) DW3 := DW3 - DW8 +C + CALL DAXPY( N*(K-1), -ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) +C +C 22) DW8 := DW7*S3 +C + CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K, ONE, RS(1,PS3), LDRS, DWORK(PDW8), N ) +C +C 23) DW5 := DW5 - DW8 +C + CALL DAXPY( N*K, -ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) +C +C 24) DW7 := DW7*S2 +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ -ONE, RS(1,PS2), LDRS, DWORK(PDW7), N ) + ELSE +C +C 17) DW7 := DW6*S3' +C + CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW7), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PS3), LDRS, DWORK(PDW7), N ) +C +C 18) DW8 := DW1*S1' +C + CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, + $ ONE, RS(1,PS1+1), LDRS, DWORK(PDW8), N ) +C +C 19) DW7 := DW7 + DW8 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ15) DW8 := DW9*S2' +C + CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PS2), LDRS, DWORK(PDW8), N ) +C +C NZ16) DW7 := DW7 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) + END IF +C +C 20) DW8 := DW7*R1' +C + CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PR1), LDRS, DWORK(PDW8), N ) +C +C 21) DW3 := DW3 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) +C +C 22) DW8 := DW7*R3' +C + CALL DCOPY( N*(K-1), DWORK(PDW7+N), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, + $ ONE, RS(1,PR3+1), LDRS, DWORK(PDW8), N ) +C +C 23) DW5 := DW5 + DW8 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) +C +C 24) DW7 := DW7*R2' +C + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, RS(1,PR2), LDRS, DWORK(PDW7), N ) + END IF +C +C 25) A2 := A2 + W2*DW3' +C + IF ( M.GT.K ) THEN + IF ( LTRA.AND.LCOLW ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, + $ DWORK(PDW3), N, W(K+1,1), LDW, ONE, A(1,K+1), + $ LDA ) + ELSE IF ( LTRA ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, + $ DWORK(PDW3), N, W(1,K+1), LDW, ONE, A(1,K+1), + $ LDA ) + ELSE IF ( LCOLW ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, + $ W(K+1,1), LDW, DWORK(PDW3), N, ONE, A(K+1,1), + $ LDA ) + ELSE + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, + $ W(1,K+1), LDW, DWORK(PDW3), N, ONE, A(K+1,1), + $ LDA ) + END IF + END IF +C +C 26) A2 := A2 + V2*DW5' +C + IF ( M.GT.K ) THEN + IF ( LTRA.AND.LCOLV ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, + $ DWORK(PDW5), N, V(K+1,1), LDV, ONE, A(1,K+1), + $ LDA ) + ELSE IF ( LTRA ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, + $ DWORK(PDW5), N, V(1,K+1), LDV, ONE, A(1,K+1), + $ LDA ) + ELSE IF ( LCOLV ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, + $ V(K+1,1), LDV, DWORK(PDW5), N, ONE, A(K+1,1), + $ LDA ) + ELSE + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, + $ V(1,K+1), LDV, DWORK(PDW5), N, ONE, A(K+1,1), + $ LDA ) + END IF + END IF +C +C 27) DW4 := DW4 + DW7 +C + CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW4), 1 ) +C +C 28) DW3 := DW3*W1' +C + IF ( LCOLW ) THEN + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, + $ W, LDW, DWORK(PDW3), N ) + ELSE + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, + $ ONE, W, LDW, DWORK(PDW3), N ) + END IF +C +C 29) DW4 := DW4 + DW3 +C + CALL DAXPY( N*K, ONE, DWORK(PDW3), 1, DWORK(PDW4), 1 ) +C +C 30) DW5 := DW5*V1' +C + IF ( LCOLV ) THEN + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, + $ V, LDV, DWORK(PDW5), N ) + ELSE + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, + $ ONE, V, LDV, DWORK(PDW5), N ) + END IF +C +C 31) DW4 := DW4 + DW5 +C + CALL DAXPY( N*K, ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) +C +C 32) A1 := A1 + DW4' +C + IF ( LA1B1 ) THEN + IF ( LTRA ) THEN + DO 50 I = 1, K + CALL DAXPY( N, ONE, DWORK(PDW4+(I-1)*N), 1, A(1,I), 1 ) + 50 CONTINUE + ELSE + DO 60 I = 1, N + CALL DAXPY( K, ONE, DWORK(PDW4+I-1), N, A(1,I), 1 ) + 60 CONTINUE + END IF + ELSE + IF ( LTRA ) THEN + DO 70 I = 1, K + CALL DCOPY( N, DWORK(PDW4+(I-1)*N), 1, A(1,I), 1 ) + 70 CONTINUE + ELSE + DO 80 I = 1, N + CALL DCOPY( K, DWORK(PDW4+I-1), N, A(1,I), 1 ) + 80 CONTINUE + END IF + END IF +C +C Update the matrix B. +C + IF ( LTRQ ) THEN +C +C 33) DW3 := DW1*T11 +C + CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) +C +C 34) DW4 := DW6*T31 +C + CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, T(1,PT31+1), LDT, DWORK(PDW4), N ) +C +C 35) DW3 := DW3 + DW4 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ17) DW8 := DW9*T21 +C + CALL DCOPY( N*(K-1), DWORK(PDW9), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, T(1,PT21+1), LDT, DWORK(PDW8), N ) +C +C NZ18) DW3 := DW3 + DW8 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) + END IF +C +C 36) DW4 := DW2*S1 +C + CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, RS(1,PS1+1), LDRS, DWORK(PDW4), N ) +C +C 37) DW3 := DW3 + DW4 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) +C +C 38) DW4 := DW1*T12 +C + CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT12), LDT, DWORK(PDW4), N ) +C +C 38) DW5 := DW6*T32 +C + CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW5), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW5), N ) +C +C 40) DW4 := DW4 + DW5 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4+N), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ19) DW8 := DW9*T22 +C + CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K, ONE, T(1,PT22), LDT, DWORK(PDW8), N ) +C +C NZ20) DW4 := DW4 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) + END IF +C +C 41) DW5 := DW2*S2 +C + CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PS2), LDRS, DWORK(PDW5), N ) +C +C 42) DW4 := DW4 + DW5 +C + CALL DAXPY( N*K, ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) +C +C 43) DW6 := DW6*T33 +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT33), LDT, DWORK(PDW6), N ) +C +C 44) DW1 := DW1*T13 +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT13), LDT, DWORK(PDW1), N ) +C +C 45) DW6 := DW6 + DW1 +C + CALL DAXPY( N*K, ONE, DWORK(PDW1), 1, DWORK(PDW6), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ19) DW9 := DW9*T23 +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K, ONE, T(1,PT23), LDT, DWORK(PDW9), N ) +C +C NZ20) DW6 := DW6 + DW9 +C + CALL DAXPY( N*K, ONE, DWORK(PDW9), 1, DWORK(PDW6), 1 ) + END IF +C +C 46) DW2 := DW2*S3 +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PS3), LDRS, DWORK(PDW2), N ) +C +C 45) DW6 := DW6 + DW2 +C + CALL DAXPY( N*K, ONE, DWORK(PDW2), 1, DWORK(PDW6), 1 ) + ELSE +C +C 33) DW3 := DW1*T11' +C + CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) +C +C 34) DW4 := DW6*T13' +C + CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT13), LDT, DWORK(PDW4), N ) +C +C 35) DW3 := DW3 + DW4 +C + CALL DAXPY( N*K, ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ17) DW8 := DW9*T12' +C + CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT12), LDT, DWORK(PDW8), N ) +C +C NZ18) DW3 := DW3 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) + END IF +C +C 36) DW4 := DW2*R1' +C + CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PR1), LDRS, DWORK(PDW4), N ) +C +C 37) DW3 := DW3 - DW4 +C + CALL DAXPY( N*K, -ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) +C +C 38) DW4 := DW6*T23' +C + CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT23), LDT, DWORK(PDW4), N ) +C +C 39) DW5 := DW1*T21' +C + CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW5), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, + $ ONE, T(1,PT21+1), LDT, DWORK(PDW5), N ) +C +C 40) DW4 := DW4 + DW5 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ19) DW8 := DW9*T22' +C + CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT22), LDT, DWORK(PDW8), N ) +C +C NZ20) DW4 := DW4 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) + END IF +C +C 41) DW5 := DW2*R2' +C + CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, RS(1,PR2), LDRS, DWORK(PDW5), N ) +C +C 42) DW4 := DW4 - DW5 +C + CALL DAXPY( N*K, -ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) +C +C 43) DW6 := DW6*T33' +C + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT33), LDT, DWORK(PDW6), N ) +C +C 44) DW1 := DW1*T31' +C + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, + $ ONE, T(1,PT31+1), LDT, DWORK(PDW1+N), N ) +C +C 45) DW6 := DW6 + DW1 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW1+N), 1, DWORK(PDW6), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ19) DW9 := DW9*T32' +C + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, + $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW9+N), N ) +C +C NZ20) DW6 := DW6 + DW9 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW9+N), 1, DWORK(PDW6), 1 ) + END IF +C +C 46) DW2 := DW2*R3' +C + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, + $ ONE, RS(1,PR3+1), LDRS, DWORK(PDW2+N), N ) +C +C 45) DW6 := DW6 - DW2 +C + CALL DAXPY( N*(K-1), -ONE, DWORK(PDW2+N), 1, DWORK(PDW6), 1 ) + END IF +C +C 46) B2 := B2 + W2*DW3' +C + IF ( M.GT.K ) THEN + IF ( LTRB.AND.LCOLW ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, + $ DWORK(PDW3), N, W(K+1,1), LDW, ONE, B(1,K+1), + $ LDB ) + ELSE IF ( LTRB ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, + $ DWORK(PDW3), N, W(1,K+1), LDW, ONE, B(1,K+1), + $ LDB ) + ELSE IF ( LCOLW ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, + $ W(K+1,1), LDW, DWORK(PDW3), N, ONE, B(K+1,1), + $ LDB ) + ELSE + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, + $ W(1,K+1), LDW, DWORK(PDW3), N, ONE, B(K+1,1), + $ LDB ) + END IF + END IF +C +C 47) B2 := B2 + V2*DW6' +C + IF ( M.GT.K ) THEN + IF ( LTRB.AND.LCOLV ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, + $ DWORK(PDW6), N, V(K+1,1), LDV, ONE, B(1,K+1), + $ LDB ) + ELSE IF ( LTRB ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, + $ DWORK(PDW6), N, V(1,K+1), LDV, ONE, B(1,K+1), + $ LDB ) + ELSE IF ( LCOLV ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, + $ V(K+1,1), LDV, DWORK(PDW6), N, ONE, B(K+1,1), + $ LDB ) + ELSE + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, + $ V(1,K+1), LDV, DWORK(PDW6), N, ONE, B(K+1,1), + $ LDB ) + END IF + END IF +C +C 48) DW3 := DW3*W1' +C + IF ( LCOLW ) THEN + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, + $ W, LDW, DWORK(PDW3), N ) + ELSE + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, + $ ONE, W, LDW, DWORK(PDW3), N ) + END IF +C +C 49) DW4 := DW4 + DW3 +C + CALL DAXPY( N*K, ONE, DWORK(PDW3), 1, DWORK(PDW4), 1 ) +C +C 50) DW6 := DW6*V1' +C + IF ( LCOLV ) THEN + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, + $ V, LDV, DWORK(PDW6), N ) + ELSE + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, + $ ONE, V, LDV, DWORK(PDW6), N ) + END IF +C +C 51) DW4 := DW4 + DW6 +C + CALL DAXPY( N*K, ONE, DWORK(PDW6), 1, DWORK(PDW4), 1 ) +C +C 52) B1 := B1 + DW4' +C + IF ( LA1B1 ) THEN + IF ( LTRB ) THEN + DO 90 I = 1, K + CALL DAXPY( N, ONE, DWORK(PDW4+(I-1)*N), 1, B(1,I), 1 ) + 90 CONTINUE + ELSE + DO 100 I = 1, N + CALL DAXPY( K, ONE, DWORK(PDW4+I-1), N, B(1,I), 1 ) + 100 CONTINUE + END IF + ELSE + IF ( LTRB ) THEN + DO 110 I = 1, K + CALL DCOPY( N, DWORK(PDW4+(I-1)*N), 1, B(1,I), 1 ) + 110 CONTINUE + ELSE + DO 120 I = 1, N + CALL DCOPY( K, DWORK(PDW4+I-1), N, B(1,I), 1 ) + 120 CONTINUE + END IF + END IF +C + RETURN +C *** Last line of MB04QC *** + END diff --git a/mex/sources/libslicot/MB04QF.f b/mex/sources/libslicot/MB04QF.f new file mode 100644 index 000000000..f2be26ce0 --- /dev/null +++ b/mex/sources/libslicot/MB04QF.f @@ -0,0 +1,532 @@ + SUBROUTINE MB04QF( DIRECT, STOREV, STOREW, N, K, V, LDV, W, LDW, + $ CS, TAU, RS, LDRS, T, LDT, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To form the triangular block factors R, S and T of a symplectic +C block reflector SH, which is defined as a product of 2k +C concatenated Householder reflectors and k Givens rotators, +C +C SH = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) +C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) +C .... +C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). +C +C The upper triangular blocks of the matrices +C +C [ S1 ] [ T11 T12 T13 ] +C R = [ R1 R2 R3 ], S = [ S2 ], T = [ T21 T22 T23 ], +C [ S3 ] [ T31 T32 T33 ] +C +C with R2 unit and S1, R3, T21, T31, T32 strictly upper triangular, +C are stored rowwise in the arrays RS and T, respectively. +C +C ARGUMENTS +C +C Mode Parameters +C +C DIRECT CHARACTER*1 +C This is a dummy argument, which is reserved for future +C extensions of this subroutine. Not referenced. +C +C STOREV CHARACTER*1 +C Specifies how the vectors which define the concatenated +C Householder F(i) reflectors are stored: +C = 'C': columnwise; +C = 'R': rowwise. +C +C STOREW CHARACTER*1 +C Specifies how the vectors which define the concatenated +C Householder H(i) reflectors are stored: +C = 'C': columnwise; +C = 'R': rowwise. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the Householder reflectors F(i) and H(i). +C N >= 0. +C +C K (input) INTEGER +C The number of Givens rotators. K >= 1. +C +C V (input) DOUBLE PRECISION array, dimension +C (LDV,K) if STOREV = 'C', +C (LDV,N) if STOREV = 'R' +C On entry with STOREV = 'C', the leading N-by-K part of +C this array must contain in its i-th column the vector +C which defines the elementary reflector F(i). +C On entry with STOREV = 'R', the leading K-by-N part of +C this array must contain in its i-th row the vector +C which defines the elementary reflector F(i). +C +C LDV INTEGER +C The leading dimension of the array V. +C LDV >= MAX(1,N), if STOREV = 'C'; +C LDV >= K, if STOREV = 'R'. +C +C W (input) DOUBLE PRECISION array, dimension +C (LDW,K) if STOREW = 'C', +C (LDW,N) if STOREW = 'R' +C On entry with STOREW = 'C', the leading N-by-K part of +C this array must contain in its i-th column the vector +C which defines the elementary reflector H(i). +C On entry with STOREV = 'R', the leading K-by-N part of +C this array must contain in its i-th row the vector +C which defines the elementary reflector H(i). +C +C LDW INTEGER +C The leading dimension of the array W. +C LDW >= MAX(1,N), if STOREW = 'C'; +C LDW >= K, if STOREW = 'R'. +C +C CS (input) DOUBLE PRECISION array, dimension (2*K) +C On entry, the first 2*K elements of this array must +C contain the cosines and sines of the symplectic Givens +C rotators G(i). +C +C TAU (input) DOUBLE PRECISION array, dimension (K) +C On entry, the first K elements of this array must +C contain the scalar factors of the elementary reflectors +C F(i). +C +C RS (output) DOUBLE PRECISION array, dimension (K,6*K) +C On exit, the leading K-by-6*K part of this array contains +C the upper triangular matrices defining the factors R and +C S of the symplectic block reflector SH. The (strictly) +C lower portions of this array are not used. +C +C LDRS INTEGER +C The leading dimension of the array RS. LDRS >= K. +C +C T (output) DOUBLE PRECISION array, dimension (K,9*K) +C On exit, the leading K-by-9*K part of this array contains +C the upper triangular matrices defining the factor T of the +C symplectic block reflector SH. The (strictly) lower +C portions of this array are not used. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= K. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (3*K) +C +C REFERENCES +C +C [1] Kressner, D. +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C NUMERICAL ASPECTS +C +C The algorithm requires ( 4*K - 2 )*K*N + 19/3*K*K*K + 1/2*K*K +C + 43/6*K - 4 floating point operations. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAEST). +C +C KEYWORDS +C +C Elementary matrix operations, orthogonal symplectic matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DIRECT, STOREV, STOREW + INTEGER K, LDRS, LDT, LDV, LDW, N +C .. Array Arguments .. + DOUBLE PRECISION CS(*), DWORK(*), RS(LDRS,*), T(LDT,*), + $ TAU(*), V(LDV,*), W(LDW,*) +C .. Local Scalars .. + LOGICAL LCOLV, LCOLW + INTEGER I, J, K2, PR1, PR2, PR3, PS1, PS2, PS3, PT11, + $ PT12, PT13, PT21, PT22, PT23, PT31, PT32, PT33 + DOUBLE PRECISION CM1, TAUI, VII, WII +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DSCAL, DTRMV +C +C .. Executable Statements .. +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + LCOLV = LSAME( STOREV, 'C' ) + LCOLW = LSAME( STOREW, 'C' ) +C + K2 = K + K + PR1 = 0 + PR2 = PR1 + K + PR3 = PR2 + K + PS1 = PR3 + K + PS2 = PS1 + K + PS3 = PS2 + K +C + PT11 = 0 + PT12 = PT11 + K + PT13 = PT12 + K + PT21 = PT13 + K + PT22 = PT21 + K + PT23 = PT22 + K + PT31 = PT23 + K + PT32 = PT31 + K + PT33 = PT32 + K +C + DO 90 I = 1, K + TAUI = TAU(I) + VII = V(I,I) + V(I,I) = ONE + WII = W(I,I) + W(I,I) = ONE + IF ( WII.EQ.ZERO ) THEN + DO 10 J = 1, I + T(J,PT11+I) = ZERO + 10 CONTINUE + DO 20 J = 1, I-1 + T(J,PT21+I) = ZERO + 20 CONTINUE + DO 30 J = 1, I-1 + T(J,PT31+I) = ZERO + 30 CONTINUE + DO 40 J = 1, I-1 + RS(J,PS1+I) = ZERO + 40 CONTINUE + ELSE +C +C Treat first Householder reflection. +C + IF ( LCOLV.AND.LCOLW ) THEN +C +C Compute t1 = -wii * W(i:n,1:i-1)' * W(i:n,i). +C + CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, W(I,1), LDW, + $ W(I,I), 1, ZERO, DWORK, 1 ) +C +C Compute t2 = -wii * V(i:n,1:i-1)' * W(i:n,i). +C + CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, V(I,1), LDV, + $ W(I,I), 1, ZERO, DWORK(K+1), 1 ) + ELSE IF ( LCOLV ) THEN +C +C Compute t1 = -wii * W(1:i-1,i:n) * W(i,i:n)'. +C + CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, W(1,I), + $ LDW, W(I,I), LDW, ZERO, DWORK, 1 ) +C +C Compute t2 = -wii * V(i:n,1:i-1)' * W(i,i:n)'. +C + CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, V(I,1), LDV, + $ W(I,I), LDW, ZERO, DWORK(K+1), 1 ) + ELSE IF ( LCOLW ) THEN +C +C Compute t1 = -wii * W(i:n,1:i-1)' * W(i:n,i). +C + CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, W(I,1), LDW, + $ W(I,I), 1, ZERO, DWORK, 1 ) +C +C Compute t2 = -wii * V(1:i-1,i:n) * W(i:n,i). +C + CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, V(1,I), + $ LDV, W(I,I), 1, ZERO, DWORK(K+1), 1 ) + ELSE +C +C Compute t1 = -wii * W(1:i-1,i:n) * W(i,i:n)'. +C + CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, W(1,I), + $ LDW, W(I,I), LDW, ZERO, DWORK, 1 ) +C +C Compute t2 = -wii * V(1:i-1,i:n) * W(i,i:n)'. +C + CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, V(1,I), + $ LDV, W(I,I), LDW, ZERO, DWORK(K+1), 1 ) + END IF +C +C T11(1:i-1,i) := T11(1:i-1,1:i-1)*t1 + T13(1:i-1,1:i-1)*t2 +C + CALL DCOPY( I-1, DWORK, 1, T(1,PT11+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT11+1), LDT, T(1,PT11+I), 1 ) + CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT13+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT13+1), LDT, T(1,PT13+I), 1 ) + CALL DAXPY( I-1, ONE, T(1,PT13+I), 1, T(1,PT11+I), 1 ) + T(I,PT11+I) = -WII +C + IF ( I.GT.1 ) THEN +C +C T21(1:i-1,i) := T21(1:i-1,1:i-1)*t1 + T23(1:i-1,1:i-1)*t2 +C + CALL DCOPY( I-2, DWORK(2), 1, T(1,PT21+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2, + $ T(1,PT21+2), LDT, T(1,PT21+I), 1 ) + T(I-1, PT21+I) = ZERO + CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT23+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT23+1), LDT, T(1,PT23+I), 1 ) + CALL DAXPY( I-1, ONE, T(1,PT23+I), 1, T(1,PT21+I), 1 ) +C +C T31(1:i-1,i) := T31(1:i-1,1:i-1)*t1 + T33(1:i-1,1:i-1)*t2 +C + CALL DCOPY( I-2, DWORK(2), 1, T(1,PT31+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2, + $ T(1,PT31+2), LDT, T(1,PT31+I), 1 ) + T(I-1, PT31+I) = ZERO + CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT33+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT33+1), LDT, T(1,PT33+I), 1 ) + CALL DAXPY( I-1, ONE, T(1,PT33+I), 1, T(1,PT31+I), 1 ) +C +C S1(1:i-1,i) := S1(1:i-1,1:i-1)*t1 + S3(1:i-1,1:i-1)*t2 +C + CALL DCOPY( I-2, DWORK(2), 1, RS(1,PS1+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2, + $ RS(1,PS1+2), LDRS, RS(1,PS1+I), 1 ) + RS(I-1, PS1+I) = ZERO + CALL DCOPY( I-1, DWORK(K+1), 1, RS(1,PS3+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ RS(1,PS3+1), LDRS, RS(1,PS3+I), 1 ) + CALL DAXPY( I-1, ONE, RS(1,PS3+I), 1, RS(1,PS1+I), 1 ) + END IF + END IF +C +C Treat Givens rotation. +C + CM1 = CS(2*I-1) - ONE + IF ( LCOLW ) THEN + CALL DCOPY( I, W(I,1), LDW, DWORK, 1 ) + ELSE + CALL DCOPY( I, W(1,I), 1, DWORK, 1 ) + END IF + IF ( LCOLV ) THEN + CALL DCOPY( I-1, V(I,1), LDV, DWORK(K+1), 1 ) + ELSE + CALL DCOPY( I-1, V(1,I), 1, DWORK(K+1), 1 ) + END IF +C +C R1(1:i,i) = T11(1:i,1:i) * dwork(1:i) +C + [ T13(1:i-1,1:i-1) * dwork(k+1:k+i-1); 0 ] +C + CALL DCOPY( I, DWORK, 1, RS(1,PR1+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I, + $ T(1,PT11+1), LDT, RS(1,PR1+I), 1 ) + CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT13+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT13+1), LDT, T(1,PT13+I), 1 ) + CALL DAXPY( I-1, ONE, T(1,PT13+I), 1, RS(1,PR1+I), 1 ) +C +C R2(1:i-1,i) = T21(1:i-1,2:i) * W(i,2:i) +C + T23(1:i-1,1:i-1) * V(i,1:i-1) +C + CALL DCOPY( I-1, DWORK(2), 1, RS(1,PR2+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT21+2), LDT, RS(1,PR2+I), 1 ) + CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT23+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT23+1), LDT, T(1,PT23+I), 1 ) + CALL DAXPY( I-1, ONE, T(1,PT23+I), 1, RS(1,PR2+I), 1 ) +C +C R3(1:i-1,i) = T31(1:i-1,2:i) * dwork(2:i) +C + T33(1:i-1,1:i-1) * dwork(k+1:k+i-1) +C + CALL DCOPY( I-1, DWORK(2), 1, RS(1,PR3+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT31+2), LDT, RS(1,PR3+I), 1 ) + CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT33+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT33+1), LDT, T(1,PT33+I), 1 ) + CALL DAXPY( I-1, ONE, T(1,PT33+I), 1, RS(1,PR3+I), 1 ) +C +C S2(1:i-1,i) = S1(1:i-1,2:i) * dwork(2:i) +C + S3(1:i-1,1:i-1) * dwork(k+1:k+i-1) +C + CALL DCOPY( I-1, DWORK(2), 1, RS(1,PS2+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ RS(1,PS1+2), LDRS, RS(1,PS2+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ RS(1,PS3+1), LDRS, DWORK(K+1), 1 ) + CALL DAXPY( I-1, ONE, DWORK(K+1), 1, RS(1,PS2+I), 1 ) + RS(I,PS2+I) = -CS(2*I) +C +C T12(1:i,i) = [ R1(1:i-1,1:i-1)*S2(1:i-1,i); 0 ] +C + (c-1) * R1(1:i,i) +C + CALL DCOPY( I-1, RS(1,PS2+I), 1, T(1,PT12+I), 1 ) + CALL DSCAL( I-1, CM1, RS(1,PS2+I), 1) + CALL DSCAL( I-1, CS(2*I), T(1,PT12+I), 1 ) + CALL DCOPY( I-1, T(1,PT12+I), 1, T(1,PT22+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ RS(1,PR1+1), LDRS, T(1,PT12+I), 1 ) + T(I,PT12+I) = ZERO + CALL DAXPY( I, CM1, RS(1,PR1+I), 1, T(1,PT12+I), 1 ) +C +C T22(1:i-1,i) = R2(1:i-1,1:i-1)*S2(1:i-1,i) + (c-1)*R2(1:i-1,i) +C + IF (I.GT.1) + $ CALL DCOPY( I-2, T(2,PT22+I), 1, T(1,PT32+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Unit diagonal', I-1, + $ RS(1,PR2+1), LDRS, T(1,PT22+I), 1 ) + CALL DAXPY( I-1, CM1, RS(1,PR2+I), 1, T(1,PT22+I), 1 ) + T(I,PT22+I) = CM1 +C +C T32(1:i-1,i) = R3(1:i-1,1:i-1)*S2(1:i-1,i) + (c-1)*R3(1:i-1,i) +C + IF ( I.GT.1 ) THEN + CALL DTRMV( 'Upper', 'No transpose', 'Non-Unit', I-2, + $ RS(1,PR3+2), LDRS, T(1,PT32+I), 1 ) + T(I-1,PT32+I) = ZERO + CALL DAXPY( I-1, CM1, RS(1,PR3+I), 1, T(1,PT32+I), 1 ) + END IF +C + IF ( TAUI.EQ.ZERO ) THEN + DO 50 J = 1, I + T(J,PT13+I) = ZERO + 50 CONTINUE + DO 60 J = 1, I + T(J,PT23+I) = ZERO + 60 CONTINUE + DO 70 J = 1, I + T(J,PT33+I) = ZERO + 70 CONTINUE + DO 80 J = 1, I + RS(J,PS3+I) = ZERO + 80 CONTINUE + ELSE +C +C Treat second Householder reflection. +C + IF ( LCOLV.AND.LCOLW ) THEN +C +C Compute t1 = -tau(i) * W(i:n,1:i)' * V(i:n,i). +C + CALL DGEMV( 'Transpose', N-I+1, I, -TAUI, W(I,1), + $ LDW, V(I,I), 1, ZERO, DWORK, 1 ) +C +C Compute t2 = -tau(i) * V(i:n,1:i-1)' * V(i:n,i). +C + CALL DGEMV( 'Transpose', N-I+1, I-1, -TAUI, V(I,1), + $ LDV, V(I,I), 1, ZERO, DWORK(K2+1), 1 ) + ELSE IF ( LCOLV ) THEN +C +C Compute t1 = -tau(i) * W(1:i,i:n) * V(i:n,i). +C + CALL DGEMV( 'No Transpose', I, N-I+1, -TAUI, W(1,I), + $ LDW, V(I,I), 1, ZERO, DWORK, 1 ) +C +C Compute t2 = -tau(i) * V(i:n,1:i-1)' * V(i:n,i). +C + CALL DGEMV( 'Transpose', N-I+1, I-1, -TAUI, V(I,1), + $ LDV, V(I,I), 1, ZERO, DWORK(K2+1), 1 ) + ELSE IF ( LCOLW ) THEN +C +C Compute t1 = -tau(i) * W(i:n,1:i)' * V(i,i:n)'. +C + CALL DGEMV( 'Transpose', N-I+1, I, -TAUI, W(I,1), + $ LDW, V(I,I), LDV, ZERO, DWORK, 1 ) +C +C Compute t2 = -tau(i) * V(1:i-1,i:n) * V(i,i:n)'. +C + CALL DGEMV( 'No Transpose', I-1, N-I+1, -TAUI, V(1,I), + $ LDV, V(I,I), LDV, ZERO, DWORK(K2+1), 1 ) + ELSE +C +C Compute t1 = -tau(i) * W(1:i,i:n) * V(i,i:n)'. +C + CALL DGEMV( 'No Transpose', I, N-I+1, -TAUI, W(1,I), + $ LDW, V(I,I), LDV, ZERO, DWORK, 1 ) +C +C Compute t2 = -tau(i) * V(1:i-1,i:n) * V(i,i:n)'. +C + CALL DGEMV( 'No Transpose', I-1, N-I+1, -TAUI, V(1,I), + $ LDV, V(I,I), LDV, ZERO, DWORK(K2+1), 1 ) + END IF +C +C T13(1:i,i) := T11(1:i,1:i)*t1 - tau(i)*T12(1:i,i) +C + [T13(1:i-1,1:i-1)*t2;0] +C + CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT13+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT13+1), LDT, T(1,PT13+I), 1 ) + T(I,PT13+I) = ZERO + CALL DCOPY( I, DWORK, 1, DWORK(K+1), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I, + $ T(1,PT11+1), LDT, DWORK(K+1), 1 ) + CALL DAXPY( I, ONE, DWORK(K+1), 1, T(1,PT13+I), 1 ) + CALL DAXPY( I, -TAUI, T(1,PT12+I), 1, T(1,PT13+I), 1 ) +C +C T23(1:i,i) := T21(1:i,1:i)*t1 - tau(i)*T22(1:i,i) +C + [T23(1:i-1,1:i-1)*t2;0] +C + CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT23+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT23+1), LDT, T(1,PT23+I), 1 ) + T(I,PT23+I) = ZERO + CALL DCOPY( I-1, DWORK(2), 1, DWORK(K+1), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT21+2), LDT, DWORK(K+1), 1 ) + CALL DAXPY( I-1, ONE, DWORK(K+1), 1, T(1,PT23+I), 1 ) + CALL DAXPY( I, -TAUI, T(1,PT22+I), 1, T(1,PT23+I), 1 ) +C +C T33(1:i,i) := T31(1:i,1:i)*t1 - tau(i)*T32(1:i,i) +C + [T33(1:i-1,1:i-1)*t2;0] +C + CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT33+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT33+1), LDT, T(1,PT33+I), 1 ) + CALL DCOPY( I-1, DWORK(2), 1, DWORK(K+1), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT31+2), LDT, DWORK(K+1), 1 ) + CALL DAXPY( I-1, ONE, DWORK(K+1), 1, T(1,PT33+I), 1 ) + CALL DAXPY( I-1, -TAUI, T(1,PT32+I), 1, T(1,PT33+I), 1 ) + T(I,PT33+I) = -TAUI +C +C S3(1:i,i) := S1(1:i,1:i)*t1 - tau(i)*S2(1:i,i) +C + [S3(1:i-1,1:i-1)*t2;0] +C + CALL DCOPY( I-1, DWORK(K2+1), 1, RS(1,PS3+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ RS(1,PS3+1), LDRS, RS(1,PS3+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ RS(1,PS1+2), LDRS, DWORK(2), 1 ) + CALL DAXPY( I-1, ONE, DWORK(2), 1, RS(1,PS3+I), 1 ) + RS(I,PS3+I) = ZERO + CALL DAXPY( I, -TAUI, RS(1,PS2+I), 1, RS(1,PS3+I), 1 ) + END IF + W(I,I) = WII + V(I,I) = VII + 90 CONTINUE +C + RETURN +C *** Last line of MB04QF *** + END diff --git a/mex/sources/libslicot/MB04QU.f b/mex/sources/libslicot/MB04QU.f new file mode 100644 index 000000000..6ae814da0 --- /dev/null +++ b/mex/sources/libslicot/MB04QU.f @@ -0,0 +1,472 @@ + SUBROUTINE MB04QU( TRANC, TRAND, TRANQ, STOREV, STOREW, M, N, K, + $ V, LDV, W, LDW, C, LDC, D, LDD, CS, TAU, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To overwrite general real m-by-n matrices C and D, or their +C transposes, with +C +C [ op(C) ] +C Q * [ ] if TRANQ = 'N', or +C [ op(D) ] +C +C T [ op(C) ] +C Q * [ ] if TRANQ = 'T', +C [ op(D) ] +C +C where Q is defined as the product of symplectic reflectors and +C Givens rotators, +C +C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) +C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) +C .... +C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). +C +C Unblocked version. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANC CHARACTER*1 +C Specifies the form of op( C ) as follows: +C = 'N': op( C ) = C; +C = 'T': op( C ) = C'; +C = 'C': op( C ) = C'. +C +C STOREV CHARACTER*1 +C Specifies how the vectors which define the concatenated +C Householder reflectors contained in V are stored: +C = 'C': columnwise; +C = 'R': rowwise. +C +C STOREW CHARACTER*1 +C Specifies how the vectors which define the concatenated +C Householder reflectors contained in W are stored: +C = 'C': columnwise; +C = 'R': rowwise. +C +C TRAND CHARACTER*1 +C Specifies the form of op( D ) as follows: +C = 'N': op( D ) = D; +C = 'T': op( D ) = D'; +C = 'C': op( D ) = D'. +C +C TRANQ CHARACTER*1 +C = 'N': apply Q; +C = 'T': apply Q'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices op(C) and op(D). +C M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrices op(C) and op(D). +C N >= 0. +C +C K (input) INTEGER +C The number of elementary reflectors whose product defines +C the matrix Q. M >= K >= 0. +C +C V (input) DOUBLE PRECISION array, dimension +C (LDV,K) if STOREV = 'C', +C (LDV,M) if STOREV = 'R' +C On entry with STOREV = 'C', the leading M-by-K part of +C this array must contain in its columns the vectors which +C define the elementary reflectors F(i). +C On entry with STOREV = 'R', the leading K-by-M part of +C this array must contain in its rows the vectors which +C define the elementary reflectors F(i). +C +C LDV INTEGER +C The leading dimension of the array V. +C LDV >= MAX(1,M), if STOREV = 'C'; +C LDV >= MAX(1,K), if STOREV = 'R'. +C +C W (input) DOUBLE PRECISION array, dimension +C (LDW,K) if STOREW = 'C', +C (LDW,M) if STOREW = 'R' +C On entry with STOREW = 'C', the leading M-by-K part of +C this array must contain in its columns the vectors which +C define the elementary reflectors H(i). +C On entry with STOREW = 'R', the leading K-by-M part of +C this array must contain in its rows the vectors which +C define the elementary reflectors H(i). +C +C LDW INTEGER +C The leading dimension of the array W. +C LDW >= MAX(1,M), if STOREW = 'C'; +C LDW >= MAX(1,K), if STOREW = 'R'. +C +C C (input/output) DOUBLE PRECISION array, dimension +C (LDC,N) if TRANC = 'N', +C (LDC,M) if TRANC = 'T' or TRANC = 'C' +C On entry with TRANC = 'N', the leading M-by-N part of +C this array must contain the matrix C. +C On entry with TRANC = 'C' or TRANC = 'T', the leading +C N-by-M part of this array must contain the transpose of +C the matrix C. +C On exit with TRANC = 'N', the leading M-by-N part of +C this array contains the updated matrix C. +C On exit with TRANC = 'C' or TRANC = 'T', the leading +C N-by-M part of this array contains the transpose of the +C updated matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= MAX(1,M), if TRANC = 'N'; +C LDC >= MAX(1,N), if TRANC = 'T' or TRANC = 'C'. +C +C D (input/output) DOUBLE PRECISION array, dimension +C (LDD,N) if TRAND = 'N', +C (LDD,M) if TRAND = 'T' or TRAND = 'C' +C On entry with TRAND = 'N', the leading M-by-N part of +C this array must contain the matrix D. +C On entry with TRAND = 'C' or TRAND = 'T', the leading +C N-by-M part of this array must contain the transpose of +C the matrix D. +C On exit with TRAND = 'N', the leading M-by-N part of +C this array contains the updated matrix D. +C On exit with TRAND = 'C' or TRAND = 'T', the leading +C N-by-M part of this array contains the transpose of the +C updated matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= MAX(1,M), if TRAND = 'N'; +C LDD >= MAX(1,N), if TRAND = 'T' or TRAND = 'C'. +C +C CS (input) DOUBLE PRECISION array, dimension (2*K) +C On entry, the first 2*K elements of this array must +C contain the cosines and sines of the symplectic Givens +C rotators G(i). +C +C TAU (input) DOUBLE PRECISION array, dimension (K) +C On entry, the first K elements of this array must +C contain the scalar factors of the elementary reflectors +C F(i). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -20, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSMSQ). +C +C KEYWORDS +C +C Elementary matrix operations, orthogonal symplectic matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +C .. Scalar Arguments .. + CHARACTER STOREV, STOREW, TRANC, TRAND, TRANQ + INTEGER INFO, K, LDC, LDD, LDV, LDW, LDWORK, M, N +C .. Array Arguments .. + DOUBLE PRECISION CS(*), DWORK(*), C(LDC,*), D(LDD,*), V(LDV,*), + $ W(LDW,*), TAU(*) +C .. Local Scalars .. + LOGICAL LCOLV, LCOLW, LTRC, LTRD, LTRQ + INTEGER I + DOUBLE PRECISION NU +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARF, DROT, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + LCOLV = LSAME( STOREV, 'C' ) + LCOLW = LSAME( STOREW, 'C' ) + LTRC = LSAME( TRANC, 'T' ) .OR. LSAME( TRANC, 'C' ) + LTRD = LSAME( TRAND, 'T' ) .OR. LSAME( TRAND, 'C' ) + LTRQ = LSAME( TRANQ, 'T' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( LTRC.OR.LSAME( TRANC, 'N' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( LTRD .OR. LSAME( TRAND, 'N' ) ) ) THEN + INFO = -2 + ELSE IF ( .NOT.( LTRQ .OR. LSAME( TRANQ, 'N' ) ) ) THEN + INFO = -3 + ELSE IF ( .NOT.( LCOLV.OR. LSAME( STOREV, 'R' ) ) ) THEN + INFO = -4 + ELSE IF ( .NOT.( LCOLW.OR. LSAME( STOREW, 'R' ) ) ) THEN + INFO = -5 + ELSE IF ( M.LT.0 ) THEN + INFO = -6 + ELSE IF ( N.LT.0 ) THEN + INFO = -7 + ELSE IF ( K.LT.0 .OR. K.GT.M ) THEN + INFO = -8 + ELSE IF ( ( LCOLV.AND.LDV.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.LCOLV.AND.LDV.LT.MAX( 1, K ) ) ) THEN + INFO = -10 + ELSE IF ( ( LCOLW.AND.LDW.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.LCOLW.AND.LDW.LT.MAX( 1, K ) ) ) THEN + INFO = -12 + ELSE IF ( ( LTRC.AND.LDC.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LTRC.AND.LDC.LT.MAX( 1, M ) ) ) THEN + INFO = -14 + ELSE IF ( ( LTRD.AND.LDD.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LTRD.AND.LDD.LT.MAX( 1, M ) ) ) THEN + INFO = -16 + ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN + DWORK(1) = DBLE( MAX( 1, N ) ) + INFO = -20 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04QU', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( K, M, N ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + IF ( LTRQ ) THEN + DO 10 I = 1, K +C +C Apply H(I) to C(I:M,:) and D(I:M,:) from the left. +C + NU = W(I,I) + W(I,I) = ONE + IF ( LCOLW ) THEN + IF ( LTRC ) THEN + CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, C(1,I), + $ LDC, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, C(I,1), + $ LDC, DWORK ) + END IF + IF ( LTRD ) THEN + CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, D(1,I), + $ LDD, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, D(I,1), + $ LDD, DWORK ) + END IF + ELSE + IF ( LTRC ) THEN + CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, + $ C(1,I), LDC, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, C(I,1), + $ LDC, DWORK ) + END IF + IF ( LTRD ) THEN + CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, + $ D(1,I), LDD, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, D(I,1), + $ LDD, DWORK ) + END IF + END IF + W(I,I) = NU +C +C Apply G(i) to C(I,:) and D(I,:) from the left. +C + IF ( LTRC.AND.LTRD ) THEN + CALL DROT( N, C(1,I), 1, D(1,I), 1, CS(2*I-1), CS(2*I) ) + ELSE IF ( LTRC ) THEN + CALL DROT( N, C(1,I), 1, D(I,1), LDD, CS(2*I-1), + $ CS(2*I) ) + ELSE IF ( LTRD ) THEN + CALL DROT( N, C(I,1), LDC, D(1,I), 1, CS(2*I-1), + $ CS(2*I) ) + ELSE + CALL DROT( N, C(I,1), LDC, D(I,1), LDD, CS(2*I-1), + $ CS(2*I) ) + END IF +C +C Apply F(I) to C(I:M,:) and D(I:M,:) from the left. +C + NU = V(I,I) + V(I,I) = ONE + IF ( LCOLV ) THEN + IF ( LTRC ) THEN + CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), + $ C(1,I), LDC, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), + $ C(I,1), LDC, DWORK ) + END IF + IF ( LTRD ) THEN + CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), + $ D(1,I), LDD, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), + $ D(I,1), LDD, DWORK ) + END IF + ELSE + IF ( LTRC ) THEN + CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), + $ C(1,I), LDC, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), + $ C(I,1), LDC, DWORK ) + END IF + IF ( LTRD ) THEN + CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), + $ D(1,I), LDD, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), + $ D(I,1), LDD, DWORK ) + END IF + END IF + V(I,I) = NU + 10 CONTINUE + ELSE + DO 20 I = K, 1, -1 +C +C Apply F(I) to C(I:M,:) and D(I:M,:) from the left. +C + NU = V(I,I) + V(I,I) = ONE + IF ( LCOLV ) THEN + IF ( LTRC ) THEN + CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), + $ C(1,I), LDC, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), + $ C(I,1), LDC, DWORK ) + END IF + IF ( LTRD ) THEN + CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), + $ D(1,I), LDD, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), + $ D(I,1), LDD, DWORK ) + END IF + ELSE + IF ( LTRC ) THEN + CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), + $ C(1,I), LDC, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), + $ C(I,1), LDC, DWORK ) + END IF + IF ( LTRD ) THEN + CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), + $ D(1,I), LDD, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), + $ D(I,1), LDD, DWORK ) + END IF + END IF + V(I,I) = NU +C +C Apply G(i) to C(I,:) and D(I,:) from the left. +C + IF ( LTRC.AND.LTRD ) THEN + CALL DROT( N, C(1,I), 1, D(1,I), 1, CS(2*I-1), -CS(2*I) ) + ELSE IF ( LTRC ) THEN + CALL DROT( N, C(1,I), 1, D(I,1), LDD, CS(2*I-1), + $ -CS(2*I) ) + ELSE IF ( LTRD ) THEN + CALL DROT( N, C(I,1), LDC, D(1,I), 1, CS(2*I-1), + $ -CS(2*I) ) + ELSE + CALL DROT( N, C(I,1), LDC, D(I,1), LDD, CS(2*I-1), + $ -CS(2*I) ) + END IF +C +C Apply H(I) to C(I:M,:) and D(I:M,:) from the left. +C + NU = W(I,I) + W(I,I) = ONE + IF ( LCOLW ) THEN + IF ( LTRC ) THEN + CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, C(1,I), + $ LDC, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, C(I,1), + $ LDC, DWORK ) + END IF + IF ( LTRD ) THEN + CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, D(1,I), + $ LDD, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, D(I,1), + $ LDD, DWORK ) + END IF + ELSE + IF ( LTRC ) THEN + CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, + $ C(1,I), LDC, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, C(I,1), + $ LDC, DWORK ) + END IF + IF ( LTRD ) THEN + CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, + $ D(1,I), LDD, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, D(I,1), + $ LDD, DWORK ) + END IF + END IF + W(I,I) = NU + 20 CONTINUE + END IF +C + DWORK(1) = DBLE( MAX( 1, N ) ) +C *** Last line of MB04QU *** + END diff --git a/mex/sources/libslicot/MB04TB.f b/mex/sources/libslicot/MB04TB.f new file mode 100644 index 000000000..3d5ad6614 --- /dev/null +++ b/mex/sources/libslicot/MB04TB.f @@ -0,0 +1,677 @@ + SUBROUTINE MB04TB( TRANA, TRANB, N, ILO, A, LDA, B, LDB, G, LDG, + $ Q, LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a symplectic URV (SURV) decomposition of a real +C 2N-by-2N matrix H, +C +C [ op(A) G ] [ op(R11) R12 ] +C H = [ ] = U R V' = U * [ ] * V' , +C [ Q op(B) ] [ 0 op(R22) ] +C +C where A, B, G, Q, R12 are real N-by-N matrices, op(R11) is a real +C N-by-N upper triangular matrix, op(R22) is a real N-by-N lower +C Hessenberg matrix and U, V are 2N-by-2N orthogonal symplectic +C matrices. Blocked version. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANA CHARACTER*1 +C Specifies the form of op( A ) as follows: +C = 'N': op( A ) = A; +C = 'T': op( A ) = A'; +C = 'C': op( A ) = A'. +C +C TRANB CHARACTER*1 +C Specifies the form of op( B ) as follows: +C = 'N': op( B ) = B; +C = 'T': op( B ) = B'; +C = 'C': op( B ) = B'. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C ILO (input) INTEGER +C It is assumed that op(A) is already upper triangular, +C op(B) is lower triangular and Q is zero in rows and +C columns 1:ILO-1. ILO is normally set by a previous call +C to MB04DD; otherwise it should be set to 1. +C 1 <= ILO <= N, if N > 0; ILO=1, if N=0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, the leading N-by-N part of this array contains +C the triangular matrix R11, and in the zero part +C information about the elementary reflectors used to +C compute the SURV decomposition. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix B. +C On exit, the leading N-by-N part of this array contains +C the Hessenberg matrix R22, and in the zero part +C information about the elementary reflectors used to +C compute the SURV decomposition. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix G. +C On exit, the leading N-by-N part of this array contains +C the matrix R12. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix Q. +C On exit, the leading N-by-N part of this array contains +C information about the elementary reflectors used to +C compute the SURV decomposition. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= MAX(1,N). +C +C CSL (output) DOUBLE PRECISION array, dimension (2N) +C On exit, the first 2N elements of this array contain the +C cosines and sines of the symplectic Givens rotations +C applied from the left-hand side used to compute the SURV +C decomposition. +C +C CSR (output) DOUBLE PRECISION array, dimension (2N-2) +C On exit, the first 2N-2 elements of this array contain the +C cosines and sines of the symplectic Givens rotations +C applied from the right-hand side used to compute the SURV +C decomposition. +C +C TAUL (output) DOUBLE PRECISION array, dimension (N) +C On exit, the first N elements of this array contain the +C scalar factors of some of the elementary reflectors +C applied form the left-hand side. +C +C TAUR (output) DOUBLE PRECISION array, dimension (N-1) +C On exit, the first N-1 elements of this array contain the +C scalar factors of some of the elementary reflectors +C applied form the right-hand side. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK, (16*N + 5)*NB, where NB is the optimal +C block size determined by the function UE01MD. +C On exit, if INFO = -16, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrices U and V are represented as products of symplectic +C reflectors and Givens rotators +C +C U = diag( HU(1),HU(1) ) GU(1) diag( FU(1),FU(1) ) +C diag( HU(2),HU(2) ) GU(2) diag( FU(2),FU(2) ) +C .... +C diag( HU(n),HU(n) ) GU(n) diag( FU(n),FU(n) ), +C +C V = diag( HV(1),HV(1) ) GV(1) diag( FV(1),FV(1) ) +C diag( HV(2),HV(2) ) GV(2) diag( FV(2),FV(2) ) +C .... +C diag( HV(n-1),HV(n-1) ) GV(n-1) diag( FV(n-1),FV(n-1) ). +C +C Each HU(i) has the form +C +C HU(i) = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in +C Q(i+1:n,i), and tau in Q(i,i). +C +C Each FU(i) has the form +C +C FU(i) = I - nu * w * w' +C +C where nu is a real scalar, and w is a real vector with +C w(1:i-1) = 0 and w(i) = 1; w(i+1:n) is stored on exit in +C A(i+1:n,i), if op(A) = 'N', and in A(i,i+1:n), otherwise. The +C scalar nu is stored in TAUL(i). +C +C Each GU(i) is a Givens rotator acting on rows i and n+i, +C where the cosine is stored in CSL(2*i-1) and the sine in +C CSL(2*i). +C +C Each HV(i) has the form +C +C HV(i) = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in +C Q(i,i+2:n), and tau in Q(i,i+1). +C +C Each FV(i) has the form +C +C FV(i) = I - nu * w * w' +C +C where nu is a real scalar, and w is a real vector with +C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in +C B(i,i+2:n), if op(B) = 'N', and in B(i+2:n,i), otherwise. +C The scalar nu is stored in TAUR(i). +C +C Each GV(i) is a Givens rotator acting on columns i+1 and n+i+1, +C where the cosine is stored in CSR(2*i-1) and the sine in +C CSR(2*i). +C +C NUMERICAL ASPECTS +C +C The algorithm requires 80/3*N**3 + ( 64*NB + 77 )*N**2 + +C ( -16*NB + 48 )*NB*N + O(N) floating point operations, where +C NB is the used block size, and is numerically backward stable. +C +C REFERENCES +C +C [1] Benner, P., Mehrmann, V., and Xu, H. +C A numerically stable, structure preserving method for +C computing the eigenvalues of real Hamiltonian or symplectic +C pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998. +C +C [2] Kressner, D. +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DGESUB). +C +C KEYWORDS +C +C Elementary matrix operations, Matrix decompositions, Hamiltonian +C matrix +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TRANA, TRANB + INTEGER ILO, INFO, LDA, LDB, LDG, LDQ, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*), + $ G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*) +C .. Local Scalars .. + LOGICAL LTRA, LTRB + INTEGER I, IB, IERR, NB, NBMIN, NH, NIB, NNB, NX, PDW, + $ PXA, PXB, PXG, PXQ, PYA, PYB, PYG, PYQ, WRKOPT +C .. External Functions .. + LOGICAL LSAME + INTEGER UE01MD + EXTERNAL LSAME, UE01MD +C .. External Subroutines .. + EXTERNAL DGEMM, MB03XU, MB04TS, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) + LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) + IF ( .NOT.LTRA .AND. .NOT.LSAME( TRANA, 'N' ) ) THEN + INFO = -1 + ELSE IF ( .NOT.LTRB .AND. .NOT.LSAME( TRANB, 'N' ) ) THEN + INFO = -2 + ELSE IF ( N.LT.0 ) THEN + INFO = -3 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF ( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN + DWORK(1) = DBLE( MAX( 1, N ) ) + INFO = -18 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04TB', -INFO ) + RETURN + END IF +C +C Set elements 1:ILO-1 of CSL, CSR, TAUL and TAUR to their default +C values. +C + DO 10 I = 1, ILO - 1 + CSL(2*I-1) = ONE + CSL(2*I) = ZERO + CSR(2*I-1) = ONE + CSR(2*I) = ZERO + TAUL(I) = ZERO + TAUR(I) = ZERO + 10 CONTINUE +C +C Quick return if possible. +C + NH = N - ILO + 1 + IF ( NH.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Determine the block size. +C + NB = UE01MD( 1, 'MB04TB', TRANA // TRANB, N, ILO, -1 ) + NBMIN = 2 + WRKOPT = N + IF ( NB.GT.1 .AND. NB.LT.NH ) THEN +C +C Determine when to cross over from blocked to unblocked code. +C + NX = MAX( NB, UE01MD( 3, 'MB04TB', TRANA // TRANB, N, ILO, -1 ) + $ ) + IF ( NX.LT.NH ) THEN +C +C Check whether workspace is large enough for blocked code. +C + WRKOPT = 16*N*NB + 5*NB + IF ( LDWORK.LT.WRKOPT ) THEN +C +C Not enough workspace available. Determine minimum value +C of NB, and reduce NB. +C + NBMIN = MAX( 2, UE01MD( 2, 'MB04TB', TRANA // TRANB, N, + $ ILO, -1 ) ) + NB = LDWORK / ( 16*N + 5 ) + END IF + END IF + END IF +C + NNB = N*NB + PYB = 1 + PYQ = PYB + 2*NNB + PYA = PYQ + 2*NNB + PYG = PYA + 2*NNB + PXQ = PYG + 2*NNB + PXA = PXQ + 2*NNB + PXG = PXA + 2*NNB + PXB = PXG + 2*NNB + PDW = PXB + 2*NNB +C + IF ( NB.LT.NBMIN .OR. NB.GE.NH ) THEN +C +C Use unblocked code. +C + I = ILO +C + ELSE IF ( LTRA .AND. LTRB ) THEN + DO 20 I = ILO, N-NX-1, NB + IB = MIN( NB, N-I ) + NIB = N*IB +C +C Reduce rows and columns i:i+nb-1 to symplectic URV form and +C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which +C are needed to update the unreduced parts of the matrices. +C + CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(I,1), LDA, + $ B(1,I), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), + $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, + $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, + $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), + $ TAUR(I), DWORK(PDW) ) +C +C Update the submatrix A(i+1+ib:n,1:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, + $ IB, ONE, DWORK(PXA+NB+1), N, Q(I+IB,I), LDQ, + $ ONE, A(I+IB+1,I+IB), LDA ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB, + $ N-I-IB+1, IB, ONE, DWORK(PXA+NIB+NB+1), N, + $ A(I,I+IB), LDA, ONE, A(I+IB+1,I+IB), LDA ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB, + $ ONE, Q(I,I+IB+1), LDQ, DWORK(PYA), N, ONE, + $ A(I+IB+1,1), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N, IB, + $ ONE, B(I+IB+1,I), LDB, DWORK(PYA+NIB), N, ONE, + $ A(I+IB+1,1), LDA ) +C +C Update the submatrix Q(i+ib:n,i+1+ib:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, + $ ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, A(I,I+IB), LDA, DWORK(PXQ+NIB+NB+1), N, + $ ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, + $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, + $ B(I+IB+1,I), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) +C +C Update the matrix G. +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, + $ G(I+IB,1), LDG ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, A(I,I+IB), LDA, DWORK(PXG+NIB), N, ONE, + $ G(I+IB,1), LDG ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, + $ G(1,I+IB+1), LDG ) + CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYG+NIB), N, B(I+IB+1,I), LDB, ONE, + $ G(1,I+IB+1), LDG ) +C +C Update the submatrix B(1:n,i+ib:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1, + $ IB, ONE, DWORK(PXB), N, Q(I+IB,I), LDQ, + $ ONE, B(1,I+IB), LDB ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB+1, IB, + $ ONE, DWORK(PXB+NIB), N, A(I,I+IB), LDA, ONE, + $ B(1,I+IB), LDB ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N-I-IB+1, + $ IB, ONE, Q(I,I+IB+1), LDQ, DWORK(PYB+NB), N, + $ ONE, B(I+IB+1,I+IB), LDB ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, + $ IB, ONE, B(I+IB+1,I), LDB, DWORK(PYB+NIB+NB), N, + $ ONE, B(I+IB+1,I+IB), LDB ) + 20 CONTINUE +C + ELSE IF ( LTRA ) THEN + DO 30 I = ILO, N-NX-1, NB + IB = MIN( NB, N-I ) + NIB = N*IB +C +C Reduce rows and columns i:i+nb-1 to symplectic URV form and +C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which +C are needed to update the unreduced parts of the matrices. +C + CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(I,1), LDA, + $ B(I,1), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), + $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, + $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, + $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), + $ TAUR(I), DWORK(PDW) ) +C +C Update the submatrix A(i+1+ib:n,1:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, + $ IB, ONE, DWORK(PXA+NB+1), N, Q(I+IB,I), LDQ, + $ ONE, A(I+IB+1,I+IB), LDA ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB, + $ N-I-IB+1, IB, ONE, DWORK(PXA+NIB+NB+1), N, + $ A(I,I+IB), LDA, ONE, A(I+IB+1,I+IB), LDA ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB, + $ ONE, Q(I,I+IB+1), LDQ, DWORK(PYA), N, ONE, + $ A(I+IB+1,1), LDA ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB, + $ ONE, B(I,I+IB+1), LDB, DWORK(PYA+NIB), N, ONE, + $ A(I+IB+1,1), LDA ) +C +C Update the submatrix Q(i+ib:n,i+1+ib:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, + $ ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, A(I,I+IB), LDA, DWORK(PXQ+NIB+NB+1), N, + $ ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, + $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, + $ B(I,I+IB+1), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) +C +C Update the matrix G. +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, + $ G(I+IB,1), LDG ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, A(I,I+IB), LDA, DWORK(PXG+NIB), N, ONE, + $ G(I+IB,1), LDG ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, + $ G(1,I+IB+1), LDG ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYG+NIB), N, B(I,I+IB+1), LDB, ONE, + $ G(1,I+IB+1), LDG ) +C +C Update the submatrix B(i+ib:n,1:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, + $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXB), N, + $ ONE, B(I+IB,1), LDB ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, A(I,I+IB), LDA, DWORK(PXB+NIB), N, ONE, + $ B(I+IB,1), LDB ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYB+NB), N, Q(I,I+IB+1), + $ LDQ, ONE, B(I+IB,I+IB+1), LDB ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYB+NIB+NB), N, + $ B(I,I+IB+1), LDB, ONE, B(I+IB,I+IB+1), LDB ) + 30 CONTINUE +C + ELSE IF ( LTRB ) THEN + DO 40 I = ILO, N-NX-1, NB + IB = MIN( NB, N-I ) + NIB = N*IB +C +C Reduce rows and columns i:i+nb-1 to symplectic URV form and +C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which +C are needed to update the unreduced parts of the matrices. +C + CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(1,I), LDA, + $ B(1,I), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), + $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, + $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, + $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), + $ TAUR(I), DWORK(PDW) ) +C +C Update the submatrix A(1:n,i+1+ib:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXA+NB+1), N, + $ ONE, A(I+IB,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, A(I+IB,I), LDA, DWORK(PXA+NIB+NB+1), N, + $ ONE, A(I+IB,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYA), N, Q(I,I+IB+1), LDQ, ONE, + $ A(1,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYA+NIB), N, B(I+IB+1,I), LDB, ONE, + $ A(1,I+IB+1), LDA ) +C +C Update the submatrix Q(i+ib:n,i+1+ib:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, + $ ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, A(I+IB,I), LDA, DWORK(PXQ+NIB+NB+1), N, + $ ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, + $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No Transpose', 'Transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, + $ B(I+IB+1,I), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) +C +C Update the matrix G. +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, + $ G(I+IB,1), LDG ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, A(I+IB,I), LDA, DWORK(PXG+NIB), N, ONE, + $ G(I+IB,1), LDG ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, + $ G(1,I+IB+1), LDG ) + CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYG+NIB), N, B(I+IB+1,I), LDB, ONE, + $ G(1,I+IB+1), LDG ) +C +C Update the submatrix B(1:n,i+ib:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1, + $ IB, ONE, DWORK(PXB), N, Q(I+IB,I), LDQ, + $ ONE, B(1,I+IB), LDB ) + CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1, IB, + $ ONE, DWORK(PXB+NIB), N, A(I+IB,I), LDA, ONE, + $ B(1,I+IB), LDB ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N-I-IB+1, + $ IB, ONE, Q(I,I+IB+1), LDQ, DWORK(PYB+NB), N, + $ ONE, B(I+IB+1,I+IB), LDB ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, + $ IB, ONE, B(I+IB+1,I), LDB, DWORK(PYB+NIB+NB), N, + $ ONE, B(I+IB+1,I+IB), LDB ) + 40 CONTINUE +C + ELSE + DO 50 I = ILO, N-NX-1, NB + IB = MIN( NB, N-I ) + NIB = N*IB +C +C Reduce rows and columns i:i+nb-1 to symplectic URV form and +C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which +C are needed to update the unreduced parts of the matrices. +C + CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(1,I), LDA, + $ B(I,1), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), + $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, + $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, + $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), + $ TAUR(I), DWORK(PDW) ) +C +C Update the submatrix A(1:n,i+1+ib:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXA+NB+1), N, + $ ONE, A(I+IB,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, A(I+IB,I), LDA, DWORK(PXA+NIB+NB+1), N, + $ ONE, A(I+IB,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYA), N, Q(I,I+IB+1), LDQ, ONE, + $ A(1,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYA+NIB), N, B(I,I+IB+1), LDB, ONE, + $ A(1,I+IB+1), LDA ) +C +C Update the submatrix Q(i+ib:n,i+1+ib:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, + $ ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, A(I+IB,I), LDA, DWORK(PXQ+NIB+NB+1), N, + $ ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, + $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, + $ B(I,I+IB+1), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) +C +C Update the matrix G. +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, + $ G(I+IB,1), LDG ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, A(I+IB,I), LDA, DWORK(PXG+NIB), N, ONE, + $ G(I+IB,1), LDG ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, + $ G(1,I+IB+1), LDG ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYG+NIB), N, B(I,I+IB+1), LDB, ONE, + $ G(1,I+IB+1), LDG ) +C +C Update the submatrix B(i+ib:n,1:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, + $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXB), N, + $ ONE, B(I+IB,1), LDB ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, A(I+IB,I), LDA, DWORK(PXB+NIB), N, ONE, + $ B(I+IB,1), LDB ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYB+NB), N, Q(I,I+IB+1), + $ LDQ, ONE, B(I+IB,I+IB+1), LDB ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYB+NIB+NB), N, + $ B(I,I+IB+1), LDB, ONE, B(I+IB,I+IB+1), LDB ) + 50 CONTINUE + END IF +C +C Unblocked code to reduce the rest of the matrices. +C + CALL MB04TS( TRANA, TRANB, N, I, A, LDA, B, LDB, G, LDG, Q, LDQ, + $ CSL, CSR, TAUL, TAUR, DWORK, LDWORK, IERR ) +C + DWORK(1) = DBLE( WRKOPT ) +C + RETURN +C *** Last line of MB04TB *** + END diff --git a/mex/sources/libslicot/MB04TS.f b/mex/sources/libslicot/MB04TS.f new file mode 100644 index 000000000..66f085f5f --- /dev/null +++ b/mex/sources/libslicot/MB04TS.f @@ -0,0 +1,519 @@ + SUBROUTINE MB04TS( TRANA, TRANB, N, ILO, A, LDA, B, LDB, G, LDG, + $ Q, LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a symplectic URV (SURV) decomposition of a real +C 2N-by-2N matrix H: +C +C [ op(A) G ] T [ op(R11) R12 ] T +C H = [ ] = U R V = U * [ ] * V , +C [ Q op(B) ] [ 0 op(R22) ] +C +C where A, B, G, Q, R12 are real N-by-N matrices, op(R11) is a real +C N-by-N upper triangular matrix, op(R22) is a real N-by-N lower +C Hessenberg matrix and U, V are 2N-by-2N orthogonal symplectic +C matrices. Unblocked version. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANA CHARACTER*1 +C Specifies the form of op( A ) as follows: +C = 'N': op( A ) = A; +C = 'T': op( A ) = A'; +C = 'C': op( A ) = A'. +C +C TRANB CHARACTER*1 +C Specifies the form of op( B ) as follows: +C = 'N': op( B ) = B; +C = 'T': op( B ) = B'; +C = 'C': op( B ) = B'. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C ILO (input) INTEGER +C It is assumed that op(A) is already upper triangular, +C op(B) is lower triangular and Q is zero in rows and +C columns 1:ILO-1. ILO is normally set by a previous call +C to MB04DD; otherwise it should be set to 1. +C 1 <= ILO <= N, if N > 0; ILO=1, if N=0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, the leading N-by-N part of this array contains +C the triangular matrix R11, and in the zero part +C information about the elementary reflectors used to +C compute the SURV decomposition. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix B. +C On exit, the leading N-by-N part of this array contains +C the Hessenberg matrix R22, and in the zero part +C information about the elementary reflectors used to +C compute the SURV decomposition. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix G. +C On exit, the leading N-by-N part of this array contains +C the matrix R12. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix Q. +C On exit, the leading N-by-N part of this array contains +C information about the elementary reflectors used to +C compute the SURV decomposition. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDG >= MAX(1,N). +C +C CSL (output) DOUBLE PRECISION array, dimension (2N) +C On exit, the first 2N elements of this array contain the +C cosines and sines of the symplectic Givens rotations +C applied from the left-hand side used to compute the SURV +C decomposition. +C +C CSR (output) DOUBLE PRECISION array, dimension (2N-2) +C On exit, the first 2N-2 elements of this array contain the +C cosines and sines of the symplectic Givens rotations +C applied from the right-hand side used to compute the SURV +C decomposition. +C +C TAUL (output) DOUBLE PRECISION array, dimension (N) +C On exit, the first N elements of this array contain the +C scalar factors of some of the elementary reflectors +C applied from the left-hand side. +C +C TAUR (output) DOUBLE PRECISION array, dimension (N-1) +C On exit, the first N-1 elements of this array contain the +C scalar factors of some of the elementary reflectors +C applied from the right-hand side. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -16, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrices U and V are represented as products of symplectic +C reflectors and Givens rotators +C +C U = diag( HU(1),HU(1) ) GU(1) diag( FU(1),FU(1) ) +C diag( HU(2),HU(2) ) GU(2) diag( FU(2),FU(2) ) +C .... +C diag( HU(n),HU(n) ) GU(n) diag( FU(n),FU(n) ), +C +C V = diag( HV(1),HV(1) ) GV(1) diag( FV(1),FV(1) ) +C diag( HV(2),HV(2) ) GV(2) diag( FV(2),FV(2) ) +C .... +C diag( HV(n-1),HV(n-1) ) GV(n-1) diag( FV(n-1),FV(n-1) ). +C +C Each HU(i) has the form +C +C HU(i) = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in +C Q(i+1:n,i), and tau in Q(i,i). +C +C Each FU(i) has the form +C +C FU(i) = I - nu * w * w' +C +C where nu is a real scalar, and w is a real vector with +C w(1:i-1) = 0 and w(i) = 1; w(i+1:n) is stored on exit in +C A(i+1:n,i), if op(A) = 'N', and in A(i,i+1:n), otherwise. The +C scalar nu is stored in TAUL(i). +C +C Each GU(i) is a Givens rotator acting on rows i and n+i, +C where the cosine is stored in CSL(2*i-1) and the sine in +C CSL(2*i). +C +C Each HV(i) has the form +C +C HV(i) = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in +C Q(i,i+2:n), and tau in Q(i,i+1). +C +C Each FV(i) has the form +C +C FV(i) = I - nu * w * w' +C +C where nu is a real scalar, and w is a real vector with +C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in +C B(i,i+2:n), if op(B) = 'N', and in B(i+2:n,i), otherwise. +C The scalar nu is stored in TAUR(i). +C +C Each GV(i) is a Givens rotator acting on columns i+1 and n+i+1, +C where the cosine is stored in CSR(2*i-1) and the sine in +C CSR(2*i). +C +C NUMERICAL ASPECTS +C +C The algorithm requires 80/3 N**3 + 20 N**2 + O(N) floating point +C operations and is numerically backward stable. +C +C REFERENCES +C +C [1] Benner, P., Mehrmann, V., and Xu, H. +C A numerically stable, structure preserving method for +C computing the eigenvalues of real Hamiltonian or symplectic +C pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DGESUV). +C +C KEYWORDS +C +C Elementary matrix operations, Matrix decompositions, Hamiltonian +C matrix +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TRANA, TRANB + INTEGER ILO, INFO, LDA, LDB, LDG, LDQ, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*), + $ G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*) +C .. Local Scalars .. + LOGICAL LTRA, LTRB + INTEGER I + DOUBLE PRECISION ALPHA, C, NU, S, TEMP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARF, DLARFG, DLARTG, DROT, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) + LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) + IF ( .NOT.LTRA .AND. .NOT.LSAME( TRANA, 'N' ) ) THEN + INFO = -1 + ELSE IF ( .NOT.LTRB .AND. .NOT.LSAME( TRANB, 'N' ) ) THEN + INFO = -2 + ELSE IF ( N.LT.0 ) THEN + INFO = -3 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF ( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN + DWORK(1) = DBLE( MAX( 1, N ) ) + INFO = -18 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04TS', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + DO 10 I = ILO, N + ALPHA = Q(I,I) + IF ( I.LT.N ) THEN +C +C Generate elementary reflector HU(i) to annihilate Q(i+1:n,i) +C + CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, NU ) +C +C Apply HU(i) from the left. +C + Q(I,I) = ONE + CALL DLARF( 'Left', N-I+1, N-I, Q(I,I), 1, NU, Q(I,I+1), + $ LDQ, DWORK ) + IF ( LTRA ) THEN + CALL DLARF( 'Right', N-I+1, N-I+1, Q(I,I), 1, NU, A(I,I), + $ LDA, DWORK ) + ELSE + CALL DLARF( 'Left', N-I+1, N-I+1, Q(I,I), 1, NU, A(I,I), + $ LDA, DWORK ) + END IF + IF ( LTRB ) THEN + CALL DLARF( 'Right', N, N-I+1, Q(I,I), 1, NU, B(1,I), + $ LDB, DWORK ) + ELSE + CALL DLARF( 'Left', N-I+1, N, Q(I,I), 1, NU, B(I,1), LDB, + $ DWORK ) + END IF + CALL DLARF( 'Left', N-I+1, N, Q(I,I), 1, NU, G(I,1), LDG, + $ DWORK ) + Q(I,I) = NU + ELSE + Q(I,I) = ZERO + END IF +C +C Generate symplectic Givens rotator GU(i) to annihilate Q(i,i). +C + TEMP = A(I,I) + CALL DLARTG( TEMP, ALPHA, C, S, A(I,I) ) +C +C Apply G(i) from the left. +C + IF ( LTRA ) THEN + CALL DROT( N-I, A(I+1,I), 1, Q(I,I+1), LDQ, C, S ) + ELSE + CALL DROT( N-I, A(I,I+1), LDA, Q(I,I+1), LDQ, C, S ) + END IF + IF ( LTRB ) THEN + CALL DROT( N, G(I,1), LDG, B(1,I), 1, C, S ) + ELSE + CALL DROT( N, G(I,1), LDG, B(I,1), LDB, C, S ) + END IF + CSL(2*I-1) = C + CSL(2*I) = S +C + IF ( I.LT.N ) THEN + IF ( LTRA ) THEN +C +C Generate elementary reflector FU(i) to annihilate +C A(i,i+1:n). +C + CALL DLARFG( N-I+1, A(I,I), A(I,I+1), LDA, TAUL(I) ) +C +C Apply FU(i) from the left. +C + TEMP = A(I,I) + A(I,I) = ONE + CALL DLARF( 'Right', N-I, N-I+1, A(I,I), LDA, TAUL(I), + $ A(I+1,I), LDA, DWORK ) + CALL DLARF( 'Left', N-I+1, N-I, A(I,I), LDA, TAUL(I), + $ Q(I,I+1), LDQ, DWORK ) + IF ( LTRB ) THEN + CALL DLARF( 'Right', N, N-I+1, A(I,I), LDA, TAUL(I), + $ B(1,I), LDB, DWORK ) + ELSE + CALL DLARF( 'Left', N-I+1, N, A(I,I), LDA, TAUL(I), + $ B(I,1), LDB, DWORK ) + END IF + CALL DLARF( 'Left', N-I+1, N, A(I,I), LDA, TAUL(I), + $ G(I,1), LDG, DWORK ) + A(I,I) = TEMP + ELSE +C +C Generate elementary reflector FU(i) to annihilate +C A(i+1:n,i). +C + CALL DLARFG( N-I+1, A(I,I), A(I+1,I), 1, TAUL(I) ) +C +C Apply FU(i) from the left. +C + TEMP = A(I,I) + A(I,I) = ONE + CALL DLARF( 'Left', N-I+1, N-I, A(I,I), 1, TAUL(I), + $ A(I,I+1), LDA, DWORK ) + CALL DLARF( 'Left', N-I+1, N-I, A(I,I), 1, TAUL(I), + $ Q(I,I+1), LDQ, DWORK ) + IF ( LTRB ) THEN + CALL DLARF( 'Right', N, N-I+1, A(I,I), 1, TAUL(I), + $ B(1,I), LDB, DWORK ) + ELSE + CALL DLARF( 'Left', N-I+1, N, A(I,I), 1, TAUL(I), + $ B(I,1), LDB, DWORK ) + END IF + CALL DLARF( 'Left', N-I+1, N, A(I,I), 1, TAUL(I), G(I,1), + $ LDG, DWORK ) + A(I,I) = TEMP + END IF + ELSE + TAUL(I) = ZERO + END IF + IF ( I.LT.N ) + $ ALPHA = Q(I,I+1) + IF ( I.LT.N-1 ) THEN +C +C Generate elementary reflector HV(i) to annihilate Q(i,i+2:n) +C + CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, NU ) +C +C Apply HV(i) from the right. +C + Q(I,I+1) = ONE + CALL DLARF( 'Right', N-I, N-I, Q(I,I+1), LDQ, NU, + $ Q(I+1,I+1), LDQ, DWORK ) + IF ( LTRA ) THEN + CALL DLARF( 'Left', N-I, N, Q(I,I+1), LDQ, NU, + $ A(I+1,1), LDA, DWORK ) + ELSE + CALL DLARF( 'Right', N, N-I, Q(I,I+1), LDQ, NU, + $ A(1,I+1), LDA, DWORK ) + END IF + IF ( LTRB ) THEN + CALL DLARF( 'Left', N-I, N-I+1, Q(I,I+1), LDQ, NU, + $ B(I+1,I), LDB, DWORK ) + ELSE + CALL DLARF( 'Right', N-I+1, N-I, Q(I,I+1), LDQ, NU, + $ B(I,I+1), LDB, DWORK ) + END IF + CALL DLARF( 'Right', N, N-I, Q(I,I+1), LDQ, NU, + $ G(1,I+1), LDG, DWORK ) + Q(I,I+1) = NU + ELSE IF ( I.LT.N ) THEN + Q(I,I+1) = ZERO + END IF + IF ( I.LT.N ) THEN +C +C Generate symplectic Givens rotator GV(i) to annihilate +C Q(i,i+1). +C + IF ( LTRB ) THEN + TEMP = B(I+1,I) + CALL DLARTG( TEMP, ALPHA, C, S, B(I+1,I) ) + S = -S + CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,I+1), LDB, C, S ) + ELSE + TEMP = B(I,I+1) + CALL DLARTG( TEMP, ALPHA, C, S, B(I,I+1) ) + S = -S + CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,I+1), 1, C, S ) + END IF + IF ( LTRA ) THEN + CALL DROT( N, A(I+1,1), LDA, G(1,I+1), 1, C, S ) + ELSE + CALL DROT( N, A(1,I+1), 1, G(1,I+1), 1, C, S ) + END IF + CSR(2*I-1) = C + CSR(2*I) = S + END IF + IF ( I.LT.N-1 ) THEN + IF ( LTRB ) THEN +C +C Generate elementary reflector FV(i) to annihilate +C B(i+2:n,i). +C + CALL DLARFG( N-I, B(I+1,I), B(I+2,I), 1, TAUR(I) ) +C +C Apply FV(i) from the right. +C + TEMP = B(I+1,I) + B(I+1,I) = ONE + CALL DLARF( 'Left', N-I, N-I, B(I+1,I), 1, TAUR(I), + $ B(I+1,I+1), LDB, DWORK ) + CALL DLARF( 'Right', N-I, N-I, B(I+1,I), 1, TAUR(I), + $ Q(I+1,I+1), LDQ, DWORK ) + IF ( LTRA ) THEN + CALL DLARF( 'Left', N-I, N, B(I+1,I), 1, + $ TAUR(I), A(I+1,1), LDA, DWORK ) + ELSE + CALL DLARF( 'Right', N, N-I, B(I+1,I), 1, + $ TAUR(I), A(1,I+1), LDA, DWORK ) + END IF + CALL DLARF( 'Right', N, N-I, B(I+1,I), 1, TAUR(I), + $ G(1,I+1), LDG, DWORK ) + B(I+1,I) = TEMP + ELSE +C +C Generate elementary reflector FV(i) to annihilate +C B(i,i+2:n). +C + CALL DLARFG( N-I, B(I,I+1), B(I,I+2), LDB, TAUR(I) ) +C +C Apply FV(i) from the right. +C + TEMP = B(I,I+1) + B(I,I+1) = ONE + CALL DLARF( 'Right', N-I, N-I, B(I,I+1), LDB, TAUR(I), + $ B(I+1,I+1), LDB, DWORK ) + CALL DLARF( 'Right', N-I, N-I, B(I,I+1), LDB, TAUR(I), + $ Q(I+1,I+1), LDQ, DWORK ) + IF ( LTRA ) THEN + CALL DLARF( 'Left', N-I, N, B(I,I+1), LDB, TAUR(I), + $ A(I+1,1), LDA, DWORK ) + ELSE + CALL DLARF( 'Right', N, N-I, B(I,I+1), LDB, + $ TAUR(I), A(1,I+1), LDA, DWORK ) + END IF + CALL DLARF( 'Right', N, N-I, B(I,I+1), LDB, TAUR(I), + $ G(1,I+1), LDG, DWORK ) + B(I,I+1) = TEMP + END IF + ELSE IF ( I.LT.N ) THEN + TAUR(I) = ZERO + END IF + 10 CONTINUE + DWORK(1) = DBLE( MAX( 1, N ) ) + RETURN +C *** Last line of MB04TS *** + END diff --git a/mex/sources/libslicot/MB04TT.f b/mex/sources/libslicot/MB04TT.f new file mode 100644 index 000000000..7d8e207f9 --- /dev/null +++ b/mex/sources/libslicot/MB04TT.f @@ -0,0 +1,413 @@ + SUBROUTINE MB04TT( UPDATQ, UPDATZ, M, N, IFIRA, IFICA, NCA, A, + $ LDA, E, LDE, Q, LDQ, Z, LDZ, ISTAIR, RANK, TOL, + $ IWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C Let A and E be M-by-N matrices with E in column echelon form. +C Let AA and EE be the following submatrices of A and E: +C AA := A(IFIRA : M ; IFICA : N) +C EE := E(IFIRA : M ; IFICA : N). +C Let Aj and Ej be the following submatrices of AA and EE: +C Aj := A(IFIRA : M ; IFICA : IFICA + NCA - 1) and +C Ej := E(IFIRA : M ; IFICA + NCA : N). +C +C To transform (AA,EE) such that Aj is row compressed while keeping +C matrix Ej in column echelon form (which may be different from the +C form on entry). +C In fact the routine performs the j-th step of Algorithm 3.2.1 in +C [1]. Furthermore, it determines the rank RANK of the submatrix Ej, +C which is equal to the number of corner points in submatrix Ej. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPDATQ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Q the orthogonal row transformations, as follows: +C = .FALSE.: Do not form Q; +C = .TRUE.: The given matrix Q is updated by the orthogonal +C row transformations used in the reduction. +C +C UPDATZ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal column transformations, as +C follows: +C = .FALSE.: Do not form Z; +C = .TRUE.: The given matrix Z is updated by the orthogonal +C column transformations used in the reduction. +C +C Input/Output Parameters +C +C M (input) INTEGER +C M is the number of rows of the matrices A, E and Q. +C M >= 0. +C +C N (input) INTEGER +C N is the number of columns of the matrices A, E and Z. +C N >= 0. +C +C IFIRA (input) INTEGER +C IFIRA is the first row index of the submatrices Aj and Ej +C in the matrices A and E, respectively. +C +C IFICA (input) INTEGER +C IFICA and IFICA + NCA are the first column indices of the +C submatrices Aj and Ej in the matrices A and E, +C respectively. +C +C NCA (input) INTEGER +C NCA is the number of columns of the submatrix Aj in A. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, A(IFIRA : M ; IFICA : IFICA + NCA - 1) contains +C the matrix Aj. +C On exit, it contains the matrix A with AA that has been +C row compressed while keeping EE in column echelon form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, E(IFIRA : M ; IFICA + NCA : N) contains the +C matrix Ej which is in column echelon form. +C On exit, it contains the transformed matrix EE which is +C kept in column echelon form. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,M). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) +C On entry, if UPDATQ = .TRUE., then the leading M-by-M +C part of this array must contain a given matrix Q (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading M-by-M part of this array contains the +C product of the input matrix Q and the row transformation +C matrix that has transformed the rows of the matrices A +C and E. +C If UPDATQ = .FALSE., the array Q is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDQ = 1 and declare this array to be Q(1,1) in the calling +C program). +C +C LDQ INTEGER +C The leading dimension of array Q. If UPDATQ = .TRUE., +C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) +C On entry, if UPDATZ = .TRUE., then the leading N-by-N +C part of this array must contain a given matrix Z (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading N-by-N part of this array contains the +C product of the input matrix Z and the column +C transformation matrix that has transformed the columns of +C the matrices A and E. +C If UPDATZ = .FALSE., the array Z is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDZ = 1 and declare this array to be Z(1,1) in the calling +C program). +C +C LDZ INTEGER +C The leading dimension of array Z. If UPDATZ = .TRUE., +C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. +C +C ISTAIR (input/output) INTEGER array, dimension (M) +C On entry, ISTAIR contains information on the column +C echelon form of the input matrix E as follows: +C ISTAIR(i) = +j: the boundary element E(i,j) is a corner +C point; +C -j: the boundary element E(i,j) is not a +C corner point (where i=1,...,M). +C On exit, ISTAIR contains the same information for the +C transformed matrix E. +C +C RANK (output) INTEGER +C Numerical rank of the submatrix Aj in A (based on TOL). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance used when considering matrix elements +C to be zero. +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C REFERENCES +C +C [1] Beelen, Th. +C New Algorithms for Computing the Kronecker structure of a +C Pencil with Applications to Systems and Control Theory. +C Ph.D.Thesis, Eindhoven University of Technology, +C The Netherlands, 1987. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MB04FZ by Th.G.J. Beelen, +C Philips Glass Eindhoven, Holland. +C +C REVISIONS +C +C June 13, 1997, V. Sima. +C November 24, 1997, A. Varga: array starting point A(KK,LL) +C correctly set when calling DLASET. +C +C KEYWORDS +C +C Echelon form, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + LOGICAL UPDATQ, UPDATZ + INTEGER IFICA, IFIRA, LDA, LDE, LDQ, LDZ, M, N, NCA, + $ RANK + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER ISTAIR(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL LZERO + INTEGER I, IFICA1, IFIRA1, II, IP, IST1, IST2, ISTPVT, + $ ITYPE, JC1, JC2, JPVT, K, KK, L, LL, LSAV, MJ, + $ MK1, MXRANK, NJ + DOUBLE PRECISION BMX, BMXNRM, EIJPVT, SC, SS +C .. External Functions .. + INTEGER IDAMAX + EXTERNAL IDAMAX +C .. External Subroutines .. + EXTERNAL DLAPMT, DLASET, DROT, DROTG, DSWAP +C .. Intrinsic Functions .. + INTRINSIC ABS, MIN +C .. Executable Statements .. +C + RANK = 0 + IF ( M.LE.0 .OR. N.LE.0 ) + $ RETURN +C +C Initialisation. +C +C NJ = number of columns in submatrix Aj, +C MJ = number of rows in submatrices Aj and Ej. +C + NJ = NCA + MJ = M + 1 - IFIRA + IFIRA1 = IFIRA - 1 + IFICA1 = IFICA - 1 +C + DO 20 I = 1, NJ + IWORK(I) = I + 20 CONTINUE +C + K = 1 + LZERO = .FALSE. + RANK = MIN( NJ, MJ ) + MXRANK = RANK +C +C WHILE ( K <= MXRANK ) and ( LZERO = FALSE ) DO + 40 IF ( ( K.LE.MXRANK ) .AND. ( .NOT.LZERO ) ) THEN +C +C Determine column in Aj with largest max-norm. +C + BMXNRM = ZERO + LSAV = K + KK = IFIRA1 + K +C + DO 60 L = K, NJ +C +C IDAMAX call gives the relative index in column L of Aj where +C max element is found. +C Note: the first element in column L is in row K of +C matrix Aj. +C + LL = IFICA1 + L + BMX = ABS( A(IDAMAX( MJ-K+1, A(KK,LL), 1 )+KK-1,LL) ) + IF ( BMX.GT.BMXNRM ) THEN + BMXNRM = BMX + LSAV = L + END IF + 60 CONTINUE +C + LL = IFICA1 + K + IF ( BMXNRM.LT.TOL ) THEN +C +C Set submatrix of Aj to zero. +C + CALL DLASET( 'Full', MJ-K+1, NJ-K+1, ZERO, ZERO, A(KK,LL), + $ LDA ) + LZERO = .TRUE. + RANK = K - 1 + ELSE +C +C Check whether columns have to be interchanged. +C + IF ( LSAV.NE.K ) THEN +C +C Interchange the columns in A which correspond to the +C columns lsav and k in Aj. Store the permutation in IWORK. +C + CALL DSWAP( M, A(1,LL), 1, A(1,IFICA1+LSAV), 1 ) + IP = IWORK(LSAV) + IWORK(LSAV) = IWORK(K) + IWORK(K) = IP + END IF +C + K = K + 1 + MK1 = N - LL + 1 +C + DO 80 I = MJ, K, -1 +C +C II = absolute row number in A corresponding to row i in +C Aj. +C + II = IFIRA1 + I +C +C Construct Givens transformation to annihilate Aj(i,k). +C Apply the row transformation to whole matrix A +C (NOT only to Aj). +C Update row transformation matrix Q, if needed. +C + CALL DROTG( A(II-1,LL), A(II,LL), SC, SS ) + CALL DROT( MK1-1, A(II-1,LL+1), LDA, A(II,LL+1), LDA, SC, + $ SS ) + A(II,LL) = ZERO + IF ( UPDATQ ) + $ CALL DROT( M, Q(1,II-1), 1, Q(1,II), 1, SC, SS ) +C +C Determine boundary type of matrix E at rows II-1 and II. +C + IST1 = ISTAIR(II-1) + IST2 = ISTAIR(II) + IF ( ( IST1*IST2 ).GT.0 ) THEN + IF ( IST1.GT.0 ) THEN +C +C boundary form = (* x) +C (0 *) +C + ITYPE = 1 + ELSE +C +C boundary form = (x x) +C (x x) +C + ITYPE = 3 + END IF + ELSE + IF ( IST1.LT.0 ) THEN +C +C boundary form = (x x) +C (* x) +C + ITYPE = 2 + ELSE +C +C boundary form = (* x) +C (0 x) +C + ITYPE = 4 + END IF + END IF +C +C Apply row transformation also to matrix E. +C +C JC1 = absolute number of the column in E in which stair +C element of row i-1 of Ej is present. +C JC2 = absolute number of the column in E in which stair +C element of row i of Ej is present. +C +C Note: JC1 < JC2 if ITYPE = 1. +C JC1 = JC2 if ITYPE = 2, 3 or 4. +C + JC1 = ABS( IST1 ) + JC2 = ABS( IST2 ) + JPVT = MIN( JC1, JC2 ) +C + CALL DROT( N-JPVT+1, E(II-1,JPVT), LDE, E(II,JPVT), LDE, + $ SC, SS ) + EIJPVT = E(II,JPVT) +C + IF ( ITYPE.EQ.1 ) THEN +C +C Construct column Givens transformation to annihilate +C E(ii,jpvt). +C Apply column Givens transformation to matrix E +C (NOT only to Ej). +C + CALL DROTG( E(II,JPVT+1), E(II,JPVT), SC, SS ) + CALL DROT( II-1, E(1,JPVT+1), 1, E(1,JPVT), 1, SC, + $ SS ) + E(II,JPVT) = ZERO +C +C Apply this transformation also to matrix A +C (NOT only to Aj). +C Update column transformation matrix Z, if needed. +C + CALL DROT( M, A(1,JPVT+1), 1, A(1,JPVT), 1, SC, SS ) + IF ( UPDATZ ) CALL DROT( N, Z(1,JPVT+1), 1, Z(1,JPVT), + $ 1, SC, SS ) +C + ELSE IF ( ITYPE.EQ.2 ) THEN + IF ( ABS( EIJPVT ).LT.TOL ) THEN +C +C (x x) (* x) +C Boundary form has been changed from (* x) to (0 x). +C + ISTPVT = ISTAIR(II) + ISTAIR(II-1) = ISTPVT + ISTAIR(II) = -(ISTPVT+1 ) + E(II,JPVT) = ZERO + END IF +C + ELSE IF ( ITYPE.EQ.4 ) THEN + IF ( ABS( EIJPVT ).GE.TOL ) THEN +C +C (* x) (x x) +C Boundary form has been changed from (0 x) to (* x). +C + ISTPVT = ISTAIR(II-1) + ISTAIR(II-1) = -ISTPVT + ISTAIR(II) = ISTPVT + END IF + END IF + 80 CONTINUE +C + END IF + GO TO 40 + END IF +C END WHILE 40 +C +C Permute columns of Aj to original order. +C + CALL DLAPMT( .FALSE., IFIRA1+RANK, NJ, A(1,IFICA), LDA, IWORK ) +C + RETURN +C *** Last line of MB04TT *** + END diff --git a/mex/sources/libslicot/MB04TU.f b/mex/sources/libslicot/MB04TU.f new file mode 100644 index 000000000..74e81bfe1 --- /dev/null +++ b/mex/sources/libslicot/MB04TU.f @@ -0,0 +1,96 @@ + SUBROUTINE MB04TU( N, X, INCX, Y, INCY, C, S ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the Givens transformation, defined by C (cos) and S +C (sin), and interchange the vectors involved, i.e. +C +C |X(i)| | 0 1 | | C S | |X(i)| +C | | := | | x | | x | |, i = 1,...N. +C |Y(i)| | 1 0 | |-S C | |Y(i)| +C +C REMARK. This routine is a modification of DROT from BLAS. +C This routine is called only by the SLICOT routines MB04TX +C and MB04VX. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB04FU by Th.G.J. Beelen, +C Philips Glass Eindhoven, Holland. +C +C REVISIONS +C +C January 26, 1998. +C +C KEYWORDS +C +C Othogonal transformation. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INCX, INCY, N + DOUBLE PRECISION C, S +C .. Array Arguments .. + DOUBLE PRECISION X(*), Y(*) +C .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I, IX, IY +C .. Executable Statements .. +C + IF ( N.LE.0 ) RETURN + IF ( ( INCX.NE.1 ) .OR. ( INCY.NE.1 ) ) THEN +C +C Code for unequal increments or equal increments not equal to 1. +C + IX = 1 + IY = 1 + IF ( INCX.LT.0 ) IX = (-N+1)*INCX + 1 + IF ( INCY.LT.0 ) IY = (-N+1)*INCY + 1 +C + DO 20 I = 1, N + DTEMP = C*Y(IY) - S*X(IX) + Y(IY) = C*X(IX) + S*Y(IY) + X(IX) = DTEMP + IX = IX + INCX + IY = IY + INCY + 20 CONTINUE +C + ELSE +C +C Code for both increments equal to 1. +C + DO 40 I = 1, N + DTEMP = C*Y(I) - S*X(I) + Y(I) = C*X(I) + S*Y(I) + X(I) = DTEMP + 40 CONTINUE +C + END IF +C + RETURN +C *** Last line of MB04TU *** + END diff --git a/mex/sources/libslicot/MB04TV.f b/mex/sources/libslicot/MB04TV.f new file mode 100644 index 000000000..c3fa37f2d --- /dev/null +++ b/mex/sources/libslicot/MB04TV.f @@ -0,0 +1,171 @@ + SUBROUTINE MB04TV( UPDATZ, N, NRA, NCA, IFIRA, IFICA, A, LDA, E, + $ LDE, Z, LDZ ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce a submatrix A(k) of A to upper triangular form by column +C Givens rotations only. +C Here A(k) = A(IFIRA:ma,IFICA:na) where ma = IFIRA - 1 + NRA, +C na = IFICA - 1 + NCA. +C Matrix A(k) is assumed to have full row rank on entry. Hence, no +C pivoting is done during the reduction process. See Algorithm 2.3.1 +C and Remark 2.3.4 in [1]. +C The constructed column transformations are also applied to matrix +C E(k) = E(1:IFIRA-1,IFICA:na). +C Note that in E columns are transformed with the same column +C indices as in A, but with row indices different from those in A. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPDATZ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal column transformations, as +C follows: +C = .FALSE.: Do not form Z; +C = .TRUE.: The given matrix Z is updated by the orthogonal +C column transformations used in the reduction. +C +C Input/Output Parameters +C +C N (input) INTEGER +C Number of columns of A and E. N >= 0. +C +C NRA (input) INTEGER +C Number of rows in A to be transformed. 0 <= NRA <= LDA. +C +C NCA (input) INTEGER +C Number of columns in A to be transformed. 0 <= NCA <= N. +C +C IFIRA (input) INTEGER +C Index of the first row in A to be transformed. +C +C IFICA (input) INTEGER +C Index of the first column in A to be transformed. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the elements of A(IFIRA:ma,IFICA:na) must +C contain the submatrix A(k) of full row rank to be reduced +C to upper triangular form. +C On exit, it contains the transformed matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,NRA). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the elements of E(1:IFIRA-1,IFICA:na) must +C contain the submatrix E(k). +C On exit, it contains the transformed matrix E. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,IFIRA-1). +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) +C On entry, if UPDATZ = .TRUE., then the leading N-by-N +C part of this array must contain a given matrix Z (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading N-by-N part of this array contains the +C product of the input matrix Z and the column +C transformation matrix that has transformed the columns of +C the matrices A and E. +C If UPDATZ = .FALSE., the array Z is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDZ = 1 and declare this array to be Z(1,1) in the calling +C program). +C +C LDZ INTEGER +C The leading dimension of array Z. If UPDATZ = .TRUE., +C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. +C +C REFERENCES +C +C [1] Beelen, Th. +C New Algorithms for Computing the Kronecker structure of a +C Pencil with Applications to Systems and Control Theory. +C Ph.D.Thesis, Eindhoven University of Technology, +C The Netherlands, 1987. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB04FV by Th.G.J. Beelen, +C Philips Glass Eindhoven, Holland. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Generalized eigenvalue problem, orthogonal transformation, +C staircase form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + LOGICAL UPDATZ + INTEGER IFICA, IFIRA, LDA, LDE, LDZ, N, NCA, NRA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), E(LDE,*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER I, IFIRA1, J, JPVT + DOUBLE PRECISION SC, SS +C .. External Subroutines .. + EXTERNAL DROT, DROTG +C .. Executable Statements .. +C + IF ( N.LE.0 .OR. NRA.LE.0 .OR. NCA.LE.0 ) + $ RETURN + IFIRA1 = IFIRA - 1 + JPVT = IFICA + NCA +C + DO 40 I = IFIRA1 + NRA, IFIRA, -1 + JPVT = JPVT - 1 +C + DO 20 J = JPVT - 1, IFICA, -1 +C +C Determine the Givens transformation on columns j and jpvt +C to annihilate A(i,j). Apply the transformation to these +C columns from rows 1 up to i. +C Apply the transformation also to the E-matrix (from rows 1 +C up to ifira1). +C Update column transformation matrix Z, if needed. +C + CALL DROTG( A(I,JPVT), A(I,J), SC, SS ) + CALL DROT( I-1, A(1,JPVT), 1, A(1,J), 1, SC, SS ) + A(I,J) = ZERO + CALL DROT( IFIRA1, E(1,JPVT), 1, E(1,J), 1, SC, SS ) + IF( UPDATZ ) CALL DROT( N, Z(1,JPVT), 1, Z(1,J), 1, SC, SS ) + 20 CONTINUE +C + 40 CONTINUE +C + RETURN +C *** Last line of MB04TV *** + END diff --git a/mex/sources/libslicot/MB04TW.f b/mex/sources/libslicot/MB04TW.f new file mode 100644 index 000000000..81854d9f2 --- /dev/null +++ b/mex/sources/libslicot/MB04TW.f @@ -0,0 +1,180 @@ + SUBROUTINE MB04TW( UPDATQ, M, N, NRE, NCE, IFIRE, IFICE, IFICA, A, + $ LDA, E, LDE, Q, LDQ ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce a submatrix E(k) of E to upper triangular form by row +C Givens rotations only. +C Here E(k) = E(IFIRE:me,IFICE:ne), where me = IFIRE - 1 + NRE, +C ne = IFICE - 1 + NCE. +C Matrix E(k) is assumed to have full column rank on entry. Hence, +C no pivoting is done during the reduction process. See Algorithm +C 2.3.1 and Remark 2.3.4 in [1]. +C The constructed row transformations are also applied to matrix +C A(k) = A(IFIRE:me,IFICA:N). +C Note that in A(k) rows are transformed with the same row indices +C as in E but with column indices different from those in E. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPDATQ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Q the orthogonal row transformations, as follows: +C = .FALSE.: Do not form Q; +C = .TRUE.: The given matrix Q is updated by the orthogonal +C row transformations used in the reduction. +C +C Input/Output Parameters +C +C M (input) INTEGER +C Number of rows of A and E. M >= 0. +C +C N (input) INTEGER +C Number of columns of A and E. N >= 0. +C +C NRE (input) INTEGER +C Number of rows in E to be transformed. 0 <= NRE <= M. +C +C NCE (input) INTEGER +C Number of columns in E to be transformed. 0 <= NCE <= N. +C +C IFIRE (input) INTEGER +C Index of first row in E to be transformed. +C +C IFICE (input) INTEGER +C Index of first column in E to be transformed. +C +C IFICA (input) INTEGER +C Index of first column in A to be transformed. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, this array contains the submatrix A(k). +C On exit, it contains the transformed matrix A(k). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, this array contains the submatrix E(k) of full +C column rank to be reduced to upper triangular form. +C On exit, it contains the transformed matrix E. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,M). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) +C On entry, if UPDATQ = .TRUE., then the leading M-by-M +C part of this array must contain a given matrix Q (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading M-by-M part of this array contains the +C product of the input matrix Q and the row transformation +C matrix that has transformed the rows of the matrices A +C and E. +C If UPDATQ = .FALSE., the array Q is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDQ = 1 and declare this array to be Q(1,1) in the calling +C program). +C +C LDQ INTEGER +C The leading dimension of array Q. If UPDATQ = .TRUE., +C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. +C +C REFERENCES +C +C [1] Beelen, Th. +C New Algorithms for Computing the Kronecker structure of a +C Pencil with Applications to Systems and Control Theory. +C Ph.D.Thesis, Eindhoven University of Technology, +C The Netherlands, 1987. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB04FW by Th.G.J. Beelen, +C Philips Glass Eindhoven, Holland. +C +C REVISIONS +C +C June 13, 1997. V. Sima. +C December 30, 1997. A. Varga: Corrected column range to apply +C transformations on the matrix E. +C +C KEYWORDS +C +C Generalized eigenvalue problem, orthogonal transformation, +C staircase form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + LOGICAL UPDATQ + INTEGER IFICA, IFICE, IFIRE, LDA, LDE, LDQ, M, N, NCE, + $ NRE +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*) +C .. Local Scalars .. + INTEGER I, IPVT, J + DOUBLE PRECISION SC, SS +C .. External Subroutines .. + EXTERNAL DROT, DROTG +C .. Executable Statements .. +C + IF ( M.LE.0 .OR. N.LE.0 .OR. NRE.LE.0 .OR. NCE.LE.0 ) + $ RETURN +C + IPVT = IFIRE - 1 +C + DO 40 J = IFICE, IFICE + NCE - 1 + IPVT = IPVT + 1 +C + DO 20 I = IPVT + 1, IFIRE + NRE - 1 +C +C Determine the Givens transformation on rows i and ipvt +C to annihilate E(i,j). +C Apply the transformation to these rows (in whole E-matrix) +C from columns j up to n . +C Apply the transformations also to the A-matrix +C (from columns ifica up to n). +C Update the row transformation matrix Q, if needed. +C + CALL DROTG( E(IPVT,J), E(I,J), SC, SS ) + CALL DROT( N-J, E(IPVT,J+1), LDE, E(I,J+1), LDE, SC, SS ) + E(I,J) = ZERO + CALL DROT( N-IFICA+1, A(IPVT,IFICA), LDA, A(I,IFICA), LDA, + $ SC, SS ) + IF( UPDATQ ) + $ CALL DROT( M, Q(1,IPVT), 1, Q(1,I), 1, SC, SS ) + 20 CONTINUE +C + 40 CONTINUE +C + RETURN +C *** Last line of MB04TW *** + END diff --git a/mex/sources/libslicot/MB04TX.f b/mex/sources/libslicot/MB04TX.f new file mode 100644 index 000000000..ff4c37128 --- /dev/null +++ b/mex/sources/libslicot/MB04TX.f @@ -0,0 +1,394 @@ + SUBROUTINE MB04TX( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, + $ LDA, E, LDE, Q, LDQ, Z, LDZ, MNEI ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To separate the pencils s*E(eps)-A(eps) and s*E(inf)-A(inf) in +C s*E(eps,inf)-A(eps,inf) using Algorithm 3.3.3 in [1]. +C +C On entry, it is assumed that the M-by-N matrices A and E have +C been obtained after applying the Algorithms 3.2.1 and 3.3.1 to +C the pencil s*E - A as described in [1], i.e. +C +C | s*E(eps,inf)-A(eps,inf) | X | +C Q'(s*E - A)Z = |-------------------------|-------------| +C | 0 | s*E(r)-A(r) | +C +C Here the pencil s*E(eps,inf)-A(eps,inf) is in staircase form. +C This pencil contains all Kronecker column indices and infinite +C elementary divisors of the pencil s*E - A. +C The pencil s*E(r)-A(r) contains all Kronecker row indices and +C finite elementary divisors of s*E - A. +C Furthermore, the submatrices having full row and column rank in +C the pencil s*E(eps,inf)-A(eps,inf) are assumed to be +C triangularized. +C +C On exit, the result then is +C +C Q'(s*E - A)Z = +C +C | s*E(eps)-A(eps) | X | X | +C |-----------------|-----------------|-------------| +C | 0 | s*E(inf)-A(inf) | X | +C |===================================|=============| +C | | | +C | 0 | s*E(r)-A(r) | +C +C Note that the pencil s*E(r)-A(r) is not reduced further. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPDATQ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Q the orthogonal row transformations, as follows: +C = .FALSE.: Do not form Q; +C = .TRUE.: The given matrix Q is updated by the orthogonal +C row transformations used in the reduction. +C +C UPDATZ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal column transformations, as +C follows: +C = .FALSE.: Do not form Z; +C = .TRUE.: The given matrix Z is updated by the orthogonal +C column transformations used in the reduction. +C +C Input/Output Parameters +C +C M (input) INTEGER +C Number of rows of A and E. M >= 0. +C +C N (input) INTEGER +C Number of columns of A and E. N >= 0. +C +C NBLCKS (input/output) INTEGER +C On entry, the number of submatrices having full row rank +C (possibly zero) in A(eps,inf). +C On exit, the input value has been reduced by one, if the +C last submatrix is a 0-by-0 (empty) matrix. +C +C INUK (input/output) INTEGER array, dimension (NBLCKS) +C On entry, this array contains the row dimensions nu(k), +C (k=1, 2, ..., NBLCKS) of the submatrices having full row +C rank in the pencil s*E(eps,inf)-A(eps,inf). +C On exit, this array contains the row dimensions nu(k), +C (k=1, 2, ..., NBLCKS) of the submatrices having full row +C rank in the pencil s*E(eps)-A(eps). +C +C IMUK (input/output) INTEGER array, dimension (NBLCKS) +C On entry, this array contains the column dimensions mu(k), +C (k=1, 2, ..., NBLCKS) of the submatrices having full +C column rank in the pencil s*E(eps,inf)-A(eps,inf). +C On exit, this array contains the column dimensions mu(k), +C (k=1, 2, ..., NBLCKS) of the submatrices having full +C column rank in the pencil s*E(eps)-A(eps). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, this array contains the matrix A to be reduced. +C On exit, it contains the transformed matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, this array contains the matrix E to be reduced. +C On exit, it contains the transformed matrix E. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,M). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) +C On entry, if UPDATQ = .TRUE., then the leading M-by-M +C part of this array must contain a given matrix Q (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading M-by-M part of this array contains the +C product of the input matrix Q and the row transformation +C matrix that has transformed the rows of the matrices A +C and E. +C If UPDATQ = .FALSE., the array Q is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDQ = 1 and declare this array to be Q(1,1) in the calling +C program). +C +C LDQ INTEGER +C The leading dimension of array Q. If UPDATQ = .TRUE., +C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) +C On entry, if UPDATZ = .TRUE., then the leading N-by-N +C part of this array must contain a given matrix Z (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading N-by-N part of this array contains the +C product of the input matrix Z and the column +C transformation matrix that has transformed the columns of +C the matrices A and E. +C If UPDATZ = .FALSE., the array Z is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDZ = 1 and declare this array to be Z(1,1) in the calling +C program). +C +C LDZ INTEGER +C The leading dimension of array Z. If UPDATZ = .TRUE., +C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. +C +C MNEI (output) INTEGER array, dimension (4) +C MNEI(1) = MEPS = row dimension of s*E(eps)-A(eps), +C MNEI(2) = NEPS = column dimension of s*E(eps)-A(eps), +C MNEI(3) = MINF = row dimension of s*E(inf)-A(inf), +C MNEI(4) = NINF = column dimension of s*E(inf)-A(inf). +C +C REFERENCES +C +C [1] Beelen, Th. +C New Algorithms for Computing the Kronecker structure of a +C Pencil with Applications to Systems and Control Theory. +C Ph.D.Thesis, Eindhoven University of Technology, +C The Netherlands, 1987. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB04FX by Th.G.J. Beelen, +C Philips Glass Eindhoven, Holland. +C +C REVISIONS +C +C June 13, 1997, V. Sima. +C November 24, 1997, A. Varga: initialization of MNEI to 0, instead +C of ZERO. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, orthogonal +C transformation, staircase form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + LOGICAL UPDATQ, UPDATZ + INTEGER LDA, LDE, LDQ, LDZ, M, N, NBLCKS +C .. Array Arguments .. + INTEGER IMUK(*), INUK(*), MNEI(4) + DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER CA, CE, CJA, CJE, IP, ISMUK, ISNUK, K, MEPS, + $ MINF, MUK, MUKP1, MUP, MUP1, NEPS, NINF, NUK, + $ NUP, RA, RJE, SK1P1, TK1P1, TP1 + DOUBLE PRECISION SC, SS +C .. External Subroutines .. + EXTERNAL DROTG, MB04TU +C .. Executable Statements .. +C + MNEI(1) = 0 + MNEI(2) = 0 + MNEI(3) = 0 + MNEI(4) = 0 + IF ( M.LE.0 .OR. N.LE.0 ) + $ RETURN +C +C Initialisation. +C + ISMUK = 0 + ISNUK = 0 +C + DO 20 K = 1, NBLCKS + ISMUK = ISMUK + IMUK(K) + ISNUK = ISNUK + INUK(K) + 20 CONTINUE +C +C MEPS, NEPS are the dimensions of the pencil s*E(eps)-A(eps). +C MEPS = Sum(k=1,...,nblcks) NU(k), +C NEPS = Sum(k=1,...,nblcks) MU(k). +C MINF, NINF are the dimensions of the pencil s*E(inf)-A(inf). +C + MEPS = ISNUK + NEPS = ISMUK + MINF = 0 + NINF = 0 +C +C MUKP1 = mu(k+1). N.B. It is assumed that mu(NBLCKS + 1) = 0. +C + MUKP1 = 0 +C + DO 120 K = NBLCKS, 1, -1 + NUK = INUK(K) + MUK = IMUK(K) +C +C Reduce submatrix E(k,k+1) to square matrix. +C NOTE that always NU(k) >= MU(k+1) >= 0. +C +C WHILE ( NU(k) > MU(k+1) ) DO + 40 IF ( NUK.GT.MUKP1 ) THEN +C +C sk1p1 = sum(i=k+1,...,p-1) NU(i) +C tk1p1 = sum(i=k+1,...,p-1) MU(i) +C ismuk = sum(i=1,...,k) MU(i) +C tp1 = sum(i=1,...,p-1) MU(i) = ismuk + tk1p1. +C + SK1P1 = 0 + TK1P1 = 0 +C + DO 100 IP = K + 1, NBLCKS +C +C Annihilate the elements originally present in the last +C row of E(k,p+1) and A(k,p). +C Start annihilating the first MU(p) - MU(p+1) elements by +C applying column Givens rotations plus interchanging +C elements. +C Use original bottom diagonal element of A(k,k) as pivot. +C Start position of pivot in A = (ra,ca). +C + TP1 = ISMUK + TK1P1 + RA = ISNUK + SK1P1 + CA = TP1 +C + MUP = IMUK(IP) + NUP = INUK(IP) + MUP1 = NUP +C + DO 60 CJA = CA, CA + MUP - NUP - 1 +C +C CJA = current column index of pivot in A. +C + CALL DROTG( A(RA,CJA), A(RA,CJA+1), SC, SS ) +C +C Apply transformations to A- and E-matrix. +C Interchange columns simultaneously. +C Update column transformation matrix Z, if needed. +C + CALL MB04TU( RA-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, + $ SS ) + A(RA,CJA+1) = A(RA,CJA) + A(RA,CJA) = ZERO + CALL MB04TU( RA, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) + IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), + $ 1, SC, SS ) + 60 CONTINUE +C +C Annihilate the remaining elements originally present in +C the last row of E(k,p+1) and A(k,p) by alternatingly +C applying row and column rotations plus interchanging +C elements. +C Use diagonal elements of E(p,p+1) and original bottom +C diagonal element of A(k,k) as pivots, respectively. +C (re,ce) and (ra,ca) are the starting positions of the +C pivots in E and A. +C + CE = TP1 + MUP + CA = CE - MUP1 - 1 +C + DO 80 RJE = RA + 1, RA + MUP1 +C +C (RJE,CJE) = current position pivot in E. +C + CJE = CE + 1 + CJA = CA + 1 +C +C Determine the row transformations. +C Apply these transformations to E- and A-matrix. +C Interchange the rows simultaneously. +C Update row transformation matrix Q, if needed. +C + CALL DROTG( E(RJE,CJE), E(RJE-1,CJE), SC, SS ) + CALL MB04TU( N-CJE, E(RJE,CJE+1), LDE, E(RJE-1,CJE+1), + $ LDE, SC, SS ) + E(RJE-1,CJE) = E(RJE,CJE) + E(RJE,CJE) = ZERO + CALL MB04TU( N-CJA+1, A(RJE,CJA), LDA, A(RJE-1,CJA), + $ LDA, SC, SS ) + IF( UPDATQ ) CALL MB04TU( M, Q(1,RJE), 1, + $ Q(1,RJE-1), 1, SC, SS ) +C +C Determine the column transformations. +C Apply these transformations to A- and E-matrix. +C Interchange the columns simultaneously. +C Update column transformation matrix Z, if needed. +C + CALL DROTG( A(RJE,CJA), A(RJE,CJA+1), SC, SS ) + CALL MB04TU( RJE-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, + $ SS ) + A(RJE,CJA+1) = A(RJE,CJA) + A(RJE,CJA) = ZERO + CALL MB04TU( RJE, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) + IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), + $ 1, SC, SS ) + 80 CONTINUE +C + SK1P1 = SK1P1 + NUP + TK1P1 = TK1P1 + MUP +C + 100 CONTINUE +C +C Reduce A=A(eps,inf) and E=E(eps,inf) by ignoring their last +C row and right most column. The row and column ignored +C belong to the pencil s*E(inf)-A(inf). +C Redefine blocks in new A and E. +C + MUK = MUK - 1 + NUK = NUK - 1 + ISMUK = ISMUK - 1 + ISNUK = ISNUK - 1 + MEPS = MEPS - 1 + NEPS = NEPS - 1 + MINF = MINF + 1 + NINF = NINF + 1 +C + GO TO 40 + END IF +C END WHILE 40 +C + IMUK(K) = MUK + INUK(K) = NUK +C +C Now submatrix E(k,k+1) is square. +C +C Consider next submatrix (k:=k-1). +C + ISNUK = ISNUK - NUK + ISMUK = ISMUK - MUK + MUKP1 = MUK + 120 CONTINUE +C +C If mu(NBLCKS) = 0, then the last submatrix counted in NBLCKS is +C a 0-by-0 (empty) matrix. This "matrix" must be removed. +C + IF ( IMUK(NBLCKS).EQ.0 ) NBLCKS = NBLCKS - 1 +C +C Store dimensions of the pencils s*E(eps)-A(eps) and +C s*E(inf)-A(inf) in array MNEI. +C + MNEI(1) = MEPS + MNEI(2) = NEPS + MNEI(3) = MINF + MNEI(4) = NINF +C + RETURN +C *** Last line of MB04TX *** + END diff --git a/mex/sources/libslicot/MB04TY.f b/mex/sources/libslicot/MB04TY.f new file mode 100644 index 000000000..1a146092f --- /dev/null +++ b/mex/sources/libslicot/MB04TY.f @@ -0,0 +1,241 @@ + SUBROUTINE MB04TY( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, + $ LDA, E, LDE, Q, LDQ, Z, LDZ, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the triangularization of the submatrices having full +C row and column rank in the pencil s*E(eps,inf)-A(eps,inf) below +C +C | s*E(eps,inf)-A(eps,inf) | X | +C s*E - A = |-------------------------|-------------| , +C | 0 | s*E(r)-A(r) | +C +C using Algorithm 3.3.1 in [1]. +C On entry, it is assumed that the M-by-N matrices A and E have +C been transformed to generalized Schur form by unitary +C transformations (see Algorithm 3.2.1 in [1]), and that the pencil +C s*E(eps,inf)-A(eps,inf) is in staircase form. +C This pencil contains all Kronecker column indices and infinite +C elementary divisors of the pencil s*E - A. +C The pencil s*E(r)-A(r) contains all Kronecker row indices and +C finite elementary divisors of s*E - A. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPDATQ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Q the orthogonal row transformations, as follows: +C = .FALSE.: Do not form Q; +C = .TRUE.: The given matrix Q is updated by the orthogonal +C row transformations used in the reduction. +C +C UPDATZ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal column transformations, as +C follows: +C = .FALSE.: Do not form Z; +C = .TRUE.: The given matrix Z is updated by the orthogonal +C column transformations used in the reduction. +C +C Input/Output Parameters +C +C M (input) INTEGER +C Number of rows in A and E. M >= 0. +C +C N (input) INTEGER +C Number of columns in A and E. N >= 0. +C +C NBLCKS (input) INTEGER +C Number of submatrices having full row rank (possibly zero) +C in A(eps,inf). +C +C INUK (input) INTEGER array, dimension (NBLCKS) +C The row dimensions nu(k) (k=1, 2, ..., NBLCKS) of the +C submatrices having full row rank in the pencil +C s*E(eps,inf)-A(eps,inf). +C +C IMUK (input) INTEGER array, dimension (NBLCKS) +C The column dimensions mu(k) (k=1, 2, ..., NBLCKS) of the +C submatrices having full column rank in the pencil. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, this array contains the matrix A to be reduced. +C On exit, it contains the transformed matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, this array contains the matrix E to be reduced. +C On exit, it contains the transformed matrix E. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,M). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) +C On entry, if UPDATQ = .TRUE., then the leading M-by-M +C part of this array must contain a given matrix Q (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading M-by-M part of this array contains the +C product of the input matrix Q and the row transformation +C matrix that has transformed the rows of the matrices A +C and E. +C If UPDATQ = .FALSE., the array Q is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDQ = 1 and declare this array to be Q(1,1) in the calling +C program). +C +C LDQ INTEGER +C The leading dimension of array Q. If UPDATQ = .TRUE., +C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) +C On entry, if UPDATZ = .TRUE., then the leading N-by-N +C part of this array must contain a given matrix Z (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading N-by-N part of this array contains the +C product of the input matrix Z and the column +C transformation matrix that has transformed the columns of +C the matrices A and E. +C If UPDATZ = .FALSE., the array Z is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDZ = 1 and declare this array to be Z(1,1) in the calling +C program). +C +C LDZ INTEGER +C The leading dimension of array Z. If UPDATZ = .TRUE., +C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if incorrect dimensions of a full column rank +C submatrix; +C = 2: if incorrect dimensions of a full row rank +C submatrix. +C +C REFERENCES +C +C [1] Beelen, Th. +C New Algorithms for Computing the Kronecker structure of a +C Pencil with Applications to Systems and Control Theory. +C Ph.D.Thesis, Eindhoven University of Technology, +C The Netherlands, 1987. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB04FY by Th.G.J. Beelen, +C Philips Glass Eindhoven, Holland. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Generalized eigenvalue problem, orthogonal transformation, +C staircase form. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + LOGICAL UPDATQ, UPDATZ + INTEGER INFO, LDA, LDE, LDQ, LDZ, M, N, NBLCKS +C .. Array Arguments .. + INTEGER IMUK(*), INUK(*) + DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER IFICA, IFICE, IFIRE, ISMUK, ISNUK1, K, MUK, + $ MUKP1, NUK +C .. External Subroutines .. + EXTERNAL MB04TV, MB04TW +C .. Executable Statements .. +C + INFO = 0 + IF ( M.LE.0 .OR. N.LE.0 ) + $ RETURN +C +C ISMUK = sum(i=1,...,k) MU(i), +C ISNUK1 = sum(i=1,...,k-1) NU(i). +C + ISMUK = 0 + ISNUK1 = 0 +C + DO 20 K = 1, NBLCKS + ISMUK = ISMUK + IMUK(K) + ISNUK1 = ISNUK1 + INUK(K) + 20 CONTINUE +C +C Note: ISNUK1 has not yet the correct value. +C + MUKP1 = 0 +C + DO 40 K = NBLCKS, 1, -1 + MUK = IMUK(K) + NUK = INUK(K) + ISNUK1 = ISNUK1 - NUK +C +C Determine left upper absolute co-ordinates of E(k) in E-matrix +C and of A(k) in A-matrix. +C + IFIRE = 1 + ISNUK1 + IFICE = 1 + ISMUK + IFICA = IFICE - MUK +C +C Reduce E(k) to upper triangular form using Givens +C transformations on rows only. Apply the same transformations +C to the rows of A(k). +C + IF ( MUKP1.GT.NUK ) THEN + INFO = 1 + RETURN + END IF +C + CALL MB04TW( UPDATQ, M, N, NUK, MUKP1, IFIRE, IFICE, IFICA, A, + $ LDA, E, LDE, Q, LDQ ) +C +C Reduce A(k) to upper triangular form using Givens +C transformations on columns only. Apply the same transformations +C to the columns in the E-matrix. +C + IF ( NUK.GT.MUK ) THEN + INFO = 2 + RETURN + END IF +C + CALL MB04TV( UPDATZ, N, NUK, MUK, IFIRE, IFICA, A, LDA, E, LDE, + $ Z, LDZ ) +C + ISMUK = ISMUK - MUK + MUKP1 = MUK + 40 CONTINUE +C + RETURN +C *** Last line of MB04TY *** + END diff --git a/mex/sources/libslicot/MB04UD.f b/mex/sources/libslicot/MB04UD.f new file mode 100644 index 000000000..a5e2ba347 --- /dev/null +++ b/mex/sources/libslicot/MB04UD.f @@ -0,0 +1,375 @@ + SUBROUTINE MB04UD( JOBQ, JOBZ, M, N, A, LDA, E, LDE, Q, LDQ, + $ Z, LDZ, RANKE, ISTAIR, TOL, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute orthogonal transformations Q and Z such that the +C transformed pencil Q'(sE-A)Z has the E matrix in column echelon +C form, where E and A are M-by-N matrices. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBQ CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix Q the unitary row permutations, as follows: +C = 'N': Do not form Q; +C = 'I': Q is initialized to the unit matrix and the +C unitary row permutation matrix Q is returned; +C = 'U': The given matrix Q is updated by the unitary +C row permutations used in the reduction. +C +C JOBZ CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix Z the unitary column transformations, as follows: +C = 'N': Do not form Z; +C = 'I': Z is initialized to the unit matrix and the +C unitary transformation matrix Z is returned; +C = 'U': The given matrix Z is updated by the unitary +C transformations used in the reduction. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows in the matrices A, E and the order of +C the matrix Q. M >= 0. +C +C N (input) INTEGER +C The number of columns in the matrices A, E and the order +C of the matrix Z. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading M-by-N part of this array must +C contain the A matrix of the pencil sE-A. +C On exit, the leading M-by-N part of this array contains +C the unitary transformed matrix Q' * A * Z. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading M-by-N part of this array must +C contain the E matrix of the pencil sE-A, to be reduced to +C column echelon form. +C On exit, the leading M-by-N part of this array contains +C the unitary transformed matrix Q' * E * Z, which is in +C column echelon form. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,M). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) +C On entry, if JOBQ = 'U', then the leading M-by-M part of +C this array must contain a given matrix Q (e.g. from a +C previous call to another SLICOT routine), and on exit, the +C leading M-by-M part of this array contains the product of +C the input matrix Q and the row permutation matrix used to +C transform the rows of matrix E. +C On exit, if JOBQ = 'I', then the leading M-by-M part of +C this array contains the matrix of accumulated unitary +C row transformations performed. +C If JOBQ = 'N', the array Q is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDQ = 1 and +C declare this array to be Q(1,1) in the calling program). +C +C LDQ INTEGER +C The leading dimension of array Q. If JOBQ = 'U' or +C JOBQ = 'I', LDQ >= MAX(1,M); if JOBQ = 'N', LDQ >= 1. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) +C On entry, if JOBZ = 'U', then the leading N-by-N part of +C this array must contain a given matrix Z (e.g. from a +C previous call to another SLICOT routine), and on exit, the +C leading N-by-N part of this array contains the product of +C the input matrix Z and the column transformation matrix +C used to transform the columns of matrix E. +C On exit, if JOBZ = 'I', then the leading N-by-N part of +C this array contains the matrix of accumulated unitary +C column transformations performed. +C If JOBZ = 'N', the array Z is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDZ = 1 and +C declare this array to be Z(1,1) in the calling program). +C +C LDZ INTEGER +C The leading dimension of array Z. If JOBZ = 'U' or +C JOBZ = 'I', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. +C +C RANKE (output) INTEGER +C The computed rank of the unitary transformed matrix E. +C +C ISTAIR (output) INTEGER array, dimension (M) +C This array contains information on the column echelon form +C of the unitary transformed matrix E. Specifically, +C ISTAIR(i) = +j if the first non-zero element E(i,j) +C is a corner point and -j otherwise, for i = 1,2,...,M. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance below which matrix elements are considered +C to be zero. If the user sets TOL to be less than (or +C equal to) zero then the tolerance is taken as +C EPS * MAX(ABS(E(I,J))), where EPS is the machine +C precision (see LAPACK Library routine DLAMCH), +C I = 1,2,...,M and J = 1,2,...,N. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension MAX(M,N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given an M-by-N matrix pencil sE-A with E not necessarily regular, +C the routine computes a unitary transformed pencil Q'(sE-A)Z such +C that the matrix Q' * E * Z is in column echelon form (trapezoidal +C form). Further details can be found in [1]. +C +C [An M-by-N matrix E with rank(E) = r is said to be in column +C echelon form if the following conditions are satisfied: +C (a) the first (N - r) columns contain only zero elements; and +C (b) if E(i(k),k) is the last nonzero element in column k for +C k = N-r+1,...,N, i.e. E(i(k),k) <> 0 and E(j,k) = 0 for +C j > i(k), then 1 <= i(N-r+1) < i(N-r+2) < ... < i(N) <= M.] +C +C REFERENCES +C +C [1] Beelen, Th. and Van Dooren, P. +C An improved algorithm for the computation of Kronecker's +C canonical form of a singular pencil. +C Linear Algebra and Applications, 105, pp. 9-65, 1988. +C +C NUMERICAL ASPECTS +C +C It is shown in [1] that the algorithm is numerically backward +C stable. The operations count is proportional to (MAX(M,N))**3. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. +C Based on Release 3.0 routine MB04SD modified by A. Varga, +C German Aerospace Research Establishment, Oberpfaffenhofen, +C Germany, Dec. 1997, to transform also the matrix A. +C +C REVISIONS +C +C A. Varga, DLR Oberpfaffenhofen, June 2005. +C +C KEYWORDS +C +C Echelon form, orthogonal transformation, staircase form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBQ, JOBZ + INTEGER INFO, LDA, LDE, LDQ, LDZ, M, N, RANKE + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER ISTAIR(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL LJOBQI, LJOBZI, LZERO, UPDATQ, UPDATZ + INTEGER I, K, KM1, L, LK, MNK, NR1 + DOUBLE PRECISION EMX, EMXNRM, TAU, TOLER +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DLARF, DLARFG, DLASET, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LJOBQI = LSAME( JOBQ, 'I' ) + UPDATQ = LJOBQI.OR.LSAME( JOBQ, 'U' ) + LJOBZI = LSAME( JOBZ, 'I' ) + UPDATZ = LJOBZI.OR.LSAME( JOBZ, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.UPDATQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.UPDATZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDE.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( .NOT.UPDATQ .AND. LDQ.LT.1 .OR. + $ UPDATQ .AND. LDQ.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( .NOT.UPDATZ .AND. LDZ.LT.1 .OR. + $ UPDATZ .AND. LDZ.LT.MAX( 1, N ) ) THEN + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB04UD', -INFO ) + RETURN + END IF +C +C Initialize Q and Z to the identity matrices, if needed. +C + IF ( LJOBQI ) + $ CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ ) + IF ( LJOBZI ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +C +C Quick return if possible. +C + RANKE = MIN( M, N ) +C + IF ( RANKE.EQ.0 ) + $ RETURN +C + TOLER = TOL + IF ( TOLER.LE.ZERO ) + $ TOLER = DLAMCH( 'Epsilon' )*DLANGE( 'M', M, N, E, LDE, DWORK ) +C + K = N + LZERO = .FALSE. +C +C WHILE ( ( K > 0 ) AND ( NOT a zero submatrix encountered ) ) DO + 20 IF ( ( K.GT.0 ) .AND. ( .NOT. LZERO ) ) THEN +C +C Intermediate form of E +C +C <--k--><--n-k-> +C l=1 |x....x| | +C | | | +C | Ek | X | +C | | | +C l=m-n+k |x....x| | +C ---------------- +C | |x ... x| } +C | O | x x x| } +C | | x x| } n-k +C | | x| } +C +C where submatrix Ek = E[1:m-n+k;1:k]. +C +C Determine row LK in submatrix Ek with largest max-norm +C (starting with row m-n+k). +C + MNK = M - N + K + EMXNRM = ZERO + LK = MNK +C + DO 40 L = MNK, 1, -1 + EMX = ABS( E(L,IDAMAX( K, E(L,1), LDE )) ) + IF ( EMX.GT.EMXNRM ) THEN + EMXNRM = EMX + LK = L + END IF + 40 CONTINUE +C + IF ( EMXNRM.LE.TOLER ) THEN +C +C Set submatrix Ek to zero. +C + CALL DLASET( 'Full', MNK, K, ZERO, ZERO, E, LDE ) + LZERO = .TRUE. + RANKE = N - K + ELSE +C +C Submatrix Ek is not considered to be identically zero. +C Check whether rows have to be interchanged. +C + IF ( LK.NE.MNK ) THEN +C +C Interchange rows lk and m-n+k in whole A- and E-matrix +C and update the row transformation matrix Q, if needed. +C (For Q, the number of elements involved is m.) +C + CALL DSWAP( N, E(LK,1), LDE, E(MNK,1), LDE ) + CALL DSWAP( N, A(LK,1), LDA, A(MNK,1), LDA ) + IF( UPDATQ ) CALL DSWAP( M, Q(1,LK), 1, Q(1,MNK), 1 ) + END IF +C + KM1 = K - 1 +C +C Determine a Householder transformation to annihilate +C E(m-n+k,1:k-1) using E(m-n+k,k) as pivot. +C Apply the transformation to the columns of A and Ek +C (number of elements involved is m for A and m-n+k for Ek). +C Update the column transformation matrix Z, if needed +C (number of elements involved is n). +C + CALL DLARFG( K, E(MNK,K), E(MNK,1), LDE, TAU ) + EMX = E(MNK,K) + E(MNK,K) = ONE + CALL DLARF( 'Right', MNK-1, K, E(MNK,1), LDE, TAU, E, LDE, + $ DWORK ) + CALL DLARF( 'Right', M, K, E(MNK,1), LDE, TAU, A, LDA, + $ DWORK ) + IF( UPDATZ ) CALL DLARF( 'Right', N, K, E(MNK,1), LDE, TAU, + $ Z, LDZ, DWORK ) + E(MNK,K) = EMX + CALL DLASET( 'Full', 1, KM1, ZERO, ZERO, E(MNK,1), LDE ) +C + K = KM1 + END IF + GO TO 20 + END IF +C END WHILE 20 +C +C Initialise administration staircase form, i.e. +C ISTAIR(i) = j if E(i,j) is a nonzero corner point +C = -j if E(i,j) is on the boundary but is no corner +C point. +C Thus, +C ISTAIR(m-k) = n-k for k=0,...,rank(E)-1 +C = -(n-rank(E)+1) for k=rank(E),...,m-1. +C + DO 60 I = 0, RANKE - 1 + ISTAIR(M-I) = N - I + 60 CONTINUE +C + NR1 = -(N - RANKE + 1) +C + DO 80 I = 1, M - RANKE + ISTAIR(I) = NR1 + 80 CONTINUE +C + RETURN +C *** Last line of MB04UD *** + END diff --git a/mex/sources/libslicot/MB04VD.f b/mex/sources/libslicot/MB04VD.f new file mode 100644 index 000000000..e83817aad --- /dev/null +++ b/mex/sources/libslicot/MB04VD.f @@ -0,0 +1,540 @@ + SUBROUTINE MB04VD( MODE, JOBQ, JOBZ, M, N, RANKE, A, LDA, E, LDE, + $ Q, LDQ, Z, LDZ, ISTAIR, NBLCKS, NBLCKI, IMUK, + $ INUK, IMUK0, MNEI, TOL, IWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute orthogonal transformations Q and Z such that the +C transformed pencil Q'(sE-A)Z is in upper block triangular form, +C where E is an M-by-N matrix in column echelon form (see SLICOT +C Library routine MB04UD) and A is an M-by-N matrix. +C +C If MODE = 'B', then the matrices A and E are transformed into the +C following generalized Schur form by unitary transformations Q1 +C and Z1 : +C +C | sE(eps,inf)-A(eps,inf) | X | +C Q1'(sE-A)Z1 = |------------------------|------------|. (1) +C | O | sE(r)-A(r) | +C +C The pencil sE(eps,inf)-A(eps,inf) is in staircase form, and it +C contains all Kronecker column indices and infinite elementary +C divisors of the pencil sE-A. The pencil sE(r)-A(r) contains all +C Kronecker row indices and elementary divisors of sE-A. +C Note: X is a pencil. +C +C If MODE = 'T', then the submatrices having full row and column +C rank in the pencil sE(eps,inf)-A(eps,inf) in (1) are +C triangularized by applying unitary transformations Q2 and Z2 to +C Q1'*(sE-A)*Z1. +C +C If MODE = 'S', then the pencil sE(eps,inf)-A(eps,inf) in (1) is +C separated into sE(eps)-A(eps) and sE(inf)-A(inf) by applying +C unitary transformations Q3 and Z3 to Q2'*Q1'*(sE-A)*Z1*Z2. +C +C This gives +C +C | sE(eps)-A(eps) | X | X | +C |----------------|----------------|------------| +C | O | sE(inf)-A(inf) | X | +C Q'(sE-A)Z =|=================================|============| (2) +C | | | +C | O | sE(r)-A(r) | +C +C where Q = Q1*Q2*Q3 and Z = Z1*Z2*Z3. +C Note: the pencil sE(r)-A(r) is not reduced further. +C +C ARGUMENTS +C +C Mode Parameters +C +C MODE CHARACTER*1 +C Specifies the desired structure of the transformed +C pencil Q'(sE-A)Z to be computed as follows: +C = 'B': Basic reduction given by (1); +C = 'T': Further reduction of (1) to triangular form; +C = 'S': Further separation of sE(eps,inf)-A(eps,inf) +C in (1) into the two pencils in (2). +C +C JOBQ CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix Q the orthogonal row transformations, as follows: +C = 'N': Do not form Q; +C = 'I': Q is initialized to the unit matrix and the +C orthogonal transformation matrix Q is returned; +C = 'U': The given matrix Q is updated by the orthogonal +C row transformations used in the reduction. +C +C JOBZ CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal column transformations, as +C follows: +C = 'N': Do not form Z; +C = 'I': Z is initialized to the unit matrix and the +C orthogonal transformation matrix Z is returned; +C = 'U': The given matrix Z is updated by the orthogonal +C transformations used in the reduction. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows in the matrices A, E and the order of +C the matrix Q. M >= 0. +C +C N (input) INTEGER +C The number of columns in the matrices A, E and the order +C of the matrix Z. N >= 0. +C +C RANKE (input) INTEGER +C The rank of the matrix E in column echelon form. +C RANKE >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix to be row compressed. +C On exit, the leading M-by-N part of this array contains +C the matrix that has been row compressed while keeping +C matrix E in column echelon form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix in column echelon form to be +C transformed equivalent to matrix A. +C On exit, the leading M-by-N part of this array contains +C the matrix that has been transformed equivalent to matrix +C A. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,M). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) +C On entry, if JOBQ = 'U', then the leading M-by-M part of +C this array must contain a given matrix Q (e.g. from a +C previous call to another SLICOT routine), and on exit, the +C leading M-by-M part of this array contains the product of +C the input matrix Q and the row transformation matrix used +C to transform the rows of matrices A and E. +C On exit, if JOBQ = 'I', then the leading M-by-M part of +C this array contains the matrix of accumulated orthogonal +C row transformations performed. +C If JOBQ = 'N', the array Q is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDQ = 1 and +C declare this array to be Q(1,1) in the calling program). +C +C LDQ INTEGER +C The leading dimension of array Q. If JOBQ = 'U' or +C JOBQ = 'I', LDQ >= MAX(1,M); if JOBQ = 'N', LDQ >= 1. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) +C On entry, if JOBZ = 'U', then the leading N-by-N part of +C this array must contain a given matrix Z (e.g. from a +C previous call to another SLICOT routine), and on exit, the +C leading N-by-N part of this array contains the product of +C the input matrix Z and the column transformation matrix +C used to transform the columns of matrices A and E. +C On exit, if JOBZ = 'I', then the leading N-by-N part of +C this array contains the matrix of accumulated orthogonal +C column transformations performed. +C If JOBZ = 'N', the array Z is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDZ = 1 and +C declare this array to be Z(1,1) in the calling program). +C +C LDZ INTEGER +C The leading dimension of array Z. If JOBZ = 'U' or +C JOBZ = 'I', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. +C +C ISTAIR (input/output) INTEGER array, dimension (M) +C On entry, this array must contain information on the +C column echelon form of the unitary transformed matrix E. +C Specifically, ISTAIR(i) must be set to +j if the first +C non-zero element E(i,j) is a corner point and -j +C otherwise, for i = 1,2,...,M. +C On exit, this array contains no useful information. +C +C NBLCKS (output) INTEGER +C The number of submatrices having full row rank greater +C than or equal to 0 detected in matrix A in the pencil +C sE(x)-A(x), +C where x = eps,inf if MODE = 'B' or 'T', +C or x = eps if MODE = 'S'. +C +C NBLCKI (output) INTEGER +C If MODE = 'S', the number of diagonal submatrices in the +C pencil sE(inf)-A(inf). If MODE = 'B' or 'T' then +C NBLCKI = 0. +C +C IMUK (output) INTEGER array, dimension (MAX(N,M+1)) +C The leading NBLCKS elements of this array contain the +C column dimensions mu(1),...,mu(NBLCKS) of the submatrices +C having full column rank in the pencil sE(x)-A(x), +C where x = eps,inf if MODE = 'B' or 'T', +C or x = eps if MODE = 'S'. +C +C INUK (output) INTEGER array, dimension (MAX(N,M+1)) +C The leading NBLCKS elements of this array contain the +C row dimensions nu(1),...,nu(NBLCKS) of the submatrices +C having full row rank in the pencil sE(x)-A(x), +C where x = eps,inf if MODE = 'B' or 'T', +C or x = eps if MODE = 'S'. +C +C IMUK0 (output) INTEGER array, dimension (limuk0), +C where limuk0 = N if MODE = 'S' and 1, otherwise. +C If MODE = 'S', then the leading NBLCKI elements of this +C array contain the dimensions mu0(1),...,mu0(NBLCKI) +C of the square diagonal submatrices in the pencil +C sE(inf)-A(inf). +C Otherwise, IMUK0 is not referenced and can be supplied +C as a dummy array. +C +C MNEI (output) INTEGER array, dimension (3) +C If MODE = 'B' or 'T' then +C MNEI(1) contains the row dimension of +C sE(eps,inf)-A(eps,inf); +C MNEI(2) contains the column dimension of +C sE(eps,inf)-A(eps,inf); +C MNEI(3) = 0. +C If MODE = 'S', then +C MNEI(1) contains the row dimension of sE(eps)-A(eps); +C MNEI(2) contains the column dimension of sE(eps)-A(eps); +C MNEI(3) contains the order of the regular pencil +C sE(inf)-A(inf). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance below which matrix elements are considered +C to be zero. If the user sets TOL to be less than (or +C equal to) zero then the tolerance is taken as +C EPS * MAX( ABS(A(I,J)), ABS(E(I,J)) ), where EPS is the +C machine precision (see LAPACK Library routine DLAMCH), +C I = 1,2,...,M and J = 1,2,...,N. +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C > 0: if incorrect rank decisions were revealed during the +C triangularization phase. This failure is not likely +C to occur. The possible values are: +C = 1: if incorrect dimensions of a full column rank +C submatrix; +C = 2: if incorrect dimensions of a full row rank +C submatrix. +C +C METHOD +C +C Let sE - A be an arbitrary pencil. Prior to calling the routine, +C this pencil must be transformed into a pencil with E in column +C echelon form. This may be accomplished by calling the SLICOT +C Library routine MB04UD. Depending on the value of MODE, +C submatrices of A and E are then reduced to one of the forms +C described above. Further details can be found in [1]. +C +C REFERENCES +C +C [1] Beelen, Th. and Van Dooren, P. +C An improved algorithm for the computation of Kronecker's +C canonical form of a singular pencil. +C Linear Algebra and Applications, 105, pp. 9-65, 1988. +C +C NUMERICAL ASPECTS +C +C It is shown in [1] that the algorithm is numerically backward +C stable. The operations count is proportional to (MAX(M,N))**3. +C +C FURTHER COMMENTS +C +C The difference mu(k)-nu(k), for k = 1,2,...,NBLCKS, is the number +C of elementary Kronecker blocks of size k x (k+1). +C +C If MODE = 'B' or 'T' on entry, then the difference nu(k)-mu(k+1), +C for k = 1,2,...,NBLCKS, is the number of infinite elementary +C divisors of degree k (with mu(NBLCKS+1) = 0). +C +C If MODE = 'S' on entry, then the difference mu0(k)-mu0(k+1), +C for k = 1,2,...,NBLCKI, is the number of infinite elementary +C divisors of degree k (with mu0(NBLCKI+1) = 0). +C In the pencil sE(r)-A(r), the pencils sE(f)-A(f) and +C sE(eta)-A(eta) can be separated by pertransposing the pencil +C sE(r)-A(r) and calling the routine with MODE set to 'B'. The +C result has got to be pertransposed again. (For more details see +C [1]). +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. +C Based on Release 3.0 routine MB04TD modified by A. Varga, +C German Aerospace Research Establishment, Oberpfaffenhofen, +C Germany, Nov. 1997, as follows: +C 1) NBLCKI is added; +C 2) the significance of IMUK0 and MNEI is changed; +C 3) INUK0 is removed. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Generalized eigenvalue problem, orthogonal transformation, +C staircase form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBQ, JOBZ, MODE + INTEGER INFO, LDA, LDE, LDQ, LDZ, M, N, NBLCKI, NBLCKS, + $ RANKE + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IMUK(*), IMUK0(*), INUK(*), ISTAIR(*), IWORK(*), + $ MNEI(*) + DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL FIRST, FIRSTI, LJOBQI, LJOBZI, LMODEB, LMODES, + $ LMODET, UPDATQ, UPDATZ + INTEGER I, IFICA, IFIRA, ISMUK, ISNUK, JK, K, NCA, NRA, + $ RANKA + DOUBLE PRECISION TOLER +C .. Local Arrays .. + DOUBLE PRECISION DWORK(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DLASET, MB04TT, MB04TY, MB04VX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. Executable Statements .. +C + INFO = 0 + LMODEB = LSAME( MODE, 'B' ) + LMODET = LSAME( MODE, 'T' ) + LMODES = LSAME( MODE, 'S' ) + LJOBQI = LSAME( JOBQ, 'I' ) + UPDATQ = LJOBQI.OR.LSAME( JOBQ, 'U' ) + LJOBZI = LSAME( JOBZ, 'I' ) + UPDATZ = LJOBZI.OR.LSAME( JOBZ, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LMODEB .AND. .NOT.LMODET .AND. .NOT.LMODES ) THEN + INFO = -1 + ELSE IF( .NOT.UPDATQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN + INFO = -2 + ELSE IF( .NOT.UPDATZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( RANKE.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDE.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( .NOT.UPDATQ .AND. LDQ.LT.1 .OR. + $ UPDATQ .AND. LDQ.LT.MAX( 1, M ) ) THEN + INFO = -12 + ELSE IF( .NOT.UPDATZ .AND. LDZ.LT.1 .OR. + $ UPDATZ .AND. LDZ.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB04VD', -INFO ) + RETURN + END IF +C +C Initialize Q and Z to the identity matrices, if needed. +C + IF ( LJOBQI ) + $ CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ ) + IF ( LJOBZI ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +C +C Quick return if possible. +C + NBLCKS = 0 + NBLCKI = 0 +C + IF ( N.EQ.0 ) THEN + MNEI(1) = 0 + MNEI(2) = 0 + MNEI(3) = 0 + RETURN + END IF +C + IF ( M.EQ.0 ) THEN + NBLCKS = N + DO 10 I = 1, N + IMUK(I) = 1 + INUK(I) = 0 + 10 CONTINUE + MNEI(1) = 0 + MNEI(2) = N + MNEI(3) = 0 + RETURN + END IF +C + TOLER = TOL + IF ( TOLER.LE.ZERO ) + $ TOLER = DLAMCH( 'Epsilon' )* + $ MAX( DLANGE( 'M', M, N, A, LDA, DWORK ), + $ DLANGE( 'M', M, N, E, LDE, DWORK ) ) +C +C A(k) is the submatrix in A that will be row compressed. +C +C ISMUK = sum(i=1,..,k) MU(i), ISNUK = sum(i=1,...,k) NU(i), +C IFIRA, IFICA: first row and first column index of A(k) in A. +C NRA, NCA: number of rows and columns in A(k). +C + IFIRA = 1 + IFICA = 1 + NRA = M + NCA = N - RANKE + ISNUK = 0 + ISMUK = 0 + K = 0 +C +C Initialization of the arrays INUK and IMUK. +C + DO 20 I = 1, M + 1 + INUK(I) = -1 + 20 CONTINUE +C +C Note: it is necessary that array INUK has DIMENSION M+1 since it +C is possible that M = 1 and NBLCKS = 2. +C Example sE-A = (0 0 s -1). +C + DO 40 I = 1, N + IMUK(I) = -1 + 40 CONTINUE +C +C Compress the rows of A while keeping E in column echelon form. +C +C REPEAT +C + 60 K = K + 1 + CALL MB04TT( UPDATQ, UPDATZ, M, N, IFIRA, IFICA, NCA, A, LDA, + $ E, LDE, Q, LDQ, Z, LDZ, ISTAIR, RANKA, TOLER, + $ IWORK ) + IMUK(K) = NCA + ISMUK = ISMUK + NCA +C + INUK(K) = RANKA + ISNUK = ISNUK + RANKA + NBLCKS = NBLCKS + 1 +C +C If the rank of A(k) is nra then A has full row rank; +C JK = the first column index (in A) after the right most column +C of matrix A(k+1). (In case A(k+1) is empty, then JK = N+1.) +C + IFIRA = 1 + ISNUK + IFICA = 1 + ISMUK + IF ( IFIRA.GT.M ) THEN + JK = N + 1 + ELSE + JK = ABS( ISTAIR(IFIRA) ) + END IF + NRA = M - ISNUK + NCA = JK - 1 - ISMUK +C +C If NCA > 0 then there can be done some more row compression +C of matrix A while keeping matrix E in column echelon form. +C + IF ( NCA.GT.0 ) GO TO 60 +C UNTIL NCA <= 0 +C +C Matrix E(k+1) has full column rank since NCA = 0. +C Reduce A and E by ignoring all rows and columns corresponding +C to E(k+1). Ignoring these columns in E changes the ranks of the +C submatrices E(i), (i=1,...,k-1). +C + MNEI(1) = ISNUK + MNEI(2) = ISMUK + MNEI(3) = 0 +C + IF ( LMODEB ) + $ RETURN +C +C Triangularization of the submatrices in A and E. +C + CALL MB04TY( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, LDA, E, + $ LDE, Q, LDQ, Z, LDZ, INFO ) +C + IF ( INFO.GT.0 .OR. LMODET ) + $ RETURN +C +C Save the row dimensions of the diagonal submatrices in pencil +C sE(eps,inf)-A(eps,inf). +C + DO 80 I = 1, NBLCKS + IMUK0(I) = INUK(I) + 80 CONTINUE +C +C Reduction to square submatrices E(k)'s in E. +C + CALL MB04VX( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, LDA, E, + $ LDE, Q, LDQ, Z, LDZ, MNEI ) +C +C Determine the dimensions of the inf diagonal submatrices and +C update block numbers if necessary. +C + FIRST = .TRUE. + FIRSTI = .TRUE. + NBLCKI = NBLCKS + K = NBLCKS +C + DO 100 I = K, 1, -1 + IMUK0(I) = IMUK0(I) - INUK(I) + IF ( FIRSTI .AND. IMUK0(I).EQ.0 ) THEN + NBLCKI = NBLCKI - 1 + ELSE + FIRSTI = .FALSE. + END IF + IF ( FIRST .AND. IMUK(I).EQ.0 ) THEN + NBLCKS = NBLCKS - 1 + ELSE + FIRST = .FALSE. + END IF + 100 CONTINUE +C + RETURN +C *** Last line of MB04VD *** + END diff --git a/mex/sources/libslicot/MB04VX.f b/mex/sources/libslicot/MB04VX.f new file mode 100644 index 000000000..92cfab1cd --- /dev/null +++ b/mex/sources/libslicot/MB04VX.f @@ -0,0 +1,384 @@ + SUBROUTINE MB04VX( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, + $ LDA, E, LDE, Q, LDQ, Z, LDZ, MNEI ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To separate the pencils s*E(eps)-A(eps) and s*E(inf)-A(inf) in +C s*E(eps,inf)-A(eps,inf) using Algorithm 3.3.3 in [1]. +C +C On entry, it is assumed that the M-by-N matrices A and E have +C been obtained after applying the Algorithms 3.2.1 and 3.3.1 to +C the pencil s*E - A as described in [1], i.e. +C +C | s*E(eps,inf)-A(eps,inf) | X | +C Q'(s*E - A)Z = |-------------------------|-------------| +C | 0 | s*E(r)-A(r) | +C +C Here the pencil s*E(eps,inf)-A(eps,inf) is in staircase form. +C This pencil contains all Kronecker column indices and infinite +C elementary divisors of the pencil s*E - A. +C The pencil s*E(r)-A(r) contains all Kronecker row indices and +C finite elementary divisors of s*E - A. +C Furthermore, the submatrices having full row and column rank in +C the pencil s*E(eps,inf)-A(eps,inf) are assumed to be +C triangularized. +C +C On exit, the result then is +C +C Q'(s*E - A)Z = +C +C | s*E(eps)-A(eps) | X | X | +C |-----------------|-----------------|-------------| +C | 0 | s*E(inf)-A(inf) | X | +C |===================================|=============| +C | | | +C | 0 | s*E(r)-A(r) | +C +C Note that the pencil s*E(r)-A(r) is not reduced further. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPDATQ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Q the orthogonal row transformations, as follows: +C = .FALSE.: Do not form Q; +C = .TRUE.: The given matrix Q is updated by the orthogonal +C row transformations used in the reduction. +C +C UPDATZ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal column transformations, as +C follows: +C = .FALSE.: Do not form Z; +C = .TRUE.: The given matrix Z is updated by the orthogonal +C column transformations used in the reduction. +C +C Input/Output Parameters +C +C M (input) INTEGER +C Number of rows of A and E. M >= 0. +C +C N (input) INTEGER +C Number of columns of A and E. N >= 0. +C +C NBLCKS (input) INTEGER +C The number of submatrices having full row rank (possibly +C zero) in A(eps,inf). +C +C INUK (input/output) INTEGER array, dimension (NBLCKS) +C On entry, this array contains the row dimensions nu(k), +C (k=1, 2, ..., NBLCKS) of the submatrices having full row +C rank in the pencil s*E(eps,inf)-A(eps,inf). +C On exit, this array contains the row dimensions nu(k), +C (k=1, 2, ..., NBLCKS) of the submatrices having full row +C rank in the pencil s*E(eps)-A(eps). +C +C IMUK (input/output) INTEGER array, dimension (NBLCKS) +C On entry, this array contains the column dimensions mu(k), +C (k=1, 2, ..., NBLCKS) of the submatrices having full +C column rank in the pencil s*E(eps,inf)-A(eps,inf). +C On exit, this array contains the column dimensions mu(k), +C (k=1, 2, ..., NBLCKS) of the submatrices having full +C column rank in the pencil s*E(eps)-A(eps). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, this array contains the matrix A to be reduced. +C On exit, it contains the transformed matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, this array contains the matrix E to be reduced. +C On exit, it contains the transformed matrix E. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,M). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) +C On entry, if UPDATQ = .TRUE., then the leading M-by-M +C part of this array must contain a given matrix Q (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading M-by-M part of this array contains the +C product of the input matrix Q and the row transformation +C matrix that has transformed the rows of the matrices A +C and E. +C If UPDATQ = .FALSE., the array Q is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDQ = 1 and declare this array to be Q(1,1) in the calling +C program). +C +C LDQ INTEGER +C The leading dimension of array Q. If UPDATQ = .TRUE., +C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) +C On entry, if UPDATZ = .TRUE., then the leading N-by-N +C part of this array must contain a given matrix Z (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading N-by-N part of this array contains the +C product of the input matrix Z and the column +C transformation matrix that has transformed the columns of +C the matrices A and E. +C If UPDATZ = .FALSE., the array Z is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDZ = 1 and declare this array to be Z(1,1) in the calling +C program). +C +C LDZ INTEGER +C The leading dimension of array Z. If UPDATZ = .TRUE., +C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. +C +C MNEI (output) INTEGER array, dimension (3) +C MNEI(1) = MEPS = row dimension of sE(eps)-A(eps); +C MNEI(2) = NEPS = column dimension of sE(eps)-A(eps); +C MNEI(3) = MINF = order of the regular pencil +C sE(inf)-A(inf). +C +C REFERENCES +C +C [1] Beelen, Th. +C New Algorithms for Computing the Kronecker structure of a +C Pencil with Applications to Systems and Control Theory. +C Ph.D.Thesis, Eindhoven University of Technology, +C The Netherlands, 1987. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. +C Based on Release 3.0 routine MB04TX modified by A. Varga, +C German Aerospace Research Establishment, Oberpfaffenhofen, +C Germany, Nov. 1997, as follows: +C 1) NBLCKS is only an input variable; +C 2) the significance of MNEI is changed. +C +C REVISIONS +C +C A. Varga, DLR Oberpfaffenhofen, March 2002. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, orthogonal +C transformation, staircase form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + LOGICAL UPDATQ, UPDATZ + INTEGER LDA, LDE, LDQ, LDZ, M, N, NBLCKS +C .. Array Arguments .. + INTEGER IMUK(*), INUK(*), MNEI(3) + DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER CA, CJA, CJE, IP, ISMUK, ISNUK, K, MEPS, MINF, + $ MUK, MUKP1, MUP, MUP1, NEPS, NUK, NUP, RA, RJE, + $ SK1P1, TK1P1, TP1 + DOUBLE PRECISION SC, SS +C .. External Subroutines .. + EXTERNAL DROTG, MB04TU +C .. Executable Statements .. +C + MNEI(1) = 0 + MNEI(2) = 0 + MNEI(3) = 0 + IF ( M.LE.0 .OR. N.LE.0 ) + $ RETURN +C +C Initialisation. +C + ISMUK = 0 + ISNUK = 0 +C + DO 20 K = 1, NBLCKS + ISMUK = ISMUK + IMUK(K) + ISNUK = ISNUK + INUK(K) + 20 CONTINUE +C +C MEPS, NEPS are the dimensions of the pencil s*E(eps)-A(eps). +C MEPS = Sum(k=1,...,nblcks) NU(k), +C NEPS = Sum(k=1,...,nblcks) MU(k). +C MINF is the order of the regular pencil s*E(inf)-A(inf). +C + MEPS = ISNUK + NEPS = ISMUK + MINF = 0 +C +C MUKP1 = mu(k+1). N.B. It is assumed that mu(NBLCKS + 1) = 0. +C + MUKP1 = 0 +C + DO 120 K = NBLCKS, 1, -1 + NUK = INUK(K) + MUK = IMUK(K) +C +C Reduce submatrix E(k,k+1) to square matrix. +C NOTE that always NU(k) >= MU(k+1) >= 0. +C +C WHILE ( NU(k) > MU(k+1) ) DO + 40 IF ( NUK.GT.MUKP1 ) THEN +C +C sk1p1 = sum(i=k+1,...,p-1) NU(i) +C tk1p1 = sum(i=k+1,...,p-1) MU(i) +C ismuk = sum(i=1,...,k) MU(i) +C tp1 = sum(i=1,...,p-1) MU(i) = ismuk + tk1p1. +C + SK1P1 = 0 + TK1P1 = 0 +C + DO 100 IP = K + 1, NBLCKS +C +C Annihilate the elements originally present in the last +C row of E(k,p+1) and A(k,p). +C Start annihilating the first MU(p) - MU(p+1) elements by +C applying column Givens rotations plus interchanging +C elements. +C Use original bottom diagonal element of A(k,k) as pivot. +C Start position of pivot in A = (ra,ca). +C + TP1 = ISMUK + TK1P1 + RA = ISNUK + SK1P1 + CA = TP1 +C + MUP = IMUK(IP) + NUP = INUK(IP) + MUP1 = NUP +C + DO 60 CJA = CA, CA + MUP - NUP - 1 +C +C CJA = current column index of pivot in A. +C + CALL DROTG( A(RA,CJA), A(RA,CJA+1), SC, SS ) +C +C Apply transformations to A- and E-matrix. +C Interchange columns simultaneously. +C Update column transformation matrix Z, if needed. +C + CALL MB04TU( RA-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, + $ SS ) + A(RA,CJA+1) = A(RA,CJA) + A(RA,CJA) = ZERO + CALL MB04TU( RA, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) + IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), + $ 1, SC, SS ) + 60 CONTINUE +C +C Annihilate the remaining elements originally present in +C the last row of E(k,p+1) and A(k,p) by alternatingly +C applying row and column rotations plus interchanging +C elements. +C Use diagonal elements of E(p,p+1) and original bottom +C diagonal element of A(k,k) as pivots, respectively. +C (re,ce) and (ra,ca) are the starting positions of the +C pivots in E and A. +C + CJE = TP1 + MUP + CJA = CJE - MUP1 - 1 +C + DO 80 RJE = RA + 1, RA + MUP1 +C +C (RJE,CJE) = current position pivot in E. +C + CJE = CJE + 1 + CJA = CJA + 1 +C +C Determine the row transformations. +C Apply these transformations to E- and A-matrix. +C Interchange the rows simultaneously. +C Update row transformation matrix Q, if needed. +C + CALL DROTG( E(RJE,CJE), E(RJE-1,CJE), SC, SS ) + CALL MB04TU( N-CJE, E(RJE,CJE+1), LDE, E(RJE-1,CJE+1), + $ LDE, SC, SS ) + E(RJE-1,CJE) = E(RJE,CJE) + E(RJE,CJE) = ZERO + CALL MB04TU( N-CJA+1, A(RJE,CJA), LDA, A(RJE-1,CJA), + $ LDA, SC, SS ) + IF( UPDATQ ) CALL MB04TU( M, Q(1,RJE), 1, + $ Q(1,RJE-1), 1, SC, SS ) +C +C Determine the column transformations. +C Apply these transformations to A- and E-matrix. +C Interchange the columns simultaneously. +C Update column transformation matrix Z, if needed. +C + CALL DROTG( A(RJE,CJA), A(RJE,CJA+1), SC, SS ) + CALL MB04TU( RJE-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, + $ SS ) + A(RJE,CJA+1) = A(RJE,CJA) + A(RJE,CJA) = ZERO + CALL MB04TU( RJE, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) + IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), + $ 1, SC, SS ) + 80 CONTINUE +C + SK1P1 = SK1P1 + NUP + TK1P1 = TK1P1 + MUP +C + 100 CONTINUE +C +C Reduce A=A(eps,inf) and E=E(eps,inf) by ignoring their last +C row and right most column. The row and column ignored +C belong to the pencil s*E(inf)-A(inf). +C Redefine blocks in new A and E. +C + MUK = MUK - 1 + NUK = NUK - 1 + ISMUK = ISMUK - 1 + ISNUK = ISNUK - 1 + MEPS = MEPS - 1 + NEPS = NEPS - 1 + MINF = MINF + 1 +C + GO TO 40 + END IF +C END WHILE 40 +C + IMUK(K) = MUK + INUK(K) = NUK +C +C Now submatrix E(k,k+1) is square. +C +C Consider next submatrix (k:=k-1). +C + ISNUK = ISNUK - NUK + ISMUK = ISMUK - MUK + MUKP1 = MUK + 120 CONTINUE +C +C Store dimensions of the pencils s*E(eps)-A(eps) and +C s*E(inf)-A(inf) in array MNEI. +C + MNEI(1) = MEPS + MNEI(2) = NEPS + MNEI(3) = MINF +C + RETURN +C *** Last line of MB04VX *** + END diff --git a/mex/sources/libslicot/MB04WD.f b/mex/sources/libslicot/MB04WD.f new file mode 100644 index 000000000..9edbbf8c6 --- /dev/null +++ b/mex/sources/libslicot/MB04WD.f @@ -0,0 +1,411 @@ + SUBROUTINE MB04WD( TRANQ1, TRANQ2, M, N, K, Q1, LDQ1, Q2, LDQ2, + $ CS, TAU, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate a matrix Q with orthogonal columns (spanning an +C isotropic subspace), which is defined as the first n columns +C of a product of symplectic reflectors and Givens rotators, +C +C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) +C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) +C .... +C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). +C +C The matrix Q is returned in terms of its first 2*M rows +C +C [ op( Q1 ) op( Q2 ) ] +C Q = [ ]. +C [ -op( Q2 ) op( Q1 ) ] +C +C Blocked version of the SLICOT Library routine MB04WU. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANQ1 CHARACTER*1 +C Specifies the form of op( Q1 ) as follows: +C = 'N': op( Q1 ) = Q1; +C = 'T': op( Q1 ) = Q1'; +C = 'C': op( Q1 ) = Q1'. +C +C TRANQ2 CHARACTER*1 +C Specifies the form of op( Q2 ) as follows: +C = 'N': op( Q2 ) = Q2; +C = 'T': op( Q2 ) = Q2'; +C = 'C': op( Q2 ) = Q2'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices Q1 and Q2. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrices Q1 and Q2. +C M >= N >= 0. +C +C K (input) INTEGER +C The number of symplectic Givens rotators whose product +C partly defines the matrix Q. N >= K >= 0. +C +C Q1 (input/output) DOUBLE PRECISION array, dimension +C (LDQ1,N) if TRANQ1 = 'N', +C (LDQ1,M) if TRANQ1 = 'T' or TRANQ1 = 'C' +C On entry with TRANQ1 = 'N', the leading M-by-K part of +C this array must contain in its i-th column the vector +C which defines the elementary reflector F(i). +C On entry with TRANQ1 = 'T' or TRANQ1 = 'C', the leading +C K-by-M part of this array must contain in its i-th row +C the vector which defines the elementary reflector F(i). +C On exit with TRANQ1 = 'N', the leading M-by-N part of this +C array contains the matrix Q1. +C On exit with TRANQ1 = 'T' or TRANQ1 = 'C', the leading +C N-by-M part of this array contains the matrix Q1'. +C +C LDQ1 INTEGER +C The leading dimension of the array Q1. +C LDQ1 >= MAX(1,M), if TRANQ1 = 'N'; +C LDQ1 >= MAX(1,N), if TRANQ1 = 'T' or TRANQ1 = 'C'. +C +C Q2 (input/output) DOUBLE PRECISION array, dimension +C (LDQ2,N) if TRANQ2 = 'N', +C (LDQ2,M) if TRANQ2 = 'T' or TRANQ2 = 'C' +C On entry with TRANQ2 = 'N', the leading M-by-K part of +C this array must contain in its i-th column the vector +C which defines the elementary reflector H(i) and, on the +C diagonal, the scalar factor of H(i). +C On entry with TRANQ2 = 'T' or TRANQ2 = 'C', the leading +C K-by-M part of this array must contain in its i-th row the +C vector which defines the elementary reflector H(i) and, on +C the diagonal, the scalar factor of H(i). +C On exit with TRANQ2 = 'N', the leading M-by-N part of this +C array contains the matrix Q2. +C On exit with TRANQ2 = 'T' or TRANQ2 = 'C', the leading +C N-by-M part of this array contains the matrix Q2'. +C +C LDQ2 INTEGER +C The leading dimension of the array Q2. +C LDQ2 >= MAX(1,M), if TRANQ2 = 'N'; +C LDQ2 >= MAX(1,N), if TRANQ2 = 'T' or TRANQ2 = 'C'. +C +C CS (input) DOUBLE PRECISION array, dimension (2*K) +C On entry, the first 2*K elements of this array must +C contain the cosines and sines of the symplectic Givens +C rotators G(i). +C +C TAU (input) DOUBLE PRECISION array, dimension (K) +C On entry, the first K elements of this array must +C contain the scalar factors of the elementary reflectors +C F(i). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK, MAX(M+N,8*N*NB + 15*NB*NB), where NB is +C the optimal block size determined by the function UE01MD. +C On exit, if INFO = -13, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,M+N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Kressner, D. +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSB). +C +C KEYWORDS +C +C Elementary matrix operations, orthogonal symplectic matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +C .. Scalar Arguments .. + CHARACTER TRANQ1, TRANQ2 + INTEGER INFO, K, LDQ1, LDQ2, LDWORK, M, N +C .. Array Arguments .. + DOUBLE PRECISION CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*) +C .. Local Scalars .. + LOGICAL LTRQ1, LTRQ2 + INTEGER I, IB, IERR, KI, KK, NB, NBMIN, NX, PDRS, PDT, + $ PDW, WRKOPT +C .. External Functions .. + LOGICAL LSAME + INTEGER UE01MD + EXTERNAL LSAME, UE01MD +C .. External Subroutines .. + EXTERNAL MB04QC, MB04QF, MB04WU, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + LTRQ1 = LSAME( TRANQ1, 'T' ) .OR. LSAME( TRANQ1,'C' ) + LTRQ2 = LSAME( TRANQ2, 'T' ) .OR. LSAME( TRANQ2,'C' ) + NB = UE01MD( 1, 'MB04WD', TRANQ1 // TRANQ2, M, N, K ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( LTRQ1 .OR. LSAME( TRANQ1, 'N' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( LTRQ2 .OR. LSAME( TRANQ2, 'N' ) ) ) THEN + INFO = -2 + ELSE IF ( M.LT.0 ) THEN + INFO = -3 + ELSE IF ( N.LT.0 .OR. N.GT.M ) THEN + INFO = -4 + ELSE IF ( K.LT.0 .OR. K.GT.N ) THEN + INFO = -5 + ELSE IF ( ( LTRQ1 .AND. LDQ1.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LTRQ1 .AND. LDQ1.LT.MAX( 1, M ) ) ) THEN + INFO = -7 + ELSE IF ( ( LTRQ2 .AND. LDQ2.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LTRQ2 .AND. LDQ2.LT.MAX( 1, M ) ) ) THEN + INFO = -9 + ELSE IF ( LDWORK.LT.MAX( 1, M + N ) ) THEN + DWORK(1) = DBLE( MAX( 1, M + N ) ) + INFO = -13 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04WD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + NBMIN = 2 + NX = 0 + WRKOPT = M + N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +C +C Determine when to cross over from blocked to unblocked code. +C + NX = MAX( 0, UE01MD( 3, 'MB04WD', TRANQ1 // TRANQ2, M, N, K ) ) + IF ( NX.LT.K ) THEN +C +C Determine if workspace is large enough for blocked code. +C + WRKOPT = MAX( WRKOPT, 8*N*NB + 15*NB*NB ) + IF( LDWORK.LT.WRKOPT ) THEN +C +C Not enough workspace to use optimal NB: reduce NB and +C determine the minimum value of NB. +C + NB = INT( ( SQRT( DBLE( 16*N*N + 15*LDWORK ) ) + $ - DBLE( 4*N ) ) / 15.0D0 ) + NBMIN = MAX( 2, UE01MD( 2, 'MB04WD', TRANQ1 // TRANQ2, M, + $ N, K ) ) + END IF + END IF + END IF +C + IF ( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +C +C Use blocked code after the last block. +C The first kk columns are handled by the block method. +C + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) + ELSE + KK = 0 + END IF +C +C Use unblocked code for the last or only block. +C + IF ( KK.LT.N ) + $ CALL MB04WU( TRANQ1, TRANQ2, M-KK, N-KK, K-KK, Q1(KK+1,KK+1), + $ LDQ1, Q2(KK+1,KK+1), LDQ2, CS(2*KK+1), TAU(KK+1), + $ DWORK, LDWORK, IERR ) +C +C Blocked code. +C + IF ( KK.GT.0 ) THEN + PDRS = 1 + PDT = PDRS + 6*NB*NB + PDW = PDT + 9*NB*NB + IF ( LTRQ1.AND.LTRQ2 ) THEN + DO 10 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF ( I+IB.LE.N ) THEN +C +C Form the triangular factors of the symplectic block +C reflector SH. +C + CALL MB04QF( 'Forward', 'Rowwise', 'Rowwise', M-I+1, + $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, + $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, + $ DWORK(PDT), NB, DWORK(PDW) ) +C +C Apply SH to Q1(i+ib:n,i:m) and Q2(i+ib:n,i:m) from +C the right. +C + CALL MB04QC( 'Zero Structure', 'Transpose', + $ 'Transpose', 'No Transpose', 'Forward', + $ 'Rowwise', 'Rowwise', M-I+1, N-I-IB+1, + $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, + $ DWORK(PDRS), NB, DWORK(PDT), NB, + $ Q2(I+IB,I), LDQ2, Q1(I+IB,I), LDQ1, + $ DWORK(PDW) ) + END IF +C +C Apply SH to columns i:m of the current block. +C + CALL MB04WU( 'Transpose', 'Transpose', M-I+1, IB, IB, + $ Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), + $ TAU(I), DWORK, LDWORK, IERR ) + 10 CONTINUE +C + ELSE IF ( LTRQ1 ) THEN + DO 20 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF ( I+IB.LE.N ) THEN +C +C Form the triangular factors of the symplectic block +C reflector SH. +C + CALL MB04QF( 'Forward', 'Rowwise', 'Columnwise', + $ M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, + $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, + $ DWORK(PDT), NB, DWORK(PDW) ) +C +C Apply SH to Q1(i+ib:n,i:m) from the right and to +C Q2(i:m,i+ib:n) from the left. +C + CALL MB04QC( 'Zero Structure', 'No Transpose', + $ 'Transpose', 'No Transpose', + $ 'Forward', 'Rowwise', 'Columnwise', + $ M-I+1, N-I-IB+1, IB, Q1(I,I), LDQ1, + $ Q2(I,I), LDQ2, DWORK(PDRS), NB, + $ DWORK(PDT), NB, Q2(I,I+IB), LDQ2, + $ Q1(I+IB,I), LDQ1, DWORK(PDW) ) + END IF +C +C Apply SH to columns/rows i:m of the current block. +C + CALL MB04WU( 'Transpose', 'No Transpose', M-I+1, IB, IB, + $ Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), + $ TAU(I), DWORK, LDWORK, IERR ) + 20 CONTINUE +C + ELSE IF ( LTRQ2 ) THEN + DO 30 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF ( I+IB.LE.N ) THEN +C +C Form the triangular factors of the symplectic block +C reflector SH. +C + CALL MB04QF( 'Forward', 'Columnwise', 'Rowwise', + $ M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, + $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, + $ DWORK(PDT), NB, DWORK(PDW) ) +C +C Apply SH to Q1(i:m,i+ib:n) from the left and to +C Q2(i+ib:n,i:m) from the right. +C + CALL MB04QC( 'Zero Structure', 'Transpose', + $ 'No Transpose', 'No Transpose', 'Forward', + $ 'Columnwise', 'Rowwise', M-I+1, N-I-IB+1, + $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, + $ DWORK(PDRS), NB, DWORK(PDT), NB, + $ Q2(I+IB,I), LDQ2, Q1(I,I+IB), LDQ1, + $ DWORK(PDW) ) + END IF +C +C Apply SH to columns/rows i:m of the current block. +C + CALL MB04WU( 'No Transpose', 'Transpose', M-I+1, IB, IB, + $ Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), + $ TAU(I), DWORK, LDWORK, IERR ) + 30 CONTINUE +C + ELSE + DO 40 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF ( I+IB.LE.N ) THEN +C +C Form the triangular factors of the symplectic block +C reflector SH. +C + CALL MB04QF( 'Forward', 'Columnwise', 'Columnwise', + $ M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, + $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, + $ DWORK(PDT), NB, DWORK(PDW) ) +C +C Apply SH to Q1(i:m,i+ib:n) and Q2(i:m,i+ib:n) from +C the left. +C + CALL MB04QC( 'Zero Structure', 'No Transpose', + $ 'No Transpose', 'No Transpose', + $ 'Forward', 'Columnwise', 'Columnwise', + $ M-I+1, N-I-IB+1, IB, Q1(I,I), LDQ1, + $ Q2(I,I), LDQ2, DWORK(PDRS), NB, + $ DWORK(PDT), NB, Q2(I,I+IB), LDQ2, + $ Q1(I,I+IB), LDQ1, DWORK(PDW) ) + END IF +C +C Apply SH to rows i:m of the current block. +C + CALL MB04WU( 'No Transpose', 'No Transpose', M-I+1, IB, + $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), + $ TAU(I), DWORK, LDWORK, IERR ) + 40 CONTINUE + END IF + END IF +C + DWORK(1) = DBLE( WRKOPT ) +C + RETURN +C *** Last line of MB04WD *** + END diff --git a/mex/sources/libslicot/MB04WP.f b/mex/sources/libslicot/MB04WP.f new file mode 100644 index 000000000..2af3306c6 --- /dev/null +++ b/mex/sources/libslicot/MB04WP.f @@ -0,0 +1,211 @@ + SUBROUTINE MB04WP( N, ILO, U1, LDU1, U2, LDU2, CS, TAU, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate an orthogonal symplectic matrix U, which is defined as +C a product of symplectic reflectors and Givens rotators +C +C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) +C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) +C .... +C diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ). +C +C as returned by MB04PU. The matrix U is returned in terms of its +C first N rows +C +C [ U1 U2 ] +C U = [ ]. +C [ -U2 U1 ] +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices U1 and U2. N >= 0. +C +C ILO (input) INTEGER +C ILO must have the same value as in the previous call of +C MB04PU. U is equal to the unit matrix except in the +C submatrix +C U([ilo+1:n n+ilo+1:2*n], [ilo+1:n n+ilo+1:2*n]). +C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. +C +C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) +C On entry, the leading N-by-N part of this array must +C contain in its i-th column the vector which defines the +C elementary reflector F(i). +C On exit, the leading N-by-N part of this array contains +C the matrix U1. +C +C LDU1 INTEGER +C The leading dimension of the array U1. LDU1 >= MAX(1,N). +C +C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) +C On entry, the leading N-by-N part of this array must +C contain in its i-th column the vector which defines the +C elementary reflector H(i) and, on the subdiagonal, the +C scalar factor of H(i). +C On exit, the leading N-by-N part of this array contains +C the matrix U2. +C +C LDU2 INTEGER +C The leading dimension of the array U2. LDU2 >= MAX(1,N). +C +C CS (input) DOUBLE PRECISION array, dimension (2N-2) +C On entry, the first 2N-2 elements of this array must +C contain the cosines and sines of the symplectic Givens +C rotators G(i). +C +C TAU (input) DOUBLE PRECISION array, dimension (N-1) +C On entry, the first N-1 elements of this array must +C contain the scalar factors of the elementary reflectors +C F(i). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -10, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,2*(N-ILO)). +C For optimum performance LDWORK should be larger. (See +C SLICOT Library routine MB04WD). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O(N**3) floating point operations and is +C strongly backward stable. +C +C REFERENCES +C +C [1] C. F. VAN LOAN: +C A symplectic method for approximating all the eigenvalues of +C a Hamiltonian matrix. +C Linear Algebra and its Applications, 61, pp. 233-251, 1984. +C +C [2] D. KRESSNER: +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C CONTRIBUTORS +C +C D. Kressner (Technical Univ. Berlin, Germany) and +C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. +C +C REVISIONS +C +C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DOSGPV). +C +C KEYWORDS +C +C Elementary matrix operations, orthogonal symplectic matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + INTEGER ILO, INFO, LDU1, LDU2, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION CS(*), DWORK(*), U1(LDU1,*), U2(LDU2,*), TAU(*) +C .. Local Scalars .. + INTEGER I, IERR, J, NH +C .. External Subroutines .. + EXTERNAL DLASET, MB04WD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + IF ( N.LT.0 ) THEN + INFO = -1 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF ( LDU1.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDU2.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF ( LDWORK.LT.MAX( 1, 2*( N - ILO ) ) ) THEN + DWORK(1) = DBLE( MAX( 1, 2*( N - ILO ) ) ) + INFO = -10 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04WP', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Shift the vectors which define the elementary reflectors one +C column to the right, and set the first ilo rows and columns to +C those of the unit matrix. +C + DO 30 J = N, ILO + 1, -1 + DO 10 I = 1, J-1 + U1(I,J) = ZERO + 10 CONTINUE + DO 20 I = J+1, N + U1(I,J) = U1(I,J-1) + 20 CONTINUE + 30 CONTINUE + CALL DLASET( 'All', N, ILO, ZERO, ONE, U1, LDU1 ) + DO 60 J = N, ILO + 1, -1 + DO 40 I = 1, J-1 + U2(I,J) = ZERO + 40 CONTINUE + DO 50 I = J, N + U2(I,J) = U2(I,J-1) + 50 CONTINUE + 60 CONTINUE + CALL DLASET( 'All', N, ILO, ZERO, ZERO, U2, LDU2 ) + NH = N - ILO + IF ( NH.GT.0 ) THEN + CALL MB04WD( 'No Transpose', 'No Transpose', NH, NH, NH, + $ U1(ILO+1,ILO+1), LDU1, U2(ILO+1,ILO+1), LDU2, + $ CS(ILO), TAU(ILO), DWORK, LDWORK, IERR ) + END IF + RETURN +C *** Last line of MB04WP *** + END diff --git a/mex/sources/libslicot/MB04WR.f b/mex/sources/libslicot/MB04WR.f new file mode 100644 index 000000000..42c1f461b --- /dev/null +++ b/mex/sources/libslicot/MB04WR.f @@ -0,0 +1,340 @@ + SUBROUTINE MB04WR( JOB, TRANS, N, ILO, Q1, LDQ1, Q2, LDQ2, CS, + $ TAU, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate orthogonal symplectic matrices U or V, defined as +C products of symplectic reflectors and Givens rotators +C +C U = diag( HU(1),HU(1) ) GU(1) diag( FU(1),FU(1) ) +C diag( HU(2),HU(2) ) GU(2) diag( FU(2),FU(2) ) +C .... +C diag( HU(n),HU(n) ) GU(n) diag( FU(n),FU(n) ), +C +C V = diag( HV(1),HV(1) ) GV(1) diag( FV(1),FV(1) ) +C diag( HV(2),HV(2) ) GV(2) diag( FV(2),FV(2) ) +C .... +C diag( HV(n-1),HV(n-1) ) GV(n-1) diag( FV(n-1),FV(n-1) ), +C +C as returned by the SLICOT Library routines MB04TS or MB04TB. The +C matrices U and V are returned in terms of their first N/2 rows: +C +C [ U1 U2 ] [ V1 V2 ] +C U = [ ], V = [ ]. +C [ -U2 U1 ] [ -V2 V1 ] +C +C ARGUMENTS +C +C Input/Output Parameters +C +C JOB CHARACTER*1 +C Specifies whether the matrix U or the matrix V is +C required: +C = 'U': generate U; +C = 'V': generate V. +C +C TRANS CHARACTER*1 +C If JOB = 'U' then TRANS must have the same value as +C the argument TRANA in the previous call of MB04TS or +C MB04TB. +C If JOB = 'V' then TRANS must have the same value as +C the argument TRANB in the previous call of MB04TS or +C MB04TB. +C +C N (input) INTEGER +C The order of the matrices Q1 and Q2. N >= 0. +C +C ILO (input) INTEGER +C ILO must have the same value as in the previous call of +C MB04TS or MB04TB. U and V are equal to the unit matrix +C except in the submatrices +C U([ilo:n n+ilo:2*n], [ilo:n n+ilo:2*n]) and +C V([ilo+1:n n+ilo+1:2*n], [ilo+1:n n+ilo+1:2*n]), +C respectively. +C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. +C +C Q1 (input/output) DOUBLE PRECISION array, dimension (LDQ1,N) +C On entry, if JOB = 'U' and TRANS = 'N' then the +C leading N-by-N part of this array must contain in its i-th +C column the vector which defines the elementary reflector +C FU(i). +C If JOB = 'U' and TRANS = 'T' or TRANS = 'C' then the +C leading N-by-N part of this array must contain in its i-th +C row the vector which defines the elementary reflector +C FU(i). +C If JOB = 'V' and TRANS = 'N' then the leading N-by-N +C part of this array must contain in its i-th row the vector +C which defines the elementary reflector FV(i). +C If JOB = 'V' and TRANS = 'T' or TRANS = 'C' then the +C leading N-by-N part of this array must contain in its i-th +C column the vector which defines the elementary reflector +C FV(i). +C On exit, if JOB = 'U' and TRANS = 'N' then the leading +C N-by-N part of this array contains the matrix U1. +C If JOB = 'U' and TRANS = 'T' or TRANS = 'C' then the +C leading N-by-N part of this array contains the matrix +C U1**T. +C If JOB = 'V' and TRANS = 'N' then the leading N-by-N +C part of this array contains the matrix V1**T. +C If JOB = 'V' and TRANS = 'T' or TRANS = 'C' then the +C leading N-by-N part of this array contains the matrix V1. +C +C LDQ1 INTEGER +C The leading dimension of the array Q1. LDQ1 >= MAX(1,N). +C +C Q2 (input/output) DOUBLE PRECISION array, dimension (LDQ2,N) +C On entry, if JOB = 'U' then the leading N-by-N part of +C this array must contain in its i-th column the vector +C which defines the elementary reflector HU(i). +C If JOB = 'V' then the leading N-by-N part of this array +C must contain in its i-th row the vector which defines the +C elementary reflector HV(i). +C On exit, if JOB = 'U' then the leading N-by-N part of +C this array contains the matrix U2. +C If JOB = 'V' then the leading N-by-N part of this array +C contains the matrix V2**T. +C +C LDQ2 INTEGER +C The leading dimension of the array Q2. LDQ2 >= MAX(1,N). +C +C CS (input) DOUBLE PRECISION array, dimension (2N) +C On entry, if JOB = 'U' then the first 2N elements of +C this array must contain the cosines and sines of the +C symplectic Givens rotators GU(i). +C If JOB = 'V' then the first 2N-2 elements of this array +C must contain the cosines and sines of the symplectic +C Givens rotators GV(i). +C +C TAU (input) DOUBLE PRECISION array, dimension (N) +C On entry, if JOB = 'U' then the first N elements of +C this array must contain the scalar factors of the +C elementary reflectors FU(i). +C If JOB = 'V' then the first N-1 elements of this array +C must contain the scalar factors of the elementary +C reflectors FV(i). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -12, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,2*(N-ILO+1)). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Benner, P., Mehrmann, V., and Xu, H. +C A numerically stable, structure preserving method for +C computing the eigenvalues of real Hamiltonian or symplectic +C pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998. +C +C [2] Kressner, D. +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSU). +C +C KEYWORDS +C +C Elementary matrix operations, Hamiltonian matrix, orthogonal +C symplectic matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + CHARACTER JOB, TRANS + INTEGER ILO, INFO, LDQ1, LDQ2, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*) +C .. Local Scalars .. + LOGICAL COMPU, LTRAN + INTEGER I, IERR, J, NH +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLASET, MB04WD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) + COMPU = LSAME( JOB, 'U' ) + IF ( .NOT.COMPU .AND. .NOT.LSAME( JOB, 'V' ) ) THEN + INFO = -1 + ELSE IF ( .NOT.LTRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN + INFO = -2 + ELSE IF ( N.LT.0 ) THEN + INFO = -3 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDQ1.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF ( LDQ2.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF ( LDWORK.LT.MAX( 1, 2*( N-ILO+1 ) ) ) THEN + DWORK(1) = DBLE( MAX( 1, 2*( N-ILO+1 ) ) ) + INFO = -12 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04WR', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + IF ( COMPU ) THEN + CALL DLASET( 'All', N, ILO-1, ZERO, ONE, Q1, LDQ1 ) + CALL DLASET( 'All', ILO-1, N-ILO+1, ZERO, ZERO, Q1(1,ILO), + $ LDQ1 ) + CALL DLASET( 'All', N, ILO-1, ZERO, ZERO, Q2, LDQ2 ) + CALL DLASET( 'All', ILO-1, N-ILO+1, ZERO, ZERO, Q2(1,ILO), + $ LDQ2 ) + NH = N - ILO + 1 + END IF + IF ( COMPU .AND. .NOT.LTRAN ) THEN +C +C Generate U1 and U2. +C + IF ( NH.GT.0 ) THEN + CALL MB04WD( 'No Transpose', 'No Transpose', NH, NH, NH, + $ Q1(ILO,ILO), LDQ1, Q2(ILO,ILO), LDQ2, CS(ILO), + $ TAU(ILO), DWORK, LDWORK, IERR ) + END IF + ELSE IF ( COMPU.AND.LTRAN ) THEN +C +C Generate U1**T and U2. +C + IF ( NH.GT.0 ) THEN + CALL MB04WD( 'Transpose', 'No Transpose', NH, NH, NH, + $ Q1(ILO,ILO), LDQ1, Q2(ILO,ILO), LDQ2, CS(ILO), + $ TAU(ILO), DWORK, LDWORK, IERR ) + END IF + ELSE IF ( .NOT.COMPU .AND. .NOT.LTRAN ) THEN +C +C Generate V1**T and V2**T. +C +C Shift the vectors which define the elementary reflectors one +C column to the bottom, and set the first ilo rows and +C columns to those of the unit matrix. +C + DO 40 I = 1, N + DO 10 J = N, MAX( I, ILO )+1, -1 + Q1(J,I) = ZERO + 10 CONTINUE + DO 20 J = MAX( I, ILO ), ILO+1, -1 + Q1(J,I) = Q1(J-1,I) + 20 CONTINUE + DO 30 J = ILO, 1, -1 + Q1(J,I) = ZERO + 30 CONTINUE + IF ( I.LE.ILO ) Q1(I,I) = ONE + 40 CONTINUE + DO 80 I = 1, N + DO 50 J = N, MAX( I, ILO )+1, -1 + Q2(J,I) = ZERO + 50 CONTINUE + DO 60 J = MAX( I, ILO ), ILO+1, -1 + Q2(J,I) = Q2(J-1,I) + 60 CONTINUE + DO 70 J = ILO, 1, -1 + Q2(J,I) = ZERO + 70 CONTINUE + 80 CONTINUE +C + NH = N - ILO + IF ( NH.GT.0 ) THEN + CALL MB04WD( 'Transpose', 'Transpose', NH, NH, NH, + $ Q1(ILO+1,ILO+1), LDQ1, Q2(ILO+1,ILO+1), LDQ2, + $ CS(ILO), TAU(ILO), DWORK, LDWORK, IERR ) + END IF + ELSE IF ( .NOT.COMPU .AND. LTRAN ) THEN +C +C Generate V1 and V2**T. +C +C Shift the vectors which define the elementary reflectors one +C column to the right/bottom, and set the first ilo rows and +C columns to those of the unit matrix. +C + DO 110 J = N, ILO + 1, -1 + DO 90 I = 1, J-1 + Q1(I,J) = ZERO + 90 CONTINUE + DO 100 I = J+1, N + Q1(I,J) = Q1(I,J-1) + 100 CONTINUE + 110 CONTINUE + CALL DLASET( 'All', N, ILO, ZERO, ONE, Q1, LDQ1 ) + DO 150 I = 1, N + DO 120 J = N, MAX( I, ILO )+1, -1 + Q2(J,I) = ZERO + 120 CONTINUE + DO 130 J = MAX( I, ILO ), ILO+1, -1 + Q2(J,I) = Q2(J-1,I) + 130 CONTINUE + DO 140 J = ILO, 1, -1 + Q2(J,I) = ZERO + 140 CONTINUE + 150 CONTINUE + NH = N - ILO +C + IF ( NH.GT.0 ) THEN + CALL MB04WD( 'No Transpose', 'Transpose', NH, NH, NH, + $ Q1(ILO+1,ILO+1), LDQ1, Q2(ILO+1,ILO+1), LDQ2, + $ CS(ILO), TAU(ILO), DWORK, LDWORK, IERR ) + END IF + END IF + RETURN +C *** Last line of MB04WR *** + END diff --git a/mex/sources/libslicot/MB04WU.f b/mex/sources/libslicot/MB04WU.f new file mode 100644 index 000000000..1e177810b --- /dev/null +++ b/mex/sources/libslicot/MB04WU.f @@ -0,0 +1,402 @@ + SUBROUTINE MB04WU( TRANQ1, TRANQ2, M, N, K, Q1, LDQ1, Q2, LDQ2, + $ CS, TAU, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate a matrix Q with orthogonal columns (spanning an +C isotropic subspace), which is defined as the first n columns +C of a product of symplectic reflectors and Givens rotators, +C +C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) +C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) +C .... +C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). +C +C The matrix Q is returned in terms of its first 2*M rows +C +C [ op( Q1 ) op( Q2 ) ] +C Q = [ ]. +C [ -op( Q2 ) op( Q1 ) ] +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANQ1 CHARACTER*1 +C Specifies the form of op( Q1 ) as follows: +C = 'N': op( Q1 ) = Q1; +C = 'T': op( Q1 ) = Q1'; +C = 'C': op( Q1 ) = Q1'. +C +C TRANQ2 CHARACTER*1 +C Specifies the form of op( Q2 ) as follows: +C = 'N': op( Q2 ) = Q2; +C = 'T': op( Q2 ) = Q2'; +C = 'C': op( Q2 ) = Q2'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices Q1 and Q2. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrices Q1 and Q2. +C M >= N >= 0. +C +C K (input) INTEGER +C The number of symplectic Givens rotators whose product +C partly defines the matrix Q. N >= K >= 0. +C +C Q1 (input/output) DOUBLE PRECISION array, dimension +C (LDQ1,N) if TRANQ1 = 'N', +C (LDQ1,M) if TRANQ1 = 'T' or TRANQ1 = 'C' +C On entry with TRANQ1 = 'N', the leading M-by-K part of +C this array must contain in its i-th column the vector +C which defines the elementary reflector F(i). +C On entry with TRANQ1 = 'T' or TRANQ1 = 'C', the leading +C K-by-M part of this array must contain in its i-th row +C the vector which defines the elementary reflector F(i). +C On exit with TRANQ1 = 'N', the leading M-by-N part of this +C array contains the matrix Q1. +C On exit with TRANQ1 = 'T' or TRANQ1 = 'C', the leading +C N-by-M part of this array contains the matrix Q1'. +C +C LDQ1 INTEGER +C The leading dimension of the array Q1. +C LDQ1 >= MAX(1,M), if TRANQ1 = 'N'; +C LDQ1 >= MAX(1,N), if TRANQ1 = 'T' or TRANQ1 = 'C'. +C +C Q2 (input/output) DOUBLE PRECISION array, dimension +C (LDQ2,N) if TRANQ2 = 'N', +C (LDQ2,M) if TRANQ2 = 'T' or TRANQ2 = 'C' +C On entry with TRANQ2 = 'N', the leading M-by-K part of +C this array must contain in its i-th column the vector +C which defines the elementary reflector H(i) and, on the +C diagonal, the scalar factor of H(i). +C On entry with TRANQ2 = 'T' or TRANQ2 = 'C', the leading +C K-by-M part of this array must contain in its i-th row the +C vector which defines the elementary reflector H(i) and, on +C the diagonal, the scalar factor of H(i). +C On exit with TRANQ2 = 'N', the leading M-by-N part of this +C array contains the matrix Q2. +C On exit with TRANQ2 = 'T' or TRANQ2 = 'C', the leading +C N-by-M part of this array contains the matrix Q2'. +C +C LDQ2 INTEGER +C The leading dimension of the array Q2. +C LDQ2 >= MAX(1,M), if TRANQ2 = 'N'; +C LDQ2 >= MAX(1,N), if TRANQ2 = 'T' or TRANQ2 = 'C'. +C +C CS (input) DOUBLE PRECISION array, dimension (2*K) +C On entry, the first 2*K elements of this array must +C contain the cosines and sines of the symplectic Givens +C rotators G(i). +C +C TAU (input) DOUBLE PRECISION array, dimension (K) +C On entry, the first K elements of this array must +C contain the scalar factors of the elementary reflectors +C F(i). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -13, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,M+N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Bunse-Gerstner, A. +C Matrix factorizations for symplectic QR-like methods. +C Linear Algebra Appl., 83, pp. 49-77, 1986. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSQ). +C +C KEYWORDS +C +C Elementary matrix operations, orthogonal symplectic matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + CHARACTER TRANQ1, TRANQ2 + INTEGER INFO, K, LDQ1, LDQ2, LDWORK, M, N +C .. Array Arguments .. + DOUBLE PRECISION CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*) +C .. Local Scalars .. + LOGICAL LTRQ1, LTRQ2 + INTEGER I, J + DOUBLE PRECISION NU +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARF, DLASET, DROT, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + LTRQ1 = LSAME( TRANQ1,'T' ) .OR. LSAME( TRANQ1,'C' ) + LTRQ2 = LSAME( TRANQ2,'T' ) .OR. LSAME( TRANQ2,'C' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( LTRQ1 .OR. LSAME( TRANQ1, 'N' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( LTRQ2 .OR. LSAME( TRANQ2, 'N' ) ) ) THEN + INFO = -2 + ELSE IF ( M.LT.0 ) THEN + INFO = -3 + ELSE IF ( N.LT.0 .OR. N.GT.M ) THEN + INFO = -4 + ELSE IF ( K.LT.0 .OR. K.GT.N ) THEN + INFO = -5 + ELSE IF ( ( LTRQ1 .AND. LDQ1.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LTRQ1 .AND. LDQ1.LT.MAX( 1, M ) ) ) THEN + INFO = -7 + ELSE IF ( ( LTRQ2 .AND. LDQ2.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LTRQ2 .AND. LDQ2.LT.MAX( 1, M ) ) ) THEN + INFO = -9 + ELSE IF ( LDWORK.LT.MAX( 1,M + N ) ) THEN + DWORK(1) = DBLE( MAX( 1,M + N ) ) + INFO = -13 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04WU', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Initialize columns K+1:N to columns of the unit matrix. +C + DO 20 J = K + 1, N + DO 10 I = 1, M + Q1(I,J) = ZERO + 10 CONTINUE + Q1(J,J) = ONE + 20 CONTINUE + CALL DLASET( 'All', M, N-K, ZERO, ZERO, Q2(1,K+1), LDQ2 ) +C + IF ( LTRQ1.AND.LTRQ2 ) THEN + DO 50 I = K, 1, -1 +C +C Apply F(I) to Q1(I+1:N,I:M) and Q2(I+1:N,I:M) from the +C right. +C + CALL DCOPY( M-I+1, Q2(I,I), LDQ2, DWORK, 1 ) + IF ( I.LT.N ) THEN + Q1(I,I) = ONE + CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I), + $ Q1(I+1,I), LDQ1, DWORK(M+1) ) + CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I), + $ Q2(I+1,I), LDQ2, DWORK(M+1) ) + END IF + IF ( I.LT.M ) + $ CALL DSCAL( M-I, -TAU(I), Q1(I,I+1), LDQ1 ) + Q1(I,I) = ONE - TAU(I) +C +C Set Q1(I,1:I-1) and Q2(I,1:M) to zero. +C + DO 30 J = 1, I - 1 + Q1(I,J) = ZERO + 30 CONTINUE + DO 40 J = 1, M + Q2(I,J) = ZERO + 40 CONTINUE +C +C Apply G(I) to Q1(I:N,I) and Q2(I:N,I) from the right. +C + CALL DROT( N-I+1, Q1(I,I), 1, Q2(I,I), 1, CS(2*I-1), + $ CS(2*I) ) +C +C Apply H(I) to Q1(I:N,I:M) and Q2(I:N,I:M) from the right. +C + NU = DWORK(1) + DWORK(1) = ONE + CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q1(I,I), + $ LDQ1, DWORK(M+1) ) + CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q2(I,I), + $ LDQ2, DWORK(M+1) ) + 50 CONTINUE + ELSE IF ( LTRQ1 ) THEN + DO 80 I = K, 1, -1 +C +C Apply F(I) to Q1(I+1:N,I:M) from the right and to +C Q2(I:M,I+1:N) from the left. +C + CALL DCOPY( M-I+1, Q2(I,I), 1, DWORK, 1 ) + IF ( I.LT.N ) THEN + Q1(I,I) = ONE + CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I), + $ Q1(I+1,I), LDQ1, DWORK(M+1) ) + CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), LDQ1, TAU(I), + $ Q2(I,I+1), LDQ2, DWORK(M+1) ) + END IF + IF ( I.LT.M ) + $ CALL DSCAL( M-I, -TAU(I), Q1(I,I+1), LDQ1 ) + Q1(I,I) = ONE - TAU(I) +C +C Set Q1(I,1:I-1) and Q2(1:M,I) to zero. +C + DO 60 J = 1, I - 1 + Q1(I,J) = ZERO + 60 CONTINUE + DO 70 J = 1, M + Q2(J,I) = ZERO + 70 CONTINUE +C +C Apply G(I) to Q1(I:N,I) from the right and to Q2(I,I:N) +C from the left. +C + CALL DROT( N-I+1, Q1(I,I), 1, Q2(I,I), LDQ2, CS(2*I-1), + $ CS(2*I) ) +C +C Apply H(I) to Q1(I:N,I:M) from the right and to Q2(I:M,I:N) +C from the left. +C + NU = DWORK(1) + DWORK(1) = ONE + CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q1(I,I), + $ LDQ1, DWORK(M+1) ) + CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q2(I,I), + $ LDQ2, DWORK(M+1) ) + 80 CONTINUE + ELSE IF ( LTRQ2 ) THEN + DO 110 I = K, 1, -1 +C +C Apply F(I) to Q1(I:M,I+1:N) from the left and to +C Q2(I+1:N,I:M) from the right. +C + CALL DCOPY( M-I+1, Q2(I,I), LDQ2, DWORK, 1 ) + IF ( I.LT.N ) THEN + Q1(I,I) = ONE + CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I), + $ Q1(I,I+1), LDQ1, DWORK(M+1) ) + CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), 1, TAU(I), + $ Q2(I+1,I), LDQ2, DWORK(M+1) ) + END IF + IF ( I.LT.M ) + $ CALL DSCAL( M-I, -TAU(I), Q1(I+1,I), 1 ) + Q1(I,I) = ONE - TAU(I) +C +C Set Q1(1:I-1,I) and Q2(I,1:M) to zero. +C + DO 90 J = 1, I - 1 + Q1(J,I) = ZERO + 90 CONTINUE + DO 100 J = 1, M + Q2(I,J) = ZERO + 100 CONTINUE +C +C Apply G(I) to Q1(I,I:N) from the left and to Q2(I:N,I) +C from the right. +C + CALL DROT( N-I+1, Q1(I,I), LDQ1, Q2(I,I), 1, CS(2*I-1), + $ CS(2*I) ) +C +C Apply H(I) to Q1(I:M,I:N) from the left and to Q2(I:N,I:M) +C from the left. +C + NU = DWORK(1) + DWORK(1) = ONE + CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q1(I,I), + $ LDQ1, DWORK(M+1) ) + CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q2(I,I), + $ LDQ2, DWORK(M+1) ) + 110 CONTINUE + ELSE + DO 140 I = K, 1, -1 +C +C Apply F(I) to Q1(I:M,I+1:N) and Q2(I:M,I+1:N) from the left. +C + CALL DCOPY( M-I+1, Q2(I,I), 1, DWORK, 1 ) + IF ( I.LT.N ) THEN + Q1(I,I) = ONE + CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I), + $ Q1(I,I+1), LDQ1, DWORK(M+1) ) + CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I), + $ Q2(I,I+1), LDQ2, DWORK(M+1) ) + END IF + IF ( I.LT.M ) + $ CALL DSCAL( M-I, -TAU(I), Q1(I+1,I), 1 ) + Q1(I,I) = ONE - TAU(I) +C +C Set Q1(1:I-1,I) and Q2(1:M,I) to zero. +C + DO 120 J = 1, I - 1 + Q1(J,I) = ZERO + 120 CONTINUE + DO 130 J = 1, M + Q2(J,I) = ZERO + 130 CONTINUE +C +C Apply G(I) to Q1(I,I:N) and Q2(I,I:N) from the left. +C + CALL DROT( N-I+1, Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), + $ CS(2*I) ) +C +C Apply H(I) to Q1(I:M,I:N) and Q2(I:M,I:N) from the left. +C + NU = DWORK(1) + DWORK(1) = ONE + CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q1(I,I), + $ LDQ1, DWORK(M+1) ) + CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q2(I,I), + $ LDQ2, DWORK(M+1) ) + 140 CONTINUE + END IF + DWORK(1) = DBLE( MAX( 1, M+N ) ) +C *** Last line of MB04WU *** + END diff --git a/mex/sources/libslicot/MB04XD.f b/mex/sources/libslicot/MB04XD.f new file mode 100644 index 000000000..6d417486a --- /dev/null +++ b/mex/sources/libslicot/MB04XD.f @@ -0,0 +1,652 @@ + SUBROUTINE MB04XD( JOBU, JOBV, M, N, RANK, THETA, A, LDA, U, LDU, + $ V, LDV, Q, INUL, TOL, RELTOL, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a basis for the left and/or right singular subspace of +C an M-by-N matrix A corresponding to its smallest singular values. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBU CHARACTER*1 +C Specifies whether to compute the left singular subspace +C as follows: +C = 'N': Do not compute the left singular subspace; +C = 'A': Return the (M - RANK) base vectors of the desired +C left singular subspace in U; +C = 'S': Return the first (min(M,N) - RANK) base vectors +C of the desired left singular subspace in U. +C +C JOBV CHARACTER*1 +C Specifies whether to compute the right singular subspace +C as follows: +C = 'N': Do not compute the right singular subspace; +C = 'A': Return the (N - RANK) base vectors of the desired +C right singular subspace in V; +C = 'S': Return the first (min(M,N) - RANK) base vectors +C of the desired right singular subspace in V. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows in matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns in matrix A. N >= 0. +C +C RANK (input/output) INTEGER +C On entry, if RANK < 0, then the rank of matrix A is +C computed by the routine as the number of singular values +C greater than THETA. +C Otherwise, RANK must specify the rank of matrix A. +C RANK <= min(M,N). +C On exit, if RANK < 0 on entry, then RANK contains the +C computed rank of matrix A. That is, the number of singular +C values of A greater than THETA. +C Otherwise, the user-supplied value of RANK may be changed +C by the routine on exit if the RANK-th and the (RANK+1)-th +C singular values of A are considered to be equal. +C See also the description of parameter TOL below. +C +C THETA (input/output) DOUBLE PRECISION +C On entry, if RANK < 0, then THETA must specify an upper +C bound on the smallest singular values of A corresponding +C to the singular subspace to be computed. THETA >= 0.0. +C Otherwise, THETA must specify an initial estimate (t say) +C for computing an upper bound on the (min(M,N) - RANK) +C smallest singular values of A. If THETA < 0.0, then t is +C computed by the routine. +C On exit, if RANK >= 0 on entry, then THETA contains the +C computed upper bound such that precisely RANK singular +C values of A are greater than THETA + TOL. +C Otherwise, THETA is unchanged. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading M-by-N part of this array must contain the +C matrix A from which the basis of a desired singular +C subspace is to be computed. +C NOTE that this array is destroyed. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= max(1,M). +C +C U (output) DOUBLE PRECISION array, dimension (LDU,*) +C If JOBU = 'A', then the leading M-by-M part of this array +C contains the (M - RANK) M-dimensional base vectors of the +C desired left singular subspace of A corresponding to its +C singular values less than or equal to THETA. These vectors +C are stored in the i-th column(s) of U for which +C INUL(i) = .TRUE., where i = 1,2,...,M. +C +C If JOBU = 'S', then the leading M-by-min(M,N) part of this +C array contains the first (min(M,N) - RANK) M-dimensional +C base vectors of the desired left singular subspace of A +C corresponding to its singular values less than or equal to +C THETA. These vectors are stored in the i-th column(s) of U +C for which INUL(i) = .TRUE., where i = 1,2,..., min(M,N). +C +C Otherwise, U is not referenced (since JOBU = 'N') and can +C be supplied as a dummy array (i.e. set parameter LDU = 1 +C and declare this array to be U(1,1) in the calling +C program). +C +C LDU INTEGER +C The leading dimension of array U. +C LDU >= max(1,M) if JOBU = 'A' or JOBU = 'S', +C LDU >= 1 if JOBU = 'N'. +C +C V (output) DOUBLE PRECISION array, dimension (LDV,*) +C If JOBV = 'A', then the leading N-by-N part of this array +C contains the (N - RANK) N-dimensional base vectors of the +C desired right singular subspace of A corresponding to its +C singular values less than or equal to THETA. These vectors +C are stored in the i-th column(s) of V for which +C INUL(i) = .TRUE., where i = 1,2,...,N. +C +C If JOBV = 'S', then the leading N-by-min(M,N) part of this +C array contains the first (min(M,N) - RANK) N-dimensional +C base vectors of the desired right singular subspace of A +C corresponding to its singular values less than or equal to +C THETA. These vectors are stored in the i-th column(s) of V +C for which INUL(i) = .TRUE., where i = 1,2,...,MIN( M,N). +C +C Otherwise, V is not referenced (since JOBV = 'N') and can +C be supplied as a dummy array (i.e. set parameter LDV = 1 +C and declare this array to be V(1,1) in the calling +C program). +C +C LDV INTEGER +C The leading dimension of array V. +C LDV >= max(1,N) if JOBV = 'A' or JOBV = 'S', +C LDV >= 1 if JOBV = 'N'. +C +C Q (output) DOUBLE PRECISION array, dimension (2*min(M,N)-1) +C This array contains the partially diagonalized bidiagonal +C matrix J computed from A, at the moment that the desired +C singular subspace has been found. Specifically, the +C leading p = min(M,N) entries of Q contain the diagonal +C elements q(1),q(2),...,q(p) and the entries Q(p+1), +C Q(p+2),...,Q(2*p-1) contain the superdiagonal elements +C e(1),e(2),...,e(p-1) of J. +C +C INUL (output) LOGICAL array, dimension (max(M,N)) +C If JOBU <> 'N' or JOBV <> 'N', then the indices of the +C elements of this array with value .TRUE. indicate the +C columns in U and/or V containing the base vectors of the +C desired left and/or right singular subspace of A. They +C also equal the indices of the diagonal elements of the +C bidiagonal submatrices in the array Q, which correspond +C to the computed singular subspaces. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C This parameter defines the multiplicity of singular values +C by considering all singular values within an interval of +C length TOL as coinciding. TOL is used in checking how many +C singular values are less than or equal to THETA. Also in +C computing an appropriate upper bound THETA by a bisection +C method, TOL is used as a stopping criterion defining the +C minimum (absolute) subinterval width. TOL is also taken +C as an absolute tolerance for negligible elements in the +C QR/QL iterations. If the user sets TOL to be less than or +C equal to 0, then the tolerance is taken as specified in +C SLICOT Library routine MB04YD document. +C +C RELTOL DOUBLE PRECISION +C This parameter specifies the minimum relative width of an +C interval. When an interval is narrower than TOL, or than +C RELTOL times the larger (in magnitude) endpoint, then it +C is considered to be sufficiently small and bisection has +C converged. If the user sets RELTOL to be less than +C BASE * EPS, where BASE is machine radix and EPS is machine +C precision (see LAPACK Library routine DLAMCH), then the +C tolerance is taken as BASE * EPS. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = max(1, LDW + max(2*P + max(M,N), LDY)), where +C P = min(M,N); +C LDW = max(2*N, N*(N+1)/2), if JOBU <> 'N' and M large +C enough than N; +C LDW = 0, otherwise; +C LDY = 8*P - 5, if JOBU <> 'N' or JOBV <> 'N'; +C LDY = 6*P - 3, if JOBU = 'N' and JOBV = 'N'. +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: if the rank of matrix A (as specified by the user) +C has been lowered because a singular value of +C multiplicity greater than 1 was found. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the maximum number of QR/QL iteration steps +C (30*MIN(M,N)) has been exceeded. +C +C METHOD +C +C The method used is the Partial Singular Value Decomposition (PSVD) +C approach proposed by Van Huffel, Vandewalle and Haegemans, which +C is an efficient technique (see [1]) for computing the singular +C subspace of a matrix corresponding to its smallest singular +C values. It differs from the classical SVD algorithm [3] at three +C points, which results in high efficiency. Firstly, the Householder +C transformations of the bidiagonalization need only to be applied +C on the base vectors of the desired singular subspaces; secondly, +C the bidiagonal matrix need only be partially diagonalized; and +C thirdly, the convergence rate of the iterative diagonalization can +C be improved by an appropriate choice between QL and QR iterations. +C (Note, however, that LAPACK Library routine DGESVD, for computing +C SVD, also uses either QL and QR iterations.) Depending on the gap, +C the desired numerical accuracy and the dimension of the desired +C singular subspace, the PSVD can be up to three times faster than +C the classical SVD algorithm. +C +C The PSVD algorithm [1-2] for an M-by-N matrix A proceeds as +C follows: +C +C Step 1: Bidiagonalization phase +C ----------------------- +C (a) If M is large enough than N, transform A into upper +C triangular form R. +C +C (b) Transform A (or R) into bidiagonal form: +C +C |q(1) e(1) 0 ... 0 | +C (0) | 0 q(2) e(2) . | +C J = | . . | +C | . e(N-1)| +C | 0 ... q(N) | +C +C if M >= N, or +C +C |q(1) 0 0 ... 0 0 | +C (0) |e(1) q(2) 0 . . | +C J = | . . . | +C | . q(M-1) . | +C | 0 ... e(M-1) q(M)| +C +C if M < N, using Householder transformations. +C In the second case, transform the matrix to the upper bidiagonal +C form by applying Givens rotations. +C +C (c) If U is requested, initialize U with the identity matrix. +C If V is requested, initialize V with the identity matrix. +C +C Step 2: Partial diagonalization phase +C ----------------------------- +C If the upper bound THETA is not given, then compute THETA such +C that precisely (min(M,N) - RANK) singular values of the bidiagonal +C matrix are less than or equal to THETA, using a bisection method +C [4]. Diagonalize the given bidiagonal matrix J partially, using +C either QR iterations (if the upper left diagonal element of the +C considered bidiagonal submatrix is larger than the lower right +C diagonal element) or QL iterations, such that J is split into +C unreduced bidiagonal submatrices whose singular values are either +C all larger than THETA or all less than or equal to THETA. +C Accumulate the Givens rotations in U and/or V (if desired). +C +C Step 3: Back transformation phase +C ------------------------- +C (a) Apply the Householder transformations of Step 1(b) onto the +C columns of U and/or V associated with the bidiagonal +C submatrices with all singular values less than or equal to +C THETA (if U and/or V is desired). +C +C (b) If M is large enough than N, and U is desired, then apply the +C Householder transformations of Step 1(a) onto each computed +C column of U in Step 3(a). +C +C REFERENCES +C +C [1] Van Huffel, S., Vandewalle, J. and Haegemans, A. +C An efficient and reliable algorithm for computing the singular +C subspace of a matrix associated with its smallest singular +C values. +C J. Comput. and Appl. Math., 19, pp. 313-330, 1987. +C +C [2] Van Huffel, S. +C Analysis of the total least squares problem and its use in +C parameter estimation. +C Doctoral dissertation, Dept. of Electr. Eng., Katholieke +C Universiteit Leuven, Belgium, June 1987. +C +C [3] Chan, T.F. +C An improved algorithm for computing the singular value +C decomposition. +C ACM TOMS, 8, pp. 72-83, 1982. +C +C [4] Van Huffel, S. and Vandewalle, J. +C The partial total least squares algorithm. +C J. Comput. and Appl. Math., 21, pp. 333-341, 1988. +C +C NUMERICAL ASPECTS +C +C Using the PSVD a large reduction in computation time can be +C gained in total least squares applications (cf [2 - 4]), in the +C computation of the null space of a matrix and in solving +C (non)homogeneous linear equations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. +C Supersedes Release 2.0 routine MB04PD by S. Van Huffel, Katholieke +C University Leuven, Belgium. +C +C REVISIONS +C +C July 10, 1997. +C +C KEYWORDS +C +C Bidiagonalization, singular subspace, singular value +C decomposition, singular values. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBU, JOBV + INTEGER INFO, IWARN, LDA, LDU, LDV, LDWORK, M, N, RANK + DOUBLE PRECISION RELTOL, THETA, TOL +C .. Array Arguments .. + LOGICAL INUL(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), Q(*), U(LDU,*), V(LDV,*) +C .. Local Scalars .. + CHARACTER*1 JOBUY, JOBVY + LOGICAL ALL, LJOBUA, LJOBUS, LJOBVA, LJOBVS, QR, WANTU, + $ WANTV + INTEGER I, IHOUSH, IJ, ITAU, ITAUP, ITAUQ, J, JU, JV, + $ JWORK, K, LDW, LDY, MA, P, PP1, WRKOPT + DOUBLE PRECISION CS, SN, TEMP +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEBRD, DGEQRF, DLARTG, DLASET, DLASR, + $ MB04XY, MB04YD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + IWARN = 0 + INFO = 0 + P = MIN( M, N ) + K = MAX( M, N ) +C +C Determine whether U and/or V are/is to be computed. +C + LJOBUA = LSAME( JOBU, 'A' ) + LJOBUS = LSAME( JOBU, 'S' ) + LJOBVA = LSAME( JOBV, 'A' ) + LJOBVS = LSAME( JOBV, 'S' ) + WANTU = LJOBUA.OR.LJOBUS + WANTV = LJOBVA.OR.LJOBVS + ALL = ( LJOBUA .AND. M.GT.N ) .OR. ( LJOBVA .AND. M.LT.N ) + QR = M.GE.ILAENV( 6, 'DGESVD', 'N' // 'N', M, N, 0, 0 ) + IF ( QR.AND.WANTU ) THEN + LDW = MAX( 2*N, N*( N + 1 )/2 ) + ELSE + LDW = 0 + END IF + IF ( WANTU.OR.WANTV ) THEN + LDY = 8*P - 5 + ELSE + LDY = 6*P - 3 + END IF +C +C Test the input scalar arguments. +C + IF( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.WANTV .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( RANK.GT.P ) THEN + INFO = -5 + ELSE IF( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( ( .NOT.WANTU .AND. LDU.LT.1 ) .OR. + $ ( WANTU .AND. LDU.LT.MAX( 1, M ) ) ) THEN + INFO = -10 + ELSE IF( ( .NOT.WANTV .AND. LDV.LT.1 ) .OR. + $ ( WANTV .AND. LDV.LT.MAX( 1, N ) ) ) THEN + INFO = -12 + ELSE IF( LDWORK.LT.MAX( 1, LDW + MAX( 2*P + K, LDY ) ) ) THEN + INFO = -18 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB04XD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( P.EQ.0 ) THEN + IF ( RANK.GE.0 ) + $ THETA = ZERO + RANK = 0 + RETURN + END IF +C +C Initializations. +C + PP1 = P + 1 +C + IF ( ALL .AND. ( .NOT.QR ) ) THEN +C + DO 20 I = 1, P + INUL(I) = .FALSE. + 20 CONTINUE +C + DO 40 I = PP1, K + INUL(I) = .TRUE. + 40 CONTINUE +C + ELSE +C + DO 60 I = 1, K + INUL(I) = .FALSE. + 60 CONTINUE +C + END IF +C +C Step 1: Bidiagonalization phase +C ----------------------- +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF ( QR ) THEN +C +C 1.a.: M is large enough than N; transform A into upper +C triangular form R by Householder transformations. +C +C Workspace: need 2*N; prefer N + N*NB. +C + ITAU = 1 + JWORK = ITAU + N + CALL DGEQRF( M, N, A, LDA, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = INT( DWORK(JWORK) )+JWORK-1 +C +C If (WANTU), store information on the Householder +C transformations performed on the columns of A in N*(N+1)/2 +C extra storage locations DWORK(K), for K = 1,2,...,N*(N+1)/2. +C (The first N locations store the scalar factors of Householder +C transformations.) +C +C Workspace: LDW = max(2*N, N*(N+1)/2). +C + IF ( WANTU ) THEN + IHOUSH = JWORK + K = IHOUSH + I = N + ELSE + K = 1 + END IF +C + DO 100 J = 1, N - 1 + IF ( WANTU ) THEN + I = I - 1 + CALL DCOPY( I, A(J+1,J), 1, DWORK(K), 1 ) + K = K + I + END IF +C + DO 80 IJ = J + 1, N + A(IJ,J) = ZERO + 80 CONTINUE +C + 100 CONTINUE +C + MA = N + WRKOPT = MAX( WRKOPT, K ) + ELSE +C +C Workspace: LDW = 0. +C + K = 1 + MA = M + WRKOPT = 1 + END IF +C +C 1.b.: Transform A (or R) into bidiagonal form Q using Householder +C transformations. +C +C Workspace: need LDW + 2*min(M,N) + max(M,N); +C prefer LDW + 2*min(M,N) + (M+N)*NB. +C + ITAUQ = K + ITAUP = ITAUQ + P + JWORK = ITAUP + P + CALL DGEBRD( MA, N, A, LDA, Q, Q(PP1), DWORK(ITAUQ), + $ DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C 1.c.: Initialize U (if WANTU) and V (if WANTV) with the identity +C matrix. +C + IF ( WANTU ) THEN + IF ( ALL ) THEN + JU = M + ELSE + JU = P + END IF + CALL DLASET( 'Full', M, JU, ZERO, ONE, U, LDU ) + JOBUY = 'U' + ELSE + JOBUY = 'N' + END IF + IF ( WANTV ) THEN + IF ( ALL ) THEN + JV = N + ELSE + JV = P + END IF + CALL DLASET( 'Full', N, JV, ZERO, ONE, V, LDV ) + JOBVY = 'U' + ELSE + JOBVY = 'N' + END IF +C +C If the matrix is lower bidiagonal, rotate to be upper bidiagonal +C by applying Givens rotations on the left. +C + IF ( M.LT.N ) THEN +C + DO 120 I = 1, P - 1 + CALL DLARTG( Q(I), Q(P+I), CS, SN, TEMP ) + Q(I) = TEMP + Q(P+I) = SN*Q(I+1) + Q(I+1) = CS*Q(I+1) + IF ( WANTU ) THEN +C +C Workspace: LDW + 4*min(M,N) - 2. +C + DWORK(JWORK+I-1) = CS + DWORK(JWORK+P+I-2) = SN + END IF + 120 CONTINUE +C +C Update left singular vectors if desired. +C + IF( WANTU ) + $ CALL DLASR( 'Right', 'Variable pivot', 'Forward', M, JU, + $ DWORK(JWORK), DWORK(JWORK+P-1), U, LDU ) +C + END IF +C +C Step 2: Partial diagonalization phase. +C ----------------------------- +C Diagonalize the bidiagonal Q partially until convergence +C to the desired left and/or right singular subspace. +C +C Workspace: LDW + 8*min(M,N) - 5, if WANTU or WANTV; +C Workspace: LDW + 6*min(M,N) - 3, if JOBU = JOBV = 'N'. +C + CALL MB04YD( JOBUY, JOBVY, M, N, RANK, THETA, Q, Q(PP1), U, LDU, + $ V, LDV, INUL, TOL, RELTOL, DWORK(JWORK), + $ LDWORK-JWORK+1, IWARN, INFO ) + IF ( WANTU.OR.WANTV ) THEN + WRKOPT = MAX( WRKOPT, JWORK - 6 + 8*P ) + ELSE + WRKOPT = MAX( WRKOPT, JWORK - 4 + 6*P ) + END IF + IF ( INFO.GT.0 ) + $ RETURN +C +C Step 3: Back transformation phase. +C ------------------------- +C 3.a.: Apply the Householder transformations of the bidiagonaliza- +C tion onto the base vectors associated with the desired +C bidiagonal submatrices. +C +C Workspace: LDW + 2*min(M,N). +C + CALL MB04XY( JOBU, JOBV, MA, N, A, LDA, DWORK(ITAUQ), + $ DWORK(ITAUP), U, LDU, V, LDV, INUL, INFO ) +C +C 3.b.: If A was reduced to upper triangular form R and JOBU = 'A' +C or JOBU = 'S' apply the Householder transformations of the +C triangularization of A onto the desired base vectors. +C + IF ( QR.AND.WANTU ) THEN + IF ( ALL ) THEN +C + DO 140 I = PP1, M + INUL(I) = .TRUE. + 140 CONTINUE +C + END IF + K = IHOUSH + I = N +C + DO 160 J = 1, N - 1 + I = I - 1 + CALL DCOPY( I, DWORK(K), 1, A(J+1,J), 1 ) + K = K + I + 160 CONTINUE +C +C Workspace: MIN(M,N) + 1. +C + JWORK = PP1 + CALL MB04XY( JOBU, 'No V', M, N, A, LDA, DWORK(ITAU), + $ DWORK(ITAU), U, LDU, DWORK(JWORK), 1, INUL, INFO ) + WRKOPT = MAX( WRKOPT, PP1 ) + END IF +C +C Set the optimal workspace. +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of MB04XD *** + END diff --git a/mex/sources/libslicot/MB04XY.f b/mex/sources/libslicot/MB04XY.f new file mode 100644 index 000000000..02e8e7e22 --- /dev/null +++ b/mex/sources/libslicot/MB04XY.f @@ -0,0 +1,274 @@ + SUBROUTINE MB04XY( JOBU, JOBV, M, N, X, LDX, TAUP, TAUQ, U, + $ LDU, V, LDV, INUL, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply the Householder transformations Pj stored in factored +C form into the columns of the array X, to the desired columns of +C the matrix U by premultiplication, and/or the Householder +C transformations Qj stored in factored form into the rows of the +C array X, to the desired columns of the matrix V by +C premultiplication. The Householder transformations Pj and Qj +C are stored as produced by LAPACK Library routine DGEBRD. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBU CHARACTER*1 +C Specifies whether to transform the columns in U as +C follows: +C = 'N': Do not transform the columns in U; +C = 'A': Transform the columns in U (U has M columns); +C = 'S': Transform the columns in U (U has min(M,N) +C columns). +C +C JOBV CHARACTER*1 +C Specifies whether to transform the columns in V as +C follows: +C = 'N': Do not transform the columns in V; +C = 'A': Transform the columns in V (V has N columns); +C = 'S': Transform the columns in V (V has min(M,N) +C columns). +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix X. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix X. N >= 0. +C +C X (input) DOUBLE PRECISION array, dimension (LDX,N) +C The leading M-by-N part contains in the columns of its +C lower triangle the Householder transformations Pj, and +C in the rows of its upper triangle the Householder +C transformations Qj in factored form. +C X is modified by the routine but restored on exit. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= MAX(1,M). +C +C TAUP (input) DOUBLE PRECISION array, dimension (MIN(M,N)) +C The scalar factors of the Householder transformations Pj. +C +C TAUQ (input) DOUBLE PRECISION array, dimension (MIN(M,N)) +C The scalar factors of the Householder transformations Qj. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) +C On entry, U contains the M-by-M (if JOBU = 'A') or +C M-by-min(M,N) (if JOBU = 'S') matrix U. +C On exit, the Householder transformations Pj have been +C applied to each column i of U corresponding to a parameter +C INUL(i) = .TRUE. +C NOTE that U is not referenced if JOBU = 'N'. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= MAX(1,M), if JOBU = 'A' or JOBU = 'S'; +C LDU >= 1, if JOBU = 'N'. +C +C V (input/output) DOUBLE PRECISION array, dimension (LDV,*) +C On entry, V contains the N-by-N (if JOBV = 'A') or +C N-by-min(M,N) (if JOBV = 'S') matrix V. +C On exit, the Householder transformations Qj have been +C applied to each column i of V corresponding to a parameter +C INUL(i) = .TRUE. +C NOTE that V is not referenced if JOBV = 'N'. +C +C LDV INTEGER +C The leading dimension of the array V. +C LDV >= MAX(1,M), if JOBV = 'A' or JOBV = 'S'; +C LDV >= 1, if JOBV = 'N'. +C +C INUL (input) LOGICAL array, dimension (MAX(M,N)) +C INUL(i) = .TRUE. if the i-th column of U and/or V is to be +C transformed, and INUL(i) = .FALSE., otherwise. +C (1 <= i <= MAX(M,N)). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The Householder transformations Pj or Qj are applied to the +C columns of U or V indexed by I for which INUL(I) = .TRUE.. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. +C Supersedes Release 2.0 routine MB04PZ by S. Van Huffel, Katholieke +C University Leuven, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Bidiagonalization, orthogonal transformation, singular subspace, +C singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBU, JOBV + INTEGER INFO, LDU, LDV, LDX, M, N +C .. Array Arguments .. + LOGICAL INUL(*) + DOUBLE PRECISION TAUP(*), TAUQ(*), U(LDU,*), V(LDV,*), + $ X(LDX,*) +C .. Local Scalars .. + LOGICAL LJOBUA, LJOBUS, LJOBVA, LJOBVS, WANTU, WANTV + INTEGER I, IM, IOFF, L, NCOL, P + DOUBLE PRECISION FIRST +C .. Local Arrays .. + DOUBLE PRECISION DWORK(1) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARF, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MIN, MAX +C .. Executable Statements .. +C + INFO = 0 + LJOBUA = LSAME( JOBU, 'A' ) + LJOBUS = LSAME( JOBU, 'S' ) + LJOBVA = LSAME( JOBV, 'A' ) + LJOBVS = LSAME( JOBV, 'S' ) + WANTU = LJOBUA.OR.LJOBUS + WANTV = LJOBVA.OR.LJOBVS +C +C Test the input scalar arguments. +C + IF( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.WANTV .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDX.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( ( WANTU.AND.LDU.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.WANTU.AND.LDU.LT.1 ) ) THEN + INFO = -10 + ELSE IF( ( WANTV.AND.LDV.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.WANTV.AND.LDV.LT.1 ) ) THEN + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return +C + CALL XERBLA( 'MB04XY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + P = MIN( M, N ) + IF ( P.EQ.0 ) + $ RETURN +C + IF ( M.LT.N ) THEN + IOFF = 1 + ELSE + IOFF = 0 + END IF +C +C Apply the Householder transformations Pj onto the desired +C columns of U. +C + IM = MIN( M-1, N ) + IF ( WANTU .AND. ( IM.GT.0 ) ) THEN + IF ( LJOBUA ) THEN + NCOL = M + ELSE + NCOL = P + END IF +C + DO 40 I = 1, NCOL + IF ( INUL(I) ) THEN +C + DO 20 L = IM, 1, -1 + IF ( TAUP(L).NE.ZERO ) THEN + FIRST = X(L+IOFF,L) + X(L+IOFF,L) = ONE + CALL DLARF( 'Left', M-L+1-IOFF, 1, X(L+IOFF,L), 1, + $ TAUP(L), U(L+IOFF,I), LDU, DWORK ) + X(L+IOFF,L) = FIRST + END IF + 20 CONTINUE +C + END IF + 40 CONTINUE +C + END IF +C +C Apply the Householder transformations Qj onto the desired columns +C of V. +C + IM = MIN( N-1, M ) + IF ( WANTV .AND. ( IM.GT.0 ) ) THEN + IF ( LJOBVA ) THEN + NCOL = N + ELSE + NCOL = P + END IF +C + DO 80 I = 1, NCOL + IF ( INUL(I) ) THEN +C + DO 60 L = IM, 1, -1 + IF ( TAUQ(L).NE.ZERO ) THEN + FIRST = X(L,L+1-IOFF) + X(L,L+1-IOFF) = ONE + CALL DLARF( 'Left', N-L+IOFF, 1, X(L,L+1-IOFF), + $ LDX, TAUQ(L), V(L+1-IOFF,I), LDV, + $ DWORK ) + X(L,L+1-IOFF) = FIRST + END IF + 60 CONTINUE +C + END IF + 80 CONTINUE +C + END IF +C + RETURN +C *** Last line of MB04XY *** + END diff --git a/mex/sources/libslicot/MB04YD.f b/mex/sources/libslicot/MB04YD.f new file mode 100644 index 000000000..90ef68b27 --- /dev/null +++ b/mex/sources/libslicot/MB04YD.f @@ -0,0 +1,623 @@ + SUBROUTINE MB04YD( JOBU, JOBV, M, N, RANK, THETA, Q, E, U, LDU, V, + $ LDV, INUL, TOL, RELTOL, DWORK, LDWORK, IWARN, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To partially diagonalize the bidiagonal matrix +C +C |q(1) e(1) 0 ... 0 | +C | 0 q(2) e(2) . | +C J = | . . | (1) +C | . e(MIN(M,N)-1)| +C | 0 ... ... q(MIN(M,N)) | +C +C using QR or QL iterations in such a way that J is split into +C unreduced bidiagonal submatrices whose singular values are either +C all larger than a given bound or are all smaller than (or equal +C to) this bound. The left- and right-hand Givens rotations +C performed on J (corresponding to each QR or QL iteration step) may +C be optionally accumulated in the arrays U and V. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBU CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix U the left-hand Givens rotations, as follows: +C = 'N': Do not form U; +C = 'I': U is initialized to the M-by-MIN(M,N) submatrix of +C the unit matrix and the left-hand Givens rotations +C are accumulated in U; +C = 'U': The given matrix U is updated by the left-hand +C Givens rotations used in the calculation. +C +C JOBV CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix V the right-hand Givens rotations, as follows: +C = 'N': Do not form V; +C = 'I': V is initialized to the N-by-MIN(M,N) submatrix of +C the unit matrix and the right-hand Givens +C rotations are accumulated in V; +C = 'U': The given matrix V is updated by the right-hand +C Givens rotations used in the calculation. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows in matrix U. M >= 0. +C +C N (input) INTEGER +C The number of rows in matrix V. N >= 0. +C +C RANK (input/output) INTEGER +C On entry, if RANK < 0, then the rank of matrix J is +C computed by the routine as the number of singular values +C larger than THETA. +C Otherwise, RANK must specify the rank of matrix J. +C RANK <= MIN(M,N). +C On exit, if RANK < 0 on entry, then RANK contains the +C computed rank of J. That is, the number of singular +C values of J larger than THETA. +C Otherwise, the user-supplied value of RANK may be +C changed by the routine on exit if the RANK-th and the +C (RANK+1)-th singular values of J are considered to be +C equal. See also the parameter TOL. +C +C THETA (input/output) DOUBLE PRECISION +C On entry, if RANK < 0, then THETA must specify an upper +C bound on the smallest singular values of J. THETA >= 0.0. +C Otherwise, THETA must specify an initial estimate (t say) +C for computing an upper bound such that precisely RANK +C singular values are greater than this bound. +C If THETA < 0.0, then t is computed by the routine. +C On exit, if RANK >= 0 on entry, then THETA contains the +C computed upper bound such that precisely RANK singular +C values of J are greater than THETA + TOL. +C Otherwise, THETA is unchanged. +C +C Q (input/output) DOUBLE PRECISION array, dimension +C (MIN(M,N)) +C On entry, this array must contain the diagonal elements +C q(1),q(2),...,q(MIN(M,N)) of the bidiagonal matrix J. That +C is, Q(i) = J(i,i) for i = 1,2,...,MIN(M,N). +C On exit, this array contains the leading diagonal of the +C transformed bidiagonal matrix J. +C +C E (input/output) DOUBLE PRECISION array, dimension +C (MIN(M,N)-1) +C On entry, this array must contain the superdiagonal +C elements e(1),e(2),...,e(MIN(M,N)-1) of the bidiagonal +C matrix J. That is, E(k) = J(k,k+1) for k = 1,2,..., +C MIN(M,N)-1. +C On exit, this array contains the superdiagonal of the +C transformed bidiagonal matrix J. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) +C On entry, if JOBU = 'U', the leading M-by-MIN(M,N) part +C of this array must contain a left transformation matrix +C applied to the original matrix of the problem, and +C on exit, the leading M-by-MIN(M,N) part of this array +C contains the product of the input matrix U and the +C left-hand Givens rotations. +C On exit, if JOBU = 'I', then the leading M-by-MIN(M,N) +C part of this array contains the matrix of accumulated +C left-hand Givens rotations used. +C If JOBU = 'N', the array U is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDU = 1 and +C declare this array to be U(1,1) in the calling program). +C +C LDU INTEGER +C The leading dimension of array U. If JOBU = 'U' or +C JOBU = 'I', LDU >= MAX(1,M); if JOBU = 'N', LDU >= 1. +C +C V (input/output) DOUBLE PRECISION array, dimension (LDV,*) +C On entry, if JOBV = 'U', the leading N-by-MIN(M,N) part +C of this array must contain a right transformation matrix +C applied to the original matrix of the problem, and +C on exit, the leading N-by-MIN(M,N) part of this array +C contains the product of the input matrix V and the +C right-hand Givens rotations. +C On exit, if JOBV = 'I', then the leading N-by-MIN(M,N) +C part of this array contains the matrix of accumulated +C right-hand Givens rotations used. +C If JOBV = 'N', the array V is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDV = 1 and +C declare this array to be V(1,1) in the calling program). +C +C LDV INTEGER +C The leading dimension of array V. If JOBV = 'U' or +C JOBV = 'I', LDV >= MAX(1,N); if JOBV = 'N', LDV >= 1. +C +C INUL (input/output) LOGICAL array, dimension (MIN(M,N)) +C On entry, the leading MIN(M,N) elements of this array must +C be set to .FALSE. unless the i-th columns of U (if JOBU = +C 'U') and V (if JOBV = 'U') already contain a computed base +C vector of the desired singular subspace of the original +C matrix, in which case INUL(i) must be set to .TRUE. +C for 1 <= i <= MIN(M,N). +C On exit, the indices of the elements of this array with +C value .TRUE. indicate the indices of the diagonal entries +C of J which belong to those bidiagonal submatrices whose +C singular values are all less than or equal to THETA. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C This parameter defines the multiplicity of singular values +C by considering all singular values within an interval of +C length TOL as coinciding. TOL is used in checking how many +C singular values are less than or equal to THETA. Also in +C computing an appropriate upper bound THETA by a bisection +C method, TOL is used as a stopping criterion defining the +C minimum (absolute) subinterval width. TOL is also taken +C as an absolute tolerance for negligible elements in the +C QR/QL iterations. If the user sets TOL to be less than or +C equal to 0, then the tolerance is taken as +C EPS * MAX(ABS(Q(i)), ABS(E(k))), where EPS is the +C machine precision (see LAPACK Library routine DLAMCH), +C i = 1,2,...,MIN(M,N) and k = 1,2,...,MIN(M,N)-1. +C +C RELTOL DOUBLE PRECISION +C This parameter specifies the minimum relative width of an +C interval. When an interval is narrower than TOL, or than +C RELTOL times the larger (in magnitude) endpoint, then it +C is considered to be sufficiently small and bisection has +C converged. If the user sets RELTOL to be less than +C BASE * EPS, where BASE is machine radix and EPS is machine +C precision (see LAPACK Library routine DLAMCH), then the +C tolerance is taken as BASE * EPS. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,6*MIN(M,N)-5), if JOBU = 'I' or 'U', or +C JOBV = 'I' or 'U'; +C LDWORK >= MAX(1,4*MIN(M,N)-3), if JOBU = 'N' and +C JOBV = 'N'. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: if the rank of the bidiagonal matrix J (as specified +C by the user) has been lowered because a singular +C value of multiplicity larger than 1 was found. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; this includes values like RANK > MIN(M,N), or +C THETA < 0.0 and RANK < 0; +C = 1: if the maximum number of QR/QL iteration steps +C (30*MIN(M,N)) has been exceeded. +C +C METHOD +C +C If the upper bound THETA is not specified by the user, then it is +C computed by the routine (using a bisection method) such that +C precisely (MIN(M,N) - RANK) singular values of J are less than or +C equal to THETA + TOL. +C +C The method used by the routine (see [1]) then proceeds as follows. +C +C The unreduced bidiagonal submatrices of J(j), where J(j) is the +C transformed bidiagonal matrix after the j-th iteration step, are +C classified into the following three classes: +C +C - C1 contains the bidiagonal submatrices with all singular values +C > THETA, +C - C2 contains the bidiagonal submatrices with all singular values +C <= THETA and +C - C3 contains the bidiagonal submatrices with singular values +C > THETA and also singular values <= THETA. +C +C If C3 is empty, then the partial diagonalization is complete, and +C RANK is the sum of the dimensions of the bidiagonal submatrices of +C C1. +C Otherwise, QR or QL iterations are performed on each bidiagonal +C submatrix of C3, until this bidiagonal submatrix has been split +C into two bidiagonal submatrices. These two submatrices are then +C classified and the iterations are restarted. +C If the upper left diagonal element of the bidiagonal submatrix is +C larger than its lower right diagonal element, then QR iterations +C are performed, else QL iterations are used. The shift is taken as +C the smallest diagonal element of the bidiagonal submatrix (in +C magnitude) unless its value exceeds THETA, in which case it is +C taken as zero. +C +C REFERENCES +C +C [1] Van Huffel, S., Vandewalle, J. and Haegemans, A. +C An efficient and reliable algorithm for computing the +C singular subspace of a matrix associated with its smallest +C singular values. +C J. Comput. and Appl. Math., 19, pp. 313-330, 1987. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C To avoid overflow, matrix J is scaled so that its largest element +C is no greater than overflow**(1/2) * underflow**(1/4) in absolute +C value (and not much smaller than that, for maximal accuracy). +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. +C Supersedes Release 2.0 routine MB04QD by S. Van Huffel, Katholieke +C University Leuven, Belgium. +C +C REVISIONS +C +C July 10, 1997. V. Sima. +C November 25, 1997. V. Sima: Setting INUL(K) = .TRUE. when handling +C 2-by-2 submatrix. +C +C KEYWORDS +C +C Bidiagonal matrix, orthogonal transformation, singular values. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TEN, HNDRD + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0, + $ HNDRD = 100.0D0 ) + DOUBLE PRECISION MEIGTH + PARAMETER ( MEIGTH = -0.125D0 ) + INTEGER MAXITR + PARAMETER ( MAXITR = 30 ) +C .. Scalar Arguments .. + CHARACTER JOBU, JOBV + INTEGER INFO, IWARN, LDU, LDV, LDWORK, M, N, RANK + DOUBLE PRECISION RELTOL, THETA, TOL +C .. Array Arguments .. + LOGICAL INUL(*) + DOUBLE PRECISION DWORK(*), E(*), Q(*), U(LDU,*), V(LDV,*) +C .. Local Scalars .. + LOGICAL LJOBUA, LJOBUI, LJOBVA, LJOBVI, NOC12, QRIT + INTEGER I, I1, IASCL, INFO1, ITER, J, K, MAXIT, NUMEIG, + $ OLDI, OLDK, P, R + DOUBLE PRECISION COSL, COSR, EPS, PIVMIN, RMAX, RMIN, SAFEMN, + $ SHIFT, SIGMA, SIGMN, SIGMX, SINL, SINR, SMAX, + $ SMLNUM, THETAC, THRESH, TOLABS, TOLREL, X +C .. External Functions .. + LOGICAL LSAME + INTEGER MB03ND + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME, MB03ND +C .. External Subroutines .. + EXTERNAL DLASET, DLASV2, DROT, DSCAL, MB02NY, MB03MD, + $ MB04YW, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +C .. Executable Statements .. +C + P = MIN( M, N ) + INFO = 0 + IWARN = 0 + LJOBUI = LSAME( JOBU, 'I' ) + LJOBVI = LSAME( JOBV, 'I' ) + LJOBUA = LJOBUI.OR.LSAME( JOBU, 'U' ) + LJOBVA = LJOBVI.OR.LSAME( JOBV, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBUA .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LJOBVA .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( RANK.GT.P ) THEN + INFO = -5 + ELSE IF( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN + INFO = -6 + ELSE IF( .NOT.LJOBUA .AND. LDU.LT.1 .OR. + $ LJOBUA .AND. LDU.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( .NOT.LJOBVA .AND. LDV.LT.1 .OR. + $ LJOBVA .AND. LDV.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( ( ( LJOBUA.OR.LJOBVA ) .AND. LDWORK.LT.MAX( 1, 6*P-5 ) ) + $ .OR.(.NOT.( LJOBUA.OR.LJOBVA ) .AND. LDWORK.LT.MAX( 1, 4*P-3 ) ) + $ ) THEN + INFO = -17 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB04YD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( P.EQ.0 ) THEN + IF ( RANK.GE.0 ) + $ THETA = ZERO + RANK = 0 + RETURN + END IF +C +C Set tolerances and machine parameters. +C + TOLABS = TOL + TOLREL = RELTOL + SMAX = ABS( Q(P) ) +C + DO 20 J = 1, P - 1 + SMAX = MAX( SMAX, ABS( Q(J) ), ABS( E(J) ) ) + 20 CONTINUE +C + SAFEMN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Epsilon' ) + IF ( TOLABS.LE.ZERO ) TOLABS = EPS*SMAX + X = DLAMCH( 'Base' )*EPS + IF ( TOLREL.LE.X ) TOLREL = X + THRESH = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )*EPS + SMLNUM = SAFEMN / EPS + RMIN = SQRT( SMLNUM ) + RMAX = MIN( ONE / RMIN, ONE / SQRT( SQRT( SAFEMN ) ) ) + THETAC = THETA +C +C Scale the matrix to allowable range, if necessary, and set PIVMIN, +C using the squares of Q and E (saved in DWORK). +C + IASCL = 0 + IF( SMAX.GT.ZERO .AND. SMAX.LT.RMIN ) THEN + IASCL = 1 + SIGMA = RMIN / SMAX + ELSE IF( SMAX.GT.RMAX ) THEN + IASCL = 1 + SIGMA = RMAX / SMAX + END IF + IF( IASCL.EQ.1 ) THEN + CALL DSCAL( P, SIGMA, Q, 1 ) + CALL DSCAL( P-1, SIGMA, E, 1 ) + THETAC = SIGMA*THETA + TOLABS = SIGMA*TOLABS + END IF +C + PIVMIN = Q(P)**2 + DWORK(P) = PIVMIN +C + DO 40 J = 1, P - 1 + DWORK(J) = Q(J)**2 + DWORK(P+J) = E(J)**2 + PIVMIN = MAX( PIVMIN, DWORK(J), DWORK(P+J) ) + 40 CONTINUE +C + PIVMIN = MAX( PIVMIN*SAFEMN, SAFEMN ) +C +C Initialize U and/or V to the identity matrix, if needed. +C + IF ( LJOBUI ) + $ CALL DLASET( 'Full', M, P, ZERO, ONE, U, LDU ) + IF ( LJOBVI ) + $ CALL DLASET( 'Full', N, P, ZERO, ONE, V, LDV ) +C +C Estimate THETA (if not fixed by the user), and set R. +C + IF ( RANK.GE.0 ) THEN + J = P - RANK + CALL MB03MD( P, J, THETAC, Q, E, DWORK(1), DWORK(P+1), PIVMIN, + $ TOLABS, TOLREL, IWARN, INFO1 ) + THETA = THETAC + IF ( IASCL.EQ.1 ) THETA = THETA / SIGMA + IF ( J.LE.0 ) + $ RETURN + R = P - J + ELSE + R = P - MB03ND( P, THETAC, DWORK, DWORK(P+1), PIVMIN, INFO1 ) + END IF +C + RANK = P +C + DO 60 I = 1, P + IF ( INUL(I) ) RANK = RANK - 1 + 60 CONTINUE +C +C From now on K is the smallest known index such that the elements +C of the bidiagonal matrix J with indices larger than K belong to C1 +C or C2. +C RANK = P - SUM(dimensions of known bidiagonal matrices of C2). +C + K = P + OLDI = -1 + OLDK = -1 + ITER = 0 + MAXIT = MAXITR*P +C WHILE ( C3 NOT EMPTY ) DO + 80 IF ( RANK.GT.R .AND. K.GT.0 ) THEN +C WHILE ( K.GT.0 .AND. INUL(K) ) DO +C +C Search for the rightmost index of a bidiagonal submatrix, +C not yet classified. +C + 100 IF ( K.GT.0 ) THEN + IF ( INUL(K) ) THEN + K = K - 1 + GO TO 100 + END IF + END IF +C END WHILE 100 +C + IF ( K.EQ.0 ) + $ RETURN +C + NOC12 = .TRUE. +C WHILE ((ITER < MAXIT).AND.(No bidiagonal matrix of C1 or +C C2 found)) DO + 120 IF ( ( ITER.LT.MAXIT ) .AND. NOC12 ) THEN +C +C Search for negligible Q(I) or E(I-1) (for I > 1) and find +C the shift. +C + I = K + X = ABS( Q(I) ) + SHIFT = X +C WHILE ABS( Q(I) ) > TOLABS .AND. ABS( E(I-1) ) > TOLABS ) DO + 140 IF ( I.GT.1 ) THEN + IF ( ( X.GT.TOLABS ).AND.( ABS( E(I-1) ).GT.TOLABS ) ) + $ THEN + I = I - 1 + X = ABS( Q(I) ) + IF ( X.LT.SHIFT ) SHIFT = X + GO TO 140 + END IF + END IF +C END WHILE 140 +C +C Classify the bidiagonal submatrix (of order J) found. +C + J = K - I + 1 + IF ( ( X.LE.TOLABS ) .OR. ( K.EQ.I ) ) THEN + NOC12 = .FALSE. + ELSE + NUMEIG = MB03ND( J, THETAC, DWORK(I), DWORK(P+I), PIVMIN, + $ INFO1 ) + IF ( NUMEIG.GE.J .OR. NUMEIG.LE.0 ) NOC12 = .FALSE. + END IF + IF ( NOC12 ) THEN + IF ( J.EQ.2 ) THEN +C +C Handle separately the 2-by-2 submatrix. +C + CALL DLASV2( Q(I), E(I), Q(K), SIGMN, SIGMX, SINR, + $ COSR, SINL, COSL ) + Q(I) = SIGMX + Q(K) = SIGMN + E(I) = ZERO + RANK = RANK - 1 + INUL(K) = .TRUE. + NOC12 = .FALSE. +C +C Update U and/or V, if needed. +C + IF( LJOBUA ) + $ CALL DROT( M, U(1,I), 1, U(1,K), 1, COSL, SINL ) + IF( LJOBVA ) + $ CALL DROT( N, V(1,I), 1, V(1,K), 1, COSR, SINR ) + ELSE +C +C If working on new submatrix, choose QR or +C QL iteration. +C + IF ( I.NE.OLDI .OR. K.NE.OLDK ) + $ QRIT = ABS( Q(I) ).GE.ABS( Q(K) ) + OLDI = I + IF ( QRIT ) THEN + IF ( ABS( E(K-1) ).LE.THRESH*ABS( Q(K) ) ) + $ E(K-1) = ZERO + ELSE + IF ( ABS( E(I) ).LE.THRESH*ABS( Q(I) ) ) + $ E(I) = ZERO + END IF +C + CALL MB04YW( QRIT, LJOBUA, LJOBVA, M, N, I, K, SHIFT, + $ Q, E, U, LDU, V, LDV, DWORK(2*P) ) +C + IF ( QRIT ) THEN + IF ( ABS( E(K-1) ).LE.TOLABS ) E(K-1) = ZERO + ELSE + IF ( ABS( E(I) ).LE.TOLABS ) E(I) = ZERO + END IF + DWORK(K) = Q(K)**2 +C + DO 160 I1 = I, K - 1 + DWORK(I1) = Q(I1)**2 + DWORK(P+I1) = E(I1)**2 + 160 CONTINUE +C + ITER = ITER + 1 + END IF + END IF + GO TO 120 + END IF +C END WHILE 120 +C + IF ( ITER.GE.MAXIT ) THEN + INFO = 1 + GO TO 200 + END IF +C + IF ( X.LE.TOLABS ) THEN +C +C Split at negligible diagonal element ABS( Q(I) ) <= TOLABS. +C + CALL MB02NY( LJOBUA, LJOBVA, M, N, I, K, Q, E, U, LDU, V, + $ LDV, DWORK(2*P) ) + INUL(I) = .TRUE. + RANK = RANK - 1 + ELSE +C +C A negligible superdiagonal element ABS( E(I-1) ) <= TOL +C has been found, the corresponding bidiagonal submatrix +C belongs to C1 or C2. Treat this bidiagonal submatrix. +C + IF ( J.GE.2 ) THEN + IF ( NUMEIG.EQ.J ) THEN +C + DO 180 I1 = I, K + INUL(I1) = .TRUE. + 180 CONTINUE +C + RANK = RANK - J + K = K - J + ELSE + K = I - 1 + END IF + ELSE + IF ( X.LE.( THETAC + TOLABS ) ) THEN + INUL(I) = .TRUE. + RANK = RANK - 1 + END IF + K = K - 1 + END IF + OLDK = K + END IF + GO TO 80 + END IF +C END WHILE 80 +C +C If matrix was scaled, then rescale Q and E appropriately. +C + 200 CONTINUE + IF( IASCL.EQ.1 ) THEN + CALL DSCAL( P, ONE / SIGMA, Q, 1 ) + CALL DSCAL( P-1, ONE / SIGMA, E, 1 ) + END IF +C + RETURN +C *** Last line of MB04YD *** + END diff --git a/mex/sources/libslicot/MB04YW.f b/mex/sources/libslicot/MB04YW.f new file mode 100644 index 000000000..0090d5111 --- /dev/null +++ b/mex/sources/libslicot/MB04YW.f @@ -0,0 +1,513 @@ + SUBROUTINE MB04YW( QRIT, UPDATU, UPDATV, M, N, L, K, SHIFT, D, E, + $ U, LDU, V, LDV, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform either one QR or QL iteration step onto the unreduced +C bidiagonal submatrix Jk: +C +C |D(l) E(l) 0 ... 0 | +C | 0 D(l+1) E(l+1) . | +C Jk = | . . | +C | . . | +C | . E(k-1)| +C | 0 ... ... D(k) | +C +C with k <= p and l >= 1, p = MIN(M,N), of the bidiagonal matrix J: +C +C |D(1) E(1) 0 ... 0 | +C | 0 D(2) E(2) . | +C J = | . . |. +C | . . | +C | . E(p-1)| +C | 0 ... ... D(p) | +C +C Hereby, Jk is transformed to S' Jk T with S and T products of +C Givens rotations. These Givens rotations S (respectively, T) are +C postmultiplied into U (respectively, V), if UPDATU (respectively, +C UPDATV) is .TRUE.. +C +C ARGUMENTS +C +C Mode Parameters +C +C QRIT LOGICAL +C Indicates whether a QR or QL iteration step is to be +C taken (from larger end diagonal element towards smaller), +C as follows: +C = .TRUE. : QR iteration step (chase bulge from top to +C bottom); +C = .FALSE.: QL iteration step (chase bulge from bottom to +C top). +C +C UPDATU LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix U the left-hand Givens rotations S, as follows: +C = .FALSE.: Do not form U; +C = .TRUE. : The given matrix U is updated (postmultiplied) +C by the left-hand Givens rotations S. +C +C UPDATV LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix V the right-hand Givens rotations S, as follows: +C = .FALSE.: Do not form V; +C = .TRUE. : The given matrix V is updated (postmultiplied) +C by the right-hand Givens rotations T. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix U. M >= 0. +C +C N (input) INTEGER +C The number of rows of the matrix V. N >= 0. +C +C L (input) INTEGER +C The index of the first diagonal entry of the considered +C unreduced bidiagonal submatrix Jk of J. +C +C K (input) INTEGER +C The index of the last diagonal entry of the considered +C unreduced bidiagonal submatrix Jk of J. +C +C SHIFT (input) DOUBLE PRECISION +C Value of the shift used in the QR or QL iteration step. +C +C D (input/output) DOUBLE PRECISION array, dimension (p) +C where p = MIN(M,N) +C On entry, D must contain the diagonal entries of the +C bidiagonal matrix J. +C On exit, D contains the diagonal entries of the +C transformed bidiagonal matrix S' J T. +C +C E (input/output) DOUBLE PRECISION array, dimension (p-1) +C On entry, E must contain the superdiagonal entries of J. +C On exit, E contains the superdiagonal entries of the +C transformed matrix S' J T. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,p) +C On entry, if UPDATU = .TRUE., U must contain the M-by-p +C left transformation matrix. +C On exit, if UPDATU = .TRUE., the Givens rotations S on the +C left have been postmultiplied into U, i.e., U * S is +C returned. +C U is not referenced if UPDATU = .FALSE.. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= max(1,M) if UPDATU = .TRUE.; +C LDU >= 1 if UPDATU = .FALSE.. +C +C V (input/output) DOUBLE PRECISION array, dimension (LDV,p) +C On entry, if UPDATV = .TRUE., V must contain the N-by-p +C right transformation matrix. +C On exit, if UPDATV = .TRUE., the Givens rotations T on the +C right have been postmultiplied into V, i.e., V * T is +C returned. +C V is not referenced if UPDATV = .FALSE.. +C +C LDV INTEGER +C The leading dimension of the array V. +C LDV >= max(1,N) if UPDATV = .TRUE.; +C LDV >= 1 if UPDATV = .FALSE.. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (MAX(1,LDWORK)) +C LDWORK >= 4*MIN(M,N)-4, if UPDATU = UPDATV = .TRUE.; +C LDWORK >= 2*MIN(M,N)-2, if +C UPDATU = .TRUE. and UPDATV = .FALSE. or +C UPDATV = .TRUE. and UPDATU = .FALSE.; +C LDWORK >= 1, if UPDATU = UPDATV = .FALSE.. +C +C METHOD +C +C QR iterations diagonalize the bidiagonal matrix by zeroing the +C super-diagonal elements of Jk from bottom to top. +C QL iterations diagonalize the bidiagonal matrix by zeroing the +C super-diagonal elements of Jk from top to bottom. +C The routine overwrites Jk with the bidiagonal matrix S' Jk T, +C where S and T are products of Givens rotations. +C T is essentially the orthogonal matrix that would be obtained by +C applying one implicit symmetric shift QR (QL) step onto the matrix +C Jk'Jk. This step factors the matrix (Jk'Jk - shift*I) into a +C product of an orthogonal matrix T and a upper (lower) triangular +C matrix. See [1,Sec.8.2-8.3] and [2] for more details. +C +C REFERENCES +C +C [1] Golub, G.H. and Van Loan, C.F. +C Matrix Computations. +C The Johns Hopkins University Press, Baltimore, Maryland, 1983. +C +C [2] Bowdler, H., Martin, R.S. and Wilkinson, J.H. +C The QR and QL algorithms for symmetric matrices. +C Numer. Math., 11, pp. 293-306, 1968. +C +C [3] Demmel, J. and Kahan, W. +C Computing small singular values of bidiagonal matrices with +C guaranteed high relative accuracy. +C SIAM J. Sci. Statist. Comput., 11, pp. 873-912, 1990. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. +C Supersedes Release 2.0 routines MB04QY and MB04QZ by S. Van +C Huffel, Katholieke University Leuven, Belgium. +C This subroutine is based on the QR/QL step implemented in LAPACK +C routine DBDSQR. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Bidiagonal matrix, orthogonal transformation, singular values. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + LOGICAL QRIT, UPDATU, UPDATV + INTEGER K, L, LDU, LDV, M, N + DOUBLE PRECISION SHIFT +C .. +C .. Array Arguments .. + DOUBLE PRECISION D( * ), DWORK( * ), E( * ), U( LDU, * ), + $ V( LDV, * ) +C .. +C .. Local Scalars .. + INTEGER I, IROT, NCV, NM1, NM12, NM13 + DOUBLE PRECISION COSL, COSR, CS, F, G, H, OLDCS, OLDSN, R, SINL, + $ SINR, SN +C .. +C .. External Subroutines .. + EXTERNAL DLARTG, DLASR +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MIN, SIGN +C .. +C .. Executable Statements .. +C +C For speed, no tests of the input scalar arguments are done. +C +C Quick return if possible. +C + NCV = MIN( M, N ) + IF ( NCV.LE.1 .OR. L.EQ.K ) + $ RETURN +C + NM1 = NCV - 1 + NM12 = NM1 + NM1 + NM13 = NM12 + NM1 + IF ( .NOT.UPDATV ) THEN + NM12 = 0 + NM13 = NM1 + END IF +C +C If SHIFT = 0, do simplified QR iteration. +C + IF( SHIFT.EQ.ZERO ) THEN + IF( QRIT ) THEN +C +C Chase bulge from top to bottom. +C Save cosines and sines for later U and/or V updates, +C if needed. +C + CS = ONE + OLDCS = ONE + CALL DLARTG( D( L )*CS, E( L ), CS, SN, R ) + CALL DLARTG( OLDCS*R, D( L+1 )*SN, OLDCS, OLDSN, D( L ) ) + IF ( UPDATV ) THEN + DWORK( 1 ) = CS + DWORK( 1+NM1 ) = SN + END IF + IF ( UPDATU ) THEN + DWORK( 1+NM12 ) = OLDCS + DWORK( 1+NM13 ) = OLDSN + END IF + IROT = 1 +C + DO 110 I = L + 1, K - 1 + CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) + E( I-1 ) = OLDSN*R + CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) ) + IROT = IROT + 1 + IF ( UPDATV ) THEN + DWORK( IROT ) = CS + DWORK( IROT+NM1 ) = SN + END IF + IF ( UPDATU ) THEN + DWORK( IROT+NM12 ) = OLDCS + DWORK( IROT+NM13 ) = OLDSN + END IF + 110 CONTINUE +C + H = D( K )*CS + D( K ) = H*OLDCS + E( K-1 ) = H*OLDSN +C +C Update U and/or V. +C + IF( UPDATV ) + $ CALL DLASR( 'R', 'V', 'F', N, K-L+1, DWORK( 1 ), + $ DWORK( NCV ), V( 1, L ), LDV ) + IF( UPDATU ) + $ CALL DLASR( 'R', 'V', 'F', M, K-L+1, DWORK( NM12+1 ), + $ DWORK( NM13+1 ), U( 1, L ), LDU ) +C + ELSE +C +C Chase bulge from bottom to top. +C Save cosines and sines for later U and/or V updates, +C if needed. +C + CS = ONE + OLDCS = ONE + CALL DLARTG( D( K )*CS, E( K-1 ), CS, SN, R ) + CALL DLARTG( OLDCS*R, D( K-1 )*SN, OLDCS, OLDSN, D( K ) ) + IF ( UPDATV ) THEN + DWORK( K-L ) = OLDCS + DWORK( K-L+NM1 ) = -OLDSN + END IF + IF ( UPDATU ) THEN + DWORK( K-L+NM12 ) = CS + DWORK( K-L+NM13 ) = -SN + END IF + IROT = K - L +C + DO 120 I = K - 1, L + 1, -1 + CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) + E( I ) = OLDSN*R + CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) + IROT = IROT - 1 + IF ( UPDATV ) THEN + DWORK( IROT ) = OLDCS + DWORK( IROT+NM1 ) = -OLDSN + END IF + IF ( UPDATU ) THEN + DWORK( IROT+NM12 ) = CS + DWORK( IROT+NM13 ) = -SN + END IF + 120 CONTINUE +C + H = D( L )*CS + D( L ) = H*OLDCS + E( L ) = H*OLDSN +C +C Update U and/or V. +C + IF( UPDATV ) + $ CALL DLASR( 'R', 'V', 'B', N, K-L+1, DWORK( 1 ), + $ DWORK( NCV ), V( 1, L ), LDV ) + IF( UPDATU ) + $ CALL DLASR( 'R', 'V', 'B', M, K-L+1, DWORK( NM12+1 ), + $ DWORK( NM13+1 ), U( 1, L ), LDU ) + END IF + ELSE +C +C Use nonzero shift. +C + IF( QRIT ) THEN +C +C Chase bulge from top to bottom. +C Save cosines and sines for later U and/or V updates, +C if needed. +C + F = ( ABS( D( L ) ) - SHIFT )* + $ ( SIGN( ONE, D( L ) ) + SHIFT / D( L ) ) + G = E( L ) + CALL DLARTG( F, G, COSR, SINR, R ) + F = COSR*D( L ) + SINR*E( L ) + E( L ) = COSR*E( L ) - SINR*D( L ) + G = SINR*D( L+1 ) + D( L+1 ) = COSR*D( L+1 ) + CALL DLARTG( F, G, COSL, SINL, R ) + D( L ) = R + F = COSL*E( L ) + SINL*D( L+1 ) + D( L+1 ) = COSL*D( L+1 ) - SINL*E( L ) + G = SINL*E( L+1 ) + E( L+1 ) = COSL*E( L+1 ) + IF ( UPDATV ) THEN + DWORK( 1 ) = COSR + DWORK( 1+NM1 ) = SINR + END IF + IF ( UPDATU ) THEN + DWORK( 1+NM12 ) = COSL + DWORK( 1+NM13 ) = SINL + END IF + IROT = 1 +C + DO 130 I = L + 1, K - 2 + CALL DLARTG( F, G, COSR, SINR, R ) + E( I-1 ) = R + F = COSR*D( I ) + SINR*E( I ) + E( I ) = COSR*E( I ) - SINR*D( I ) + G = SINR*D( I+1 ) + D( I+1 ) = COSR*D( I+1 ) + CALL DLARTG( F, G, COSL, SINL, R ) + D( I ) = R + F = COSL*E( I ) + SINL*D( I+1 ) + D( I+1 ) = COSL*D( I+1 ) - SINL*E( I ) + G = SINL*E( I+1 ) + E( I+1 ) = COSL*E( I+1 ) + IROT = IROT + 1 + IF ( UPDATV ) THEN + DWORK( IROT ) = COSR + DWORK( IROT+NM1 ) = SINR + END IF + IF ( UPDATU ) THEN + DWORK( IROT+NM12 ) = COSL + DWORK( IROT+NM13 ) = SINL + END IF + 130 CONTINUE +C + IF ( L.LT.K-1 ) THEN + CALL DLARTG( F, G, COSR, SINR, R ) + E( K-2 ) = R + F = COSR*D( K-1 ) + SINR*E( K-1 ) + E( K-1 ) = COSR*E( K-1 ) - SINR*D( K-1 ) + G = SINR*D( K ) + D( K ) = COSR*D( K ) + CALL DLARTG( F, G, COSL, SINL, R ) + D( K-1 ) = R + F = COSL*E( K-1 ) + SINL*D( K ) + D( K ) = COSL*D( K ) - SINL*E( K-1 ) + IROT = IROT + 1 + IF ( UPDATV ) THEN + DWORK( IROT ) = COSR + DWORK( IROT+NM1 ) = SINR + END IF + IF ( UPDATU ) THEN + DWORK( IROT+NM12 ) = COSL + DWORK( IROT+NM13 ) = SINL + END IF + END IF + E( K-1 ) = F +C +C Update U and/or V. +C + IF( UPDATV ) + $ CALL DLASR( 'R', 'V', 'F', N, K-L+1, DWORK( 1 ), + $ DWORK( NCV ), V( 1, L ), LDV ) + IF( UPDATU ) + $ CALL DLASR( 'R', 'V', 'F', M, K-L+1, DWORK( NM12+1 ), + $ DWORK( NM13+1 ), U( 1, L ), LDU ) +C + ELSE +C +C Chase bulge from bottom to top. +C Save cosines and sines for later U and/or V updates, +C if needed. +C + F = ( ABS( D( K ) ) - SHIFT )* + $ ( SIGN( ONE, D( K ) ) + SHIFT / D( K ) ) + G = E( K-1 ) + IF ( L.LT.K-1 ) THEN + CALL DLARTG( F, G, COSR, SINR, R ) + F = COSR*D( K ) + SINR*E( K-1 ) + E( K-1 ) = COSR*E( K-1 ) - SINR*D( K ) + G = SINR*D( K-1 ) + D( K-1 ) = COSR*D( K-1 ) + CALL DLARTG( F, G, COSL, SINL, R ) + D( K ) = R + F = COSL*E( K-1 ) + SINL*D( K-1 ) + D( K-1 ) = COSL*D( K-1 ) - SINL*E( K-1 ) + G = SINL*E( K-2 ) + E( K-2 ) = COSL*E( K-2 ) + IF ( UPDATV ) THEN + DWORK( K-L ) = COSL + DWORK( K-L+NM1 ) = -SINL + END IF + IF ( UPDATU ) THEN + DWORK( K-L+NM12 ) = COSR + DWORK( K-L+NM13 ) = -SINR + END IF + IROT = K - L + ELSE + IROT = K - L + 1 + END IF +C + DO 140 I = K - 1, L + 2, -1 + CALL DLARTG( F, G, COSR, SINR, R ) + E( I ) = R + F = COSR*D( I ) + SINR*E( I-1 ) + E( I-1 ) = COSR*E( I-1 ) - SINR*D( I ) + G = SINR*D( I-1 ) + D( I-1 ) = COSR*D( I-1 ) + CALL DLARTG( F, G, COSL, SINL, R ) + D( I ) = R + F = COSL*E( I-1 ) + SINL*D( I-1 ) + D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 ) + G = SINL*E( I-2 ) + E( I-2 ) = COSL*E( I-2 ) + IROT = IROT - 1 + IF ( UPDATV ) THEN + DWORK( IROT ) = COSL + DWORK( IROT+NM1 ) = -SINL + END IF + IF ( UPDATU ) THEN + DWORK( IROT+NM12 ) = COSR + DWORK( IROT+NM13 ) = -SINR + END IF + 140 CONTINUE +C + CALL DLARTG( F, G, COSR, SINR, R ) + E( L+1 ) = R + F = COSR*D( L+1 ) + SINR*E( L ) + E( L ) = COSR*E( L ) - SINR*D( L+1 ) + G = SINR*D( L ) + D( L ) = COSR*D( L ) + CALL DLARTG( F, G, COSL, SINL, R ) + D( L+1 ) = R + F = COSL*E( L ) + SINL*D( L ) + D( L ) = COSL*D( L ) - SINL*E( L ) + IROT = IROT - 1 + IF ( UPDATV ) THEN + DWORK( IROT ) = COSL + DWORK( IROT+NM1 ) = -SINL + END IF + IF ( UPDATU ) THEN + DWORK( IROT+NM12 ) = COSR + DWORK( IROT+NM13 ) = -SINR + END IF + E( L ) = F +C +C Update U and/or V if desired. +C + IF( UPDATV ) + $ CALL DLASR( 'R', 'V', 'B', N, K-L+1, DWORK( 1 ), + $ DWORK( NCV ), V( 1, L ), LDV ) + IF( UPDATU ) + $ CALL DLASR( 'R', 'V', 'B', M, K-L+1, DWORK( NM12+1 ), + $ DWORK( NM13+1 ), U( 1, L ), LDU ) + END IF + END IF +C + RETURN +C *** Last line of MB04YW *** + END diff --git a/mex/sources/libslicot/MB04ZD.f b/mex/sources/libslicot/MB04ZD.f new file mode 100644 index 000000000..63c77e6a1 --- /dev/null +++ b/mex/sources/libslicot/MB04ZD.f @@ -0,0 +1,486 @@ + SUBROUTINE MB04ZD( COMPU, N, A, LDA, QG, LDQG, U, LDU, DWORK, INFO + $ ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To transform a Hamiltonian matrix +C +C ( A G ) +C H = ( T ) (1) +C ( Q -A ) +C +C into a square-reduced Hamiltonian matrix +C +C ( A' G' ) +C H' = ( T ) (2) +C ( Q' -A' ) +C T +C by an orthogonal symplectic similarity transformation H' = U H U, +C where +C ( U1 U2 ) +C U = ( ). (3) +C ( -U2 U1 ) +C T +C The square-reduced Hamiltonian matrix satisfies Q'A' - A' Q' = 0, +C and +C +C 2 T 2 ( A'' G'' ) +C H' := (U H U) = ( T ). +C ( 0 A'' ) +C +C In addition, A'' is upper Hessenberg and G'' is skew symmetric. +C The square roots of the eigenvalues of A'' = A'*A' + G'*Q' are the +C eigenvalues of H. +C +C ARGUMENTS +C +C Mode Parameters +C +C COMPU CHARACTER*1 +C Indicates whether the orthogonal symplectic similarity +C transformation matrix U in (3) is returned or +C accumulated into an orthogonal symplectic matrix, or if +C the transformation matrix is not required, as follows: +C = 'N': U is not required; +C = 'I' or 'F': on entry, U need not be set; +C on exit, U contains the orthogonal +C symplectic matrix U from (3); +C = 'V' or 'A': the orthogonal symplectic similarity +C transformations are accumulated into U; +C on input, U must contain an orthogonal +C symplectic matrix S; +C on exit, U contains S*U with U from (3). +C See the description of U below for details. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, G, and Q. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On input, the leading N-by-N part of this array must +C contain the upper left block A of the Hamiltonian matrix H +C in (1). +C On output, the leading N-by-N part of this array contains +C the upper left block A' of the square-reduced Hamiltonian +C matrix H' in (2). +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C QG (input/output) DOUBLE PRECISION array, dimension +C (LDQG,N+1) +C On input, the leading N-by-N lower triangular part of this +C array must contain the lower triangle of the lower left +C symmetric block Q of the Hamiltonian matrix H in (1), and +C the N-by-N upper triangular part of the submatrix in the +C columns 2 to N+1 of this array must contain the upper +C triangle of the upper right symmetric block G of H in (1). +C So, if i >= j, then Q(i,j) = Q(j,i) is stored in QG(i,j) +C and G(i,j) = G(j,i) is stored in QG(j,i+1). +C On output, the leading N-by-N lower triangular part of +C this array contains the lower triangle of the lower left +C symmetric block Q', and the N-by-N upper triangular part +C of the submatrix in the columns 2 to N+1 of this array +C contains the upper triangle of the upper right symmetric +C block G' of the square-reduced Hamiltonian matrix H' +C in (2). +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= MAX(1,N). +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,2*N) +C If COMPU = 'N', then this array is not referenced. +C If COMPU = 'I' or 'F', then the input contents of this +C array are not specified. On output, the leading +C N-by-(2*N) part of this array contains the first N rows +C of the orthogonal symplectic matrix U in (3). +C If COMPU = 'V' or 'A', then, on input, the leading +C N-by-(2*N) part of this array must contain the first N +C rows of an orthogonal symplectic matrix S. On output, the +C leading N-by-(2*N) part of this array contains the first N +C rows of the product S*U where U is the orthogonal +C symplectic matrix from (3). +C The storage scheme implied by (3) is used for orthogonal +C symplectic matrices, i.e., only the first N rows are +C stored, as they contain all relevant information. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= MAX(1,N), if COMPU <> 'N'; +C LDU >= 1, if COMPU = 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, then the i-th argument had an illegal +C value. +C +C METHOD +C +C The Hamiltonian matrix H is transformed into a square-reduced +C Hamiltonian matrix H' using the implicit version of Van Loan's +C method as proposed in [1,2,3]. +C +C REFERENCES +C +C [1] Van Loan, C. F. +C A Symplectic Method for Approximating All the Eigenvalues of +C a Hamiltonian Matrix. +C Linear Algebra and its Applications, 61, pp. 233-251, 1984. +C +C [2] Byers, R. +C Hamiltonian and Symplectic Algorithms for the Algebraic +C Riccati Equation. +C Ph. D. Thesis, Cornell University, Ithaca, NY, January 1983. +C +C [3] Benner, P., Byers, R., and Barth, E. +C Fortran 77 Subroutines for Computing the Eigenvalues of +C Hamiltonian Matrices. I: The Square-Reduced Method. +C ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000. +C +C NUMERICAL ASPECTS +C +C This algorithm requires approximately 20*N**3 flops for +C transforming H into square-reduced form. If the transformations +C are required, this adds another 8*N**3 flops. The method is +C strongly backward stable in the sense that if H' and U are the +C computed square-reduced Hamiltonian and computed orthogonal +C symplectic similarity transformation, then there is an orthogonal +C symplectic matrix T and a Hamiltonian matrix M such that +C +C H T = T M +C +C || T - U || <= c1 * eps +C +C || H' - M || <= c2 * eps * || H || +C +C where c1, c2 are modest constants depending on the dimension N and +C eps is the machine precision. +C +C Eigenvalues computed by explicitly forming the upper Hessenberg +C matrix A'' = A'A' + G'Q', with A', G', and Q' as in (2), and +C applying the Hessenberg QR iteration to A'' are exactly +C eigenvalues of a perturbed Hamiltonian matrix H + E, where +C +C || E || <= c3 * sqrt(eps) * || H ||, +C +C and c3 is a modest constant depending on the dimension N and eps +C is the machine precision. Moreover, if the norm of H and an +C eigenvalue lambda are of roughly the same magnitude, the computed +C eigenvalue is essentially as accurate as the computed eigenvalue +C from traditional methods. See [1] or [2]. +C +C CONTRIBUTOR +C +C P. Benner, Universitaet Bremen, Germany, +C R. Byers, University of Kansas, Lawrence, USA, and +C E. Barth, Kalamazoo College, Kalamazoo, USA, +C Aug. 1998, routine DHASRD. +C V. Sima, Research Institute for Informatics, Bucharest, Romania, +C Oct. 1998, SLICOT Library version. +C +C REVISIONS +C +C May 2001, A. Varga, German Aeropsce Center, DLR Oberpfaffenhofen. +C May 2009, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C Orthogonal transformation, (square-reduced) Hamiltonian matrix, +C symplectic similarity transformation. +C +C ****************************************************************** +C +C .. Parameters .. +C + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDQG, LDU, N + CHARACTER COMPU +C .. +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*), U(LDU,*) +C .. +C .. Local Scalars .. + DOUBLE PRECISION COSINE, SINE, TAU, TEMP, X, Y + INTEGER J + LOGICAL ACCUM, FORGET, FORM +C .. +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1), T(2,2) +C .. +C .. External Functions .. + DOUBLE PRECISION DDOT + LOGICAL LSAME + EXTERNAL DDOT, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DLARFG, DLARFX, DLARTG, + $ DROT, DSYMV, DSYR2, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C + INFO = 0 + ACCUM = LSAME( COMPU, 'A' ) .OR. LSAME( COMPU, 'V' ) + FORM = LSAME( COMPU, 'F' ) .OR. LSAME( COMPU, 'I' ) + FORGET = LSAME( COMPU, 'N' ) +C + IF ( .NOT.ACCUM .AND. .NOT.FORM .AND. .NOT.FORGET ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDQG.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDU.LT.1 .OR. ( .NOT.FORGET .AND. LDU.LT.MAX( 1, N ) ) ) + $ THEN + INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04ZD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C +C Transform to square-reduced form. +C + DO 10 J = 1, N - 1 +C T +C DWORK <- (Q*A - A *Q)(J+1:N,J). +C + CALL DCOPY( J-1, QG(J,1), LDQG, DWORK(N+1), 1 ) + CALL DCOPY( N-J+1, QG(J,J), 1, DWORK(N+J), 1 ) + CALL DGEMV( 'Transpose', N, N-J, -ONE, A(1,J+1), LDA, + $ DWORK(N+1), 1, ZERO, DWORK(J+1), 1 ) + CALL DGEMV( 'NoTranspose', N-J, J, ONE, QG(J+1,1), LDQG, + $ A(1,J), 1, ONE, DWORK(J+1), 1 ) + CALL DSYMV( 'Lower', N-J, ONE, QG(J+1,J+1), LDQG, A(J+1,J), 1, + $ ONE, DWORK(J+1), 1 ) +C +C Symplectic reflection to zero (H*H)((N+J+2):2N,J). +C + CALL DLARFG( N-J, DWORK(J+1), DWORK(J+2), 1, TAU ) + Y = DWORK(J+1) + DWORK(J+1) = ONE +C + CALL DLARFX( 'Left', N-J, N, DWORK(J+1), TAU, A(J+1,1), LDA, + $ DWORK(N+1) ) + CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, A(1,J+1), LDA, + $ DWORK(N+1) ) +C + CALL DLARFX( 'Left', N-J, J, DWORK(J+1), TAU, QG(J+1,1), LDQG, + $ DWORK(N+1) ) + CALL DSYMV( 'Lower', N-J, TAU, QG(J+1,J+1), LDQG, DWORK(J+1), + $ 1, ZERO, DWORK(N+J+1), 1 ) + CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), + $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) + CALL DSYR2( 'Lower', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, + $ QG(J+1,J+1), LDQG ) +C + CALL DLARFX( 'Right', J, N-J, DWORK(J+1), TAU, QG(1,J+2), LDQG, + $ DWORK(N+1) ) + CALL DSYMV( 'Upper', N-J, TAU, QG(J+1,J+2), LDQG, DWORK(J+1), + $ 1, ZERO, DWORK(N+J+1), 1 ) + CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), + $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) + CALL DSYR2( 'Upper', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, + $ QG(J+1,J+2), LDQG ) +C + IF ( FORM ) THEN +C +C Save reflection. +C + CALL DCOPY( N-J, DWORK(J+1), 1, U(J+1,J), 1 ) + U(J+1,J) = TAU +C + ELSE IF ( ACCUM ) THEN +C +C Accumulate reflection. +C + CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,J+1), + $ LDU, DWORK(N+1) ) + CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,N+J+1), + $ LDU, DWORK(N+1) ) + END IF +C +C (X,Y) := ((J+1,J),(N+J+1,J)) component of H*H. +C + X = DDOT( J, QG(1,J+2), 1, QG(J,1), LDQG ) + + $ DDOT( N-J, QG(J+1,J+2), LDQG, QG(J+1,J), 1 ) + + $ DDOT( N, A(J+1,1), LDA, A(1,J), 1 ) +C +C Symplectic rotation to zero (H*H)(N+J+1,J). +C + CALL DLARTG( X, Y, COSINE, SINE, TEMP ) +C + CALL DROT( J, A(J+1,1), LDA, QG(J+1,1), LDQG, COSINE, SINE ) + CALL DROT( J, A(1,J+1), 1, QG(1,J+2), 1, COSINE, SINE ) + IF( J.LT.N-1 ) THEN + CALL DROT( N-J-1, A(J+1,J+2), LDA, QG(J+2,J+1), 1, + $ COSINE, SINE ) + CALL DROT( N-J-1, A(J+2,J+1), 1, QG(J+1,J+3), LDQG, + $ COSINE, SINE ) + END IF +C + T(1,1) = A(J+1,J+1) + T(1,2) = QG(J+1,J+2) + T(2,1) = QG(J+1,J+1) + T(2,2) = -T(1,1) + CALL DROT( 2, T(1,1), 1, T(1,2), 1, COSINE, SINE ) + CALL DROT( 2, T(1,1), 2, T(2,1), 2, COSINE, SINE ) + A(J+1,J+1) = T(1,1) + QG(J+1,J+2) = T(1,2) + QG(J+1,J+1) = T(2,1) +C + IF ( FORM ) THEN +C +C Save rotation. +C + U(J,J) = COSINE + U(J,N+J) = SINE +C + ELSE IF ( ACCUM ) THEN +C +C Accumulate rotation. +C + CALL DROT( N, U(1,J+1), 1, U(1,N+J+1), 1, COSINE, SINE ) + END IF +C +C DWORK := (A*A + G*Q)(J+1:N,J). +C + CALL DGEMV( 'NoTranspose', N-J, N, ONE, A(J+1,1), LDA, A(1,J), + $ 1, ZERO, DWORK(J+1), 1 ) + CALL DGEMV( 'Transpose', J, N-J, ONE, QG(1,J+2), LDQG, QG(J,1), + $ LDQG, ONE, DWORK(J+1), 1 ) + CALL DSYMV( 'Upper', N-J, ONE, QG(J+1,J+2), LDQG, QG(J+1,J), 1, + $ ONE, DWORK(J+1), 1 ) +C +C Symplectic reflection to zero (H*H)(J+2:N,J). +C + CALL DLARFG( N-J, DWORK(J+1), DWORK(J+2), 1, TAU ) + DWORK(J+1) = ONE +C + CALL DLARFX( 'Left', N-J, N, DWORK(J+1), TAU, A(J+1,1), LDA, + $ DWORK(N+1) ) + CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, A(1,J+1), LDA, + $ DWORK(N+1) ) +C + CALL DLARFX( 'Left', N-J, J, DWORK(J+1), TAU, QG(J+1,1), LDQG, + $ DWORK(N+1) ) + CALL DSYMV( 'Lower', N-J, TAU, QG(J+1,J+1), LDQG, DWORK(J+1), + $ 1, ZERO, DWORK(N+J+1), 1 ) + CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), + $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) + CALL DSYR2( 'Lower', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, + $ QG(J+1,J+1), LDQG ) +C + CALL DLARFX( 'Right', J, N-J, DWORK(J+1), TAU, QG(1,J+2), LDQG, + $ DWORK(N+1) ) + CALL DSYMV( 'Upper', N-J, TAU, QG(J+1,J+2), LDQG, DWORK(J+1), + $ 1, ZERO, DWORK(N+J+1), 1 ) + CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), + $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) + CALL DSYR2( 'Upper', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, + $ QG(J+1,J+2), LDQG ) +C + IF ( FORM ) THEN +C +C Save reflection. +C + CALL DCOPY( N-J, DWORK(J+1), 1, U(J+1,N+J), 1 ) + U(J+1,N+J) = TAU +C + ELSE IF ( ACCUM ) THEN +C +C Accumulate reflection. +C + CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,J+1), + $ LDU, DWORK(N+1) ) + CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,N+J+1), + $ LDU, DWORK(N+1) ) + END IF +C + 10 CONTINUE +C + IF ( FORM ) THEN + DUMMY(1) = ZERO +C +C Form S by accumulating transformations. +C + DO 20 J = N - 1, 1, -1 +C +C Initialize (J+1)st column of S. +C + CALL DCOPY( N, DUMMY, 0, U(1,J+1), 1 ) + U(J+1,J+1) = ONE + CALL DCOPY( N, DUMMY, 0, U(1,N+J+1), 1 ) +C +C Second reflection. +C + TAU = U(J+1,N+J) + U(J+1,N+J) = ONE + CALL DLARFX( 'Left', N-J, N-J, U(J+1,N+J), TAU, + $ U(J+1,J+1), LDU, DWORK(N+1) ) + CALL DLARFX( 'Left', N-J, N-J, U(J+1,N+J), TAU, + $ U(J+1,N+J+1), LDU, DWORK(N+1) ) +C +C Rotation. +C + CALL DROT( N-J, U(J+1,J+1), LDU, U(J+1,N+J+1), LDU, + $ U(J,J), U(J,N+J) ) +C +C First reflection. +C + TAU = U(J+1,J) + U(J+1,J) = ONE + CALL DLARFX( 'Left', N-J, N-J, U(J+1,J), TAU, U(J+1,J+1), + $ LDU, DWORK(N+1) ) + CALL DLARFX( 'Left', N-J, N-J, U(J+1,J), TAU, + $ U(J+1,N+J+1), LDU, DWORK(N+1) ) + 20 CONTINUE +C +C The first column is the first column of identity. +C + CALL DCOPY( N, DUMMY, 0, U, 1 ) + U(1,1) = ONE + CALL DCOPY( N, DUMMY, 0, U(1,N+1), 1 ) + END IF +C + RETURN +C *** Last line of MB04ZD *** + END diff --git a/mex/sources/libslicot/MB05MD.f b/mex/sources/libslicot/MB05MD.f new file mode 100644 index 000000000..58da11528 --- /dev/null +++ b/mex/sources/libslicot/MB05MD.f @@ -0,0 +1,356 @@ + SUBROUTINE MB05MD( BALANC, N, DELTA, A, LDA, V, LDV, Y, LDY, VALR, + $ VALI, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute exp(A*delta) where A is a real N-by-N non-defective +C matrix with real or complex eigenvalues and delta is a scalar +C value. The routine also returns the eigenvalues and eigenvectors +C of A as well as (if all eigenvalues are real) the matrix product +C exp(Lambda*delta) times the inverse of the eigenvector matrix +C of A, where Lambda is the diagonal matrix of eigenvalues. +C Optionally, the routine computes a balancing transformation to +C improve the conditioning of the eigenvalues and eigenvectors. +C +C ARGUMENTS +C +C Mode Parameters +C +C BALANC CHARACTER*1 +C Indicates how the input matrix should be diagonally scaled +C to improve the conditioning of its eigenvalues as follows: +C = 'N': Do not diagonally scale; +C = 'S': Diagonally scale the matrix, i.e. replace A by +C D*A*D**(-1), where D is a diagonal matrix chosen +C to make the rows and columns of A more equal in +C norm. Do not permute. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C DELTA (input) DOUBLE PRECISION +C The scalar value delta of the problem. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A of the problem. +C On exit, the leading N-by-N part of this array contains +C the solution matrix exp(A*delta). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= max(1,N). +C +C V (output) DOUBLE PRECISION array, dimension (LDV,N) +C The leading N-by-N part of this array contains the +C eigenvector matrix for A. +C If the k-th eigenvalue is real the k-th column of the +C eigenvector matrix holds the eigenvector corresponding +C to the k-th eigenvalue. +C Otherwise, the k-th and (k+1)-th eigenvalues form a +C complex conjugate pair and the k-th and (k+1)-th columns +C of the eigenvector matrix hold the real and imaginary +C parts of the eigenvectors corresponding to these +C eigenvalues as follows. +C If p and q denote the k-th and (k+1)-th columns of the +C eigenvector matrix, respectively, then the eigenvector +C corresponding to the complex eigenvalue with positive +C (negative) imaginary value is given by +C 2 +C p + q*j (p - q*j), where j = -1. +C +C LDV INTEGER +C The leading dimension of array V. LDV >= max(1,N). +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,N) +C The leading N-by-N part of this array contains an +C intermediate result for computing the matrix exponential. +C Specifically, exp(A*delta) is obtained as the product V*Y, +C where V is the matrix stored in the leading N-by-N part of +C the array V. If all eigenvalues of A are real, then the +C leading N-by-N part of this array contains the matrix +C product exp(Lambda*delta) times the inverse of the (right) +C eigenvector matrix of A, where Lambda is the diagonal +C matrix of eigenvalues. +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= max(1,N). +C +C VALR (output) DOUBLE PRECISION array, dimension (N) +C VALI (output) DOUBLE PRECISION array, dimension (N) +C These arrays contain the real and imaginary parts, +C respectively, of the eigenvalues of the matrix A. The +C eigenvalues are unordered except that complex conjugate +C pairs of values appear consecutively with the eigenvalue +C having positive imaginary part first. +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and if N > 0, DWORK(2) returns the reciprocal +C condition number of the triangular matrix used to obtain +C the inverse of the eigenvector matrix. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= max(1,4*N). +C For good performance, LDWORK must generally be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = i: if INFO = i, the QR algorithm failed to compute all +C the eigenvalues; no eigenvectors have been computed; +C elements i+1:N of VALR and VALI contain eigenvalues +C which have converged; +C = N+1: if the inverse of the eigenvector matrix could not +C be formed due to an attempt to divide by zero, i.e., +C the eigenvector matrix is singular; +C = N+2: if the matrix A is defective, possibly due to +C rounding errors. +C +C METHOD +C +C This routine is an implementation of "Method 15" of the set of +C methods described in reference [1], which uses an eigenvalue/ +C eigenvector decomposition technique. A modification of LAPACK +C Library routine DGEEV is used for obtaining the right eigenvector +C matrix. A condition estimate is then employed to determine if the +C matrix A is near defective and hence the exponential solution is +C inaccurate. In this case the routine returns with the Error +C Indicator (INFO) set to N+2, and SLICOT Library routines MB05ND or +C MB05OD are the preferred alternative routines to be used. +C +C REFERENCES +C +C [1] Moler, C.B. and Van Loan, C.F. +C Nineteen dubious ways to compute the exponential of a matrix. +C SIAM Review, 20, pp. 801-836, 1978. +C +C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB05AD by M.J. Denham, Kingston +C Polytechnic, March 1981. +C +C REVISIONS +C +C V. Sima, June 13, 1997, April 25, 2003, Feb. 15, 2004. +C +C KEYWORDS +C +C Eigenvalue, eigenvector decomposition, matrix exponential. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER BALANC + INTEGER INFO, LDA, LDV, LDWORK, LDY, N + DOUBLE PRECISION DELTA +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), V(LDV,*), VALI(*), VALR(*), + $ Y(LDY,*) +C .. Local Scalars .. + LOGICAL SCALE + INTEGER I + DOUBLE PRECISION RCOND, TEMPI, TEMPR, WRKOPT +C .. Local Arrays .. + DOUBLE PRECISION TMP(2,2) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DGEBAK, DGEMM, DLACPY, DSCAL, DSWAP, DTRCON, + $ DTRMM, DTRSM, MB05MY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC COS, EXP, MAX, SIN +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + SCALE = LSAME( BALANC, 'S' ) + IF( .NOT.( LSAME( BALANC, 'N' ) .OR. SCALE ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDV.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDY.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDWORK.LT.MAX( 1, 4*N ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB05MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C +C Compute the eigenvalues and right eigenvectors of the real +C nonsymmetric matrix A; optionally, compute a balancing +C transformation. +C Workspace: need: 4*N. +C + CALL MB05MY( BALANC, N, A, LDA, VALR, VALI, V, LDV, Y, LDY, + $ DWORK, LDWORK, INFO ) +C + IF ( INFO.GT.0 ) + $ RETURN + WRKOPT = DWORK(1) + IF ( SCALE ) THEN + DO 10 I = 1, N + DWORK(I) = DWORK(I+1) + 10 CONTINUE + END IF +C +C Exit with INFO = N + 1 if V is exactly singular. +C + DO 20 I = 1, N + IF ( V(I,I).EQ.ZERO ) THEN + INFO = N + 1 + RETURN + END IF + 20 CONTINUE +C +C Compute the reciprocal condition number of the triangular matrix. +C + CALL DTRCON( '1-norm', 'Upper', 'Non unit', N, V, LDV, RCOND, + $ DWORK(N+1), IWORK, INFO ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN + DWORK(2) = RCOND + INFO = N + 2 + RETURN + END IF +C +C Compute the right eigenvector matrix (temporarily) in A. +C + CALL DLACPY( 'Full', N, N, Y, LDY, A, LDA ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Non unit', N, N, + $ ONE, V, LDV, A, LDA ) + IF ( SCALE ) + $ CALL DGEBAK( BALANC, 'Right', N, 1, N, DWORK, N, A, LDA, INFO ) +C +C Compute the inverse of the right eigenvector matrix, by solving +C a set of linear systems, V * X = Y' (if BALANC = 'N'). +C + DO 40 I = 2, N + CALL DSWAP( I-1, Y(I,1), LDY, Y(1,I), 1 ) + 40 CONTINUE +C + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non unit', N, N, + $ ONE, V, LDV, Y, LDY ) + IF( SCALE ) THEN +C + DO 60 I = 1, N + TEMPR = ONE / DWORK(I) + CALL DSCAL( N, TEMPR, Y(1,I), 1 ) + 60 CONTINUE +C + END IF +C +C Save the right eigenvector matrix in V. +C + CALL DLACPY( 'Full', N, N, A, LDA, V, LDV ) +C +C Premultiply the inverse eigenvector matrix by the exponential of +C quasi-diagonal matrix Lambda * DELTA, where Lambda is the matrix +C of eigenvalues. +C Note that only real arithmetic is used, taking the special storing +C of eigenvalues/eigenvectors into account. +C + I = 0 +C REPEAT + 80 CONTINUE + I = I + 1 + IF ( VALI(I).EQ.ZERO ) THEN + TEMPR = EXP( VALR(I)*DELTA ) + CALL DSCAL( N, TEMPR, Y(I,1), LDY ) + ELSE + TEMPR = VALR(I)*DELTA + TEMPI = VALI(I)*DELTA + TMP(1,1) = COS( TEMPI )*EXP( TEMPR ) + TMP(1,2) = SIN( TEMPI )*EXP( TEMPR ) + TMP(2,1) = -TMP(1,2) + TMP(2,2) = TMP(1,1) + CALL DLACPY( 'Full', 2, N, Y(I,1), LDY, DWORK, 2 ) + CALL DGEMM( 'No transpose', 'No transpose', 2, N, 2, ONE, + $ TMP, 2, DWORK, 2, ZERO, Y(I,1), LDY ) + I = I + 1 + END IF + IF ( I.LT.N ) GO TO 80 +C UNTIL I = N. +C +C Compute the matrix exponential as the product V * Y. +C + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, V, LDV, + $ Y, LDY, ZERO, A, LDA ) +C +C Set optimal workspace dimension and reciprocal condition number. +C + DWORK(1) = WRKOPT + DWORK(2) = RCOND +C + RETURN +C *** Last line of MB05MD *** + END diff --git a/mex/sources/libslicot/MB05MY.f b/mex/sources/libslicot/MB05MY.f new file mode 100644 index 000000000..7d7063494 --- /dev/null +++ b/mex/sources/libslicot/MB05MY.f @@ -0,0 +1,327 @@ + SUBROUTINE MB05MY( BALANC, N, A, LDA, WR, WI, R, LDR, Q, LDQ, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute, for an N-by-N real nonsymmetric matrix A, the +C orthogonal matrix Q reducing it to real Schur form T, the +C eigenvalues, and the right eigenvectors of T. +C +C The right eigenvector r(j) of T satisfies +C T * r(j) = lambda(j) * r(j) +C where lambda(j) is its eigenvalue. +C +C The matrix of right eigenvectors R is upper triangular, by +C construction. +C +C ARGUMENTS +C +C Mode Parameters +C +C BALANC CHARACTER*1 +C Indicates how the input matrix should be diagonally scaled +C to improve the conditioning of its eigenvalues as follows: +C = 'N': Do not diagonally scale; +C = 'S': Diagonally scale the matrix, i.e. replace A by +C D*A*D**(-1), where D is a diagonal matrix chosen +C to make the rows and columns of A more equal in +C norm. Do not permute. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the given matrix A. +C On exit, the leading N-by-N upper quasi-triangular part of +C this array contains the real Schur canonical form of A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= max(1,N). +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C WR and WI contain the real and imaginary parts, +C respectively, of the computed eigenvalues. Complex +C conjugate pairs of eigenvalues appear consecutively +C with the eigenvalue having the positive imaginary part +C first. +C +C R (output) DOUBLE PRECISION array, dimension (LDR,N) +C The leading N-by-N upper triangular part of this array +C contains the matrix of right eigenvectors R, in the same +C order as their eigenvalues. The real and imaginary parts +C of a complex eigenvector corresponding to an eigenvalue +C with positive imaginary part are stored in consecutive +C columns. (The corresponding conjugate eigenvector is not +C stored.) The eigenvectors are not backward transformed +C for balancing (when BALANC = 'S'). +C +C LDR INTEGER +C The leading dimension of array R. LDR >= max(1,N). +C +C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) +C The leading N-by-N part of this array contains the +C orthogonal matrix Q which has reduced A to real Schur +C form. +C +C LDQ INTEGER +C The leading dimension of array Q. LDQ >= MAX(1,N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. +C If BALANC = 'S', DWORK(2),...,DWORK(N+1) return the +C scaling factors used for balancing. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= max(1,4*N). +C For good performance, LDWORK must generally be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, the QR algorithm failed to compute all +C the eigenvalues, and no eigenvectors have been +C computed; elements i+1:N of WR and WI contain +C eigenvalues which have converged. +C +C METHOD +C +C This routine uses the QR algorithm to obtain the real Schur form +C T of matrix A. Then, the right eigenvectors of T are computed, +C but they are not backtransformed into the eigenvectors of A. +C MB05MY is a modification of the LAPACK driver routine DGEEV. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB05AY. +C +C REVISIONS +C +C V. Sima, April 25, 2003, Feb. 15, 2004. +C +C KEYWORDS +C +C Eigenvalue, eigenvector decomposition, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER BALANC + INTEGER INFO, LDA, LDQ, LDR, LDWORK, N +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), DWORK( * ), Q( LDQ, * ), + $ R( LDR, * ), WI( * ), WR( * ) +C .. +C .. Local Scalars .. + LOGICAL SCALE, SCALEA + INTEGER HSDWOR, IBAL, IERR, IHI, ILO, ITAU, JWORK, K, + $ MAXB, MAXWRK, MINWRK, NOUT + DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SMLNUM +C .. +C .. Local Arrays .. + LOGICAL SELECT( 1 ) + DOUBLE PRECISION DUM( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, DLASCL, + $ DORGHR, DTREVC, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + SCALE = LSAME( BALANC, 'S' ) + IF( .NOT.( LSAME( BALANC, 'N' ) .OR. SCALE ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDR.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV. +C HSDWOR refers to the workspace preferred by DHSEQR, as +C calculated below. HSDWOR is computed assuming ILO=1 and IHI=N, +C the worst case.) +C + MINWRK = 1 + IF( INFO.EQ.0 .AND. LDWORK.GE.1 ) THEN + MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) + MINWRK = MAX( 1, 4*N ) + MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* + $ ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) ) + MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SV', N, 1, N, -1 ), 2 ) + K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SV', N, 1, + $ N, -1 ) ) ) + HSDWOR = MAX( K*( K+2 ), 2*N ) + MAXWRK = MAX( MAXWRK, N+1, N+HSDWOR ) + MAXWRK = MAX( MAXWRK, 4*N ) + DWORK( 1 ) = MAXWRK + END IF + IF( LDWORK.LT.MINWRK ) THEN + INFO = -12 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB05MY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C +C Get machine constants. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +C +C Scale A if max element outside range [SMLNUM,BIGNUM]. +C + ANRM = DLANGE( 'M', N, N, A, LDA, DUM ) + SCALEA = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + SCALEA = .TRUE. + CSCALE = SMLNUM + ELSE IF( ANRM.GT.BIGNUM ) THEN + SCALEA = .TRUE. + CSCALE = BIGNUM + END IF + IF( SCALEA ) + $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) +C +C Balance the matrix, if requested. (Permutation is not possible.) +C (Workspace: need N) +C + IBAL = 1 + CALL DGEBAL( BALANC, N, A, LDA, ILO, IHI, DWORK( IBAL ), IERR ) +C +C Reduce to upper Hessenberg form. +C (Workspace: need 3*N, prefer 2*N+N*NB) +C + ITAU = IBAL + N + JWORK = ITAU + N + CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK( ITAU ), DWORK( JWORK ), + $ LDWORK-JWORK+1, IERR ) +C +C Compute right eigenvectors of T. +C Copy Householder vectors to Q. +C + CALL DLACPY( 'Lower', N, N, A, LDA, Q, LDQ ) +C +C Generate orthogonal matrix in Q. +C (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) +C + CALL DORGHR( N, ILO, IHI, Q, LDQ, DWORK( ITAU ), DWORK( JWORK ), + $ LDWORK-JWORK+1, IERR ) +C +C Perform QR iteration, accumulating Schur vectors in Q. +C (Workspace: need N+1, prefer N+HSDWOR (see comments) ) +C + JWORK = ITAU + CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, Q, LDQ, + $ DWORK( JWORK ), LDWORK-JWORK+1, INFO ) +C +C If INFO > 0 from DHSEQR, then quit. +C + IF( INFO.GT.0 ) + $ GO TO 10 +C +C Compute right eigenvectors of T in R. +C (Workspace: need 4*N) +C + CALL DTREVC( 'Right', 'All', SELECT, N, A, LDA, DUM, 1, R, LDR, N, + $ NOUT, DWORK( JWORK ), IERR ) +C +C Undo scaling if necessary. +C + 10 CONTINUE + IF( SCALEA ) THEN + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ), + $ MAX( N-INFO, 1 ), IERR ) + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ), + $ MAX( N-INFO, 1 ), IERR ) + IF( INFO.GT.0 ) THEN + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N, + $ IERR ) + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N, + $ IERR ) + END IF + END IF +C + IF ( SCALE ) THEN + DO 20 K = N, 1, -1 + DWORK( K+1 ) = DWORK( K ) + 20 CONTINUE + END IF + DWORK( 1 ) = MAXWRK +C + RETURN +C *** Last line of MB05MY *** + END diff --git a/mex/sources/libslicot/MB05ND.f b/mex/sources/libslicot/MB05ND.f new file mode 100644 index 000000000..37bbe61a6 --- /dev/null +++ b/mex/sources/libslicot/MB05ND.f @@ -0,0 +1,377 @@ + SUBROUTINE MB05ND( N, DELTA, A, LDA, EX, LDEX, EXINT, LDEXIN, + $ TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute +C +C (a) F(delta) = exp(A*delta) and +C +C (b) H(delta) = Int[F(s) ds] from s = 0 to s = delta, +C +C where A is a real N-by-N matrix and delta is a scalar value. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C DELTA (input) DOUBLE PRECISION +C The scalar value delta of the problem. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C matrix A of the problem. (Array A need not be set if +C DELTA = 0.) +C +C LDA INTEGER +C The leading dimension of array A. LDA >= max(1,N). +C +C EX (output) DOUBLE PRECISION array, dimension (LDEX,N) +C The leading N-by-N part of this array contains an +C approximation to F(delta). +C +C LDEX INTEGER +C The leading dimension of array EX. LDEX >= MAX(1,N). +C +C EXINT (output) DOUBLE PRECISION array, dimension (LDEXIN,N) +C The leading N-by-N part of this array contains an +C approximation to H(delta). +C +C LDEXIN INTEGER +C The leading dimension of array EXINT. LDEXIN >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the order of the +C Pade approximation to H(t), where t is a scale factor +C determined by the routine. A reasonable value for TOL may +C be SQRT(EPS), where EPS is the machine precision (see +C LAPACK Library routine DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N*(N+1)). +C For optimum performance LDWORK should be larger (2*N*N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, the (i,i) element of the denominator of +C the Pade approximation is zero, so the denominator +C is exactly singular; +C = N+1: if DELTA = (delta * frobenius norm of matrix A) is +C probably too large to permit meaningful computation. +C That is, DELTA > SQRT(BIG), where BIG is a +C representable number near the overflow threshold of +C the machine (see LAPACK Library Routine DLAMCH). +C +C METHOD +C +C This routine uses a Pade approximation to H(t) for some small +C value of t (where 0 < t <= delta) and then calculates F(t) from +C H(t). Finally, the results are re-scaled to give F(delta) and +C H(delta). For a detailed description of the implementation of this +C algorithm see [1]. +C +C REFERENCES +C +C [1] Benson, C.J. +C The numerical evaluation of the matrix exponential and its +C integral. +C Report 82/03, Control Systems Research Group, +C School of Electronic Engineering and Computer +C Science, Kingston Polytechnic, January 1982. +C +C [2] Ward, R.C. +C Numerical computation of the matrix exponential with accuracy +C estimate. +C SIAM J. Numer. Anal., 14, pp. 600-610, 1977. +C +C [3] Moler, C.B. and Van Loan, C.F. +C Nineteen Dubious Ways to Compute the Exponential of a Matrix. +C SIAM Rev., 20, pp. 801-836, 1978. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Supersedes Release 2.0 routine MB05BD by C.J. Benson, Kingston +C Polytechnic, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Continuous-time system, matrix algebra, matrix exponential, +C matrix operations, Pade approximation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, ONE64, THREE, FOUR8 + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, + $ ONE64 = 1.64D0, THREE = 3.0D0, FOUR8 = 4.8D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDEX, LDEXIN, LDWORK, N + DOUBLE PRECISION DELTA, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), EX(LDEX,*), EXINT(LDEXIN,*) +C .. Local Scalars .. + INTEGER I, I2IQ1, IJ, IQ, J, JSCAL, KK, L, NN + DOUBLE PRECISION COEFFD, COEFFN, DELSC, EPS, ERR, F2IQ1, + $ FNORM, FNORM2, QMAX, SMALL +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGESV, DLACPY, + $ DLASET, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, EXP, MAX, MOD, SQRT +C .. Executable Statements .. +C + INFO = 0 + NN = N*N +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDEX.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDEXIN.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDWORK.LT.MAX( 1, NN + N ) ) THEN + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB05ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + DWORK(1) = ONE + IF ( N.EQ.0 ) + $ RETURN +C + CALL DLASET( 'Full', N, N, ZERO, ZERO, EX, LDEX ) + CALL DLASET( 'Full', N, N, ZERO, ZERO, EXINT, LDEXIN ) +C + IF ( DELTA.EQ.ZERO ) THEN + CALL DLASET( 'Upper', N, N, ZERO, ONE, EX, LDEX ) + RETURN + END IF +C + IF ( N.EQ.1 ) THEN + EX(1,1) = EXP( DELTA*A(1,1) ) + IF ( A(1,1).EQ.ZERO ) THEN + EXINT(1,1) = DELTA + ELSE + EXINT(1,1) = ( ( ONE/A(1,1) )*EX(1,1) ) - ( ONE/A(1,1) ) + END IF + RETURN + END IF +C +C Set some machine parameters. +C + EPS = DLAMCH( 'Epsilon' ) + SMALL = DLAMCH( 'Safe minimum' )/EPS +C +C First calculate the Frobenius norm of A, and the scaling factor. +C + FNORM = DELTA*DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) +C + IF ( FNORM.GT.SQRT( ONE/SMALL ) ) THEN + INFO = N + 1 + RETURN + END IF +C + JSCAL = 0 + DELSC = DELTA +C WHILE ( FNORM >= HALF ) DO + 20 CONTINUE + IF ( FNORM.GE.HALF ) THEN + JSCAL = JSCAL + 1 + DELSC = DELSC*HALF + FNORM = FNORM*HALF + GO TO 20 + END IF +C END WHILE 20 +C +C Calculate the order of the Pade approximation needed to satisfy +C the requested relative error TOL. +C + FNORM2 = FNORM**2 + IQ = 1 + QMAX = FNORM/THREE + ERR = DELTA/DELSC*FNORM2**2/FOUR8 +C WHILE ( ERR > TOL*( 2*IQ + 3 - FNORM )/1.64 and QMAX >= EPS ) DO + 40 CONTINUE + IF ( ERR.GT.TOL*( DBLE( 2*IQ + 3 ) - FNORM )/ONE64 ) THEN + IQ = IQ + 1 + QMAX = QMAX*DBLE( IQ + 1 )*FNORM/DBLE( 2*IQ*( 2*IQ + 1 ) ) + IF ( QMAX.GE.EPS ) THEN + ERR = ERR*FNORM2*DBLE( 2*IQ + 5 )/DBLE( ( 2*IQ + 3 )**2 + $ *( 2*IQ + 4 ) ) + GO TO 40 + END IF + END IF +C END WHILE 40 +C +C Initialise DWORK (to contain succesive powers of A), +C EXINT (to contain the numerator) and +C EX (to contain the denominator). +C + I2IQ1 = 2*IQ + 1 + F2IQ1 = DBLE( I2IQ1 ) + COEFFD = -DBLE( IQ )/F2IQ1 + COEFFN = HALF/F2IQ1 + IJ = 1 +C + DO 80 J = 1, N +C + DO 60 I = 1, N + DWORK(IJ) = DELSC*A(I,J) + EXINT(I,J) = COEFFN*DWORK(IJ) + EX(I,J) = COEFFD*DWORK(IJ) + IJ = IJ + 1 + 60 CONTINUE +C + EXINT(J,J) = EXINT(J,J) + ONE + EX(J,J) = EX(J,J) + ONE + 80 CONTINUE +C + DO 140 KK = 2, IQ +C +C Calculate the next power of A*DELSC, and update the numerator +C and denominator. +C + COEFFD = -COEFFD*DBLE( IQ+1-KK )/DBLE( KK*( I2IQ1+1-KK ) ) + IF ( MOD( KK, 2 ).EQ.0 ) THEN + COEFFN = COEFFD/DBLE( KK + 1 ) + ELSE + COEFFN = -COEFFD/DBLE( I2IQ1 - KK ) + END IF + IJ = 1 +C + IF ( LDWORK.GE.2*NN ) THEN +C +C Enough space for a BLAS 3 calculation. +C + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, DELSC, + $ A, LDA, DWORK, N, ZERO, DWORK(NN+1), N ) + CALL DCOPY( NN, DWORK(NN+1), 1, DWORK, 1 ) +C + DO 100 J = 1, N + CALL DAXPY( N, COEFFN, DWORK(IJ), 1, EXINT(1,J), 1 ) + CALL DAXPY( N, COEFFD, DWORK(IJ), 1, EX(1,J), 1 ) + IJ = IJ + N + 100 CONTINUE +C + ELSE +C +C Not enough space for a BLAS 3 calculation. Use BLAS 2. +C + DO 120 J = 1, N + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, DWORK(IJ), + $ 1, ZERO, DWORK(NN+1), 1 ) + CALL DCOPY( N, DWORK(NN+1), 1, DWORK(IJ), 1 ) + CALL DSCAL( N, DELSC, DWORK(IJ), 1 ) + CALL DAXPY( N, COEFFN, DWORK(IJ), 1, EXINT(1,J), 1 ) + CALL DAXPY( N, COEFFD, DWORK(IJ), 1, EX(1,J), 1 ) + IJ = IJ + N + 120 CONTINUE +C + END IF + 140 CONTINUE +C +C We now have numerator in EXINT, denominator in EX. +C +C Solve the set of N systems of linear equations for the columns of +C EXINT using the LU factorization of EX. +C + CALL DGESV( N, N, EX, LDEX, IWORK, EXINT, LDEXIN, INFO ) + IF ( INFO.NE.0 ) + $ RETURN +C +C Now we can form EX from EXINT using the formula: +C EX = EXINT * A + I +C + DO 160 J = 1, N + CALL DSCAL( N, DELSC, EXINT(1,J), 1 ) + 160 CONTINUE +C + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, EXINT, + $ LDEXIN, A, LDA, ZERO, EX, LDEX ) +C + DO 180 J = 1, N + EX(J,J) = EX(J,J) + ONE + 180 CONTINUE +C +C EX and EXINT have been evaluated at DELSC, so the results +C must be re-scaled to give the function values at DELTA. +C +C EXINT(2t) = EXINT(t) * ^ EX(t) + I [ +C EX(2t) = EX(t) * EX(t) +C +C DWORK is used to accumulate products. +C + DO 200 L = 1, JSCAL + CALL DLACPY( 'Full', N, N, EXINT, LDEXIN, DWORK, N ) + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, + $ DWORK, N, EX, LDEX, ONE, EXINT, LDEXIN ) + CALL DLACPY( 'Full', N, N, EX, LDEX, DWORK, N ) + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, + $ DWORK, N, DWORK, N, ZERO, EX, LDEX ) + 200 CONTINUE +C + DWORK(1) = 2*NN + RETURN +C *** Last line of MB05ND *** + END diff --git a/mex/sources/libslicot/MB05OD.f b/mex/sources/libslicot/MB05OD.f new file mode 100644 index 000000000..ec87a2ee7 --- /dev/null +++ b/mex/sources/libslicot/MB05OD.f @@ -0,0 +1,574 @@ + SUBROUTINE MB05OD( BALANC, N, NDIAG, DELTA, A, LDA, MDIG, IDIG, + $ IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute exp(A*delta) where A is a real N-by-N matrix and delta +C is a scalar value. The routine also returns the minimal number of +C accurate digits in the 1-norm of exp(A*delta) and the number of +C accurate digits in the 1-norm of exp(A*delta) at 95% confidence +C level. +C +C ARGUMENTS +C +C Mode Parameters +C +C BALANC CHARACTER*1 +C Specifies whether or not a balancing transformation (done +C by SLICOT Library routine MB04MD) is required, as follows: +C = 'N', do not use balancing; +C = 'S', use balancing (scaling). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C NDIAG (input) INTEGER +C The specified order of the diagonal Pade approximant. +C In the absence of further information NDIAG should +C be set to 9. NDIAG should not exceed 15. NDIAG >= 1. +C +C DELTA (input) DOUBLE PRECISION +C The scalar value delta of the problem. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On input, the leading N-by-N part of this array must +C contain the matrix A of the problem. (This is not needed +C if DELTA = 0.) +C On exit, if INFO = 0, the leading N-by-N part of this +C array contains the solution matrix exp(A*delta). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C MDIG (output) INTEGER +C The minimal number of accurate digits in the 1-norm of +C exp(A*delta). +C +C IDIG (output) INTEGER +C The number of accurate digits in the 1-norm of +C exp(A*delta) at 95% confidence level. +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= N*(2*N+NDIAG+1)+NDIAG, if N > 1. +C LDWORK >= 1, if N <= 1. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: if MDIG = 0 and IDIG > 0, warning for possible +C inaccuracy (the exponential has been computed); +C = 2: if MDIG = 0 and IDIG = 0, warning for severe +C inaccuracy (the exponential has been computed); +C = 3: if balancing has been requested, but it failed to +C reduce the matrix norm and was not actually used. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the norm of matrix A*delta (after a possible +C balancing) is too large to obtain an accurate +C result; +C = 2: if the coefficient matrix (the denominator of the +C Pade approximant) is exactly singular; try a +C different value of NDIAG; +C = 3: if the solution exponential would overflow, possibly +C due to a too large value DELTA; the calculations +C stopped prematurely. This error is not likely to +C appear. +C +C METHOD +C +C The exponential of the matrix A is evaluated from a diagonal Pade +C approximant. This routine is a modification of the subroutine +C PADE, described in reference [1]. The routine implements an +C algorithm which exploits the identity +C +C (exp[(2**-m)*A]) ** (2**m) = exp(A), +C +C where m is an integer determined by the algorithm, to improve the +C accuracy for matrices with large norms. +C +C REFERENCES +C +C [1] Ward, R.C. +C Numerical computation of the matrix exponential with accuracy +C estimate. +C SIAM J. Numer. Anal., 14, pp. 600-610, 1977. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB05CD by T.W.C. Williams, Kingston +C Polytechnic, March 1982. +C +C REVISIONS +C +C June 14, 1997, April 25, 2003, December 12, 2004. +C +C KEYWORDS +C +C Continuous-time system, matrix algebra, matrix exponential, +C matrix operations, Pade approximation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, EIGHT, TEN, TWELVE, + $ NINTEN, TWO4, FOUR7, TWOHND + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, + $ TWO = 2.0D0, FOUR = 4.0D0, EIGHT = 8.0D0, + $ TEN = 10.0D0, TWELVE = 12.0D0, + $ NINTEN = 19.0D0, TWO4 = 24.0D0, + $ FOUR7 = 47.0D0, TWOHND = 200.0D0 ) +C .. Scalar Arguments .. + CHARACTER BALANC + INTEGER IDIG, INFO, IWARN, LDA, LDWORK, MDIG, N, + $ NDIAG + DOUBLE PRECISION DELTA +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), DWORK(*) +C .. Local Scalars .. + LOGICAL LBALS + CHARACTER ACTBAL + INTEGER BASE, I, IFAIL, IJ, IK, IM1, J, JWORA1, JWORA2, + $ JWORA3, JWORV1, JWORV2, K, M, MPOWER, NDAGM1, + $ NDAGM2, NDEC, NDECM1 + DOUBLE PRECISION ANORM, AVGEV, BD, BIG, EABS, EAVGEV, EMNORM, + $ EPS, FACTOR, FN, GN, MAXRED, OVRTH2, OVRTHR, P, + $ RERL, RERR, S, SD2, SIZE, SMALL, SS, SUM2D, + $ TEMP, TMP1, TR, U, UNDERF, VAR, VAREPS, XN +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DASUM, DLAMCH, DLANGE, DNRM2 + EXTERNAL DASUM, DLAMCH, DLANGE, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DGETRF, DGETRS, DLACPY, + $ DLASCL, DLASET, DSCAL, MB04MD, MB05OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, EXP, INT, LOG, LOG10, MAX, MIN, MOD, SQRT +C .. Executable Statements .. +C + IWARN = 0 + INFO = 0 + LBALS = LSAME( BALANC, 'S' ) +C +C Test the input scalar arguments. +C + IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LBALS ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NDIAG.LT.1 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDWORK.LT.1 .OR. + $ ( LDWORK.LT.N*( 2*N + NDIAG + 1 ) + NDIAG .AND. N.GT.1 ) + $ ) THEN + INFO = -11 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB05OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + EPS = DLAMCH( 'Epsilon' ) + NDEC = INT( LOG10( ONE/EPS ) + ONE ) +C + IF ( N.EQ.0 ) THEN + MDIG = NDEC + IDIG = NDEC + RETURN + END IF +C +C Set some machine parameters. +C + BASE = DLAMCH( 'Base' ) + NDECM1 = NDEC - 1 + UNDERF = DLAMCH( 'Underflow' ) + OVRTHR = DLAMCH( 'Overflow' ) + OVRTH2 = SQRT( OVRTHR ) +C + IF ( DELTA.EQ.ZERO ) THEN +C +C The DELTA = 0 case. +C + CALL DLASET( 'Full', N, N, ZERO, ONE, A, LDA ) + MDIG = NDECM1 + IDIG = NDECM1 + RETURN + END IF +C + IF ( N.EQ.1 ) THEN +C +C The 1-by-1 case. +C + A(1,1) = EXP( A(1,1)*DELTA ) + MDIG = NDECM1 + IDIG = NDECM1 + RETURN + END IF +C +C Set pointers for the workspace. +C + JWORA1 = 1 + JWORA2 = JWORA1 + N*N + JWORA3 = JWORA2 + N*NDIAG + JWORV1 = JWORA3 + N*N + JWORV2 = JWORV1 + N +C +C Compute Pade coefficients in DWORK(JWORV2:JWORV2+NDIAG-1). +C + DWORK(JWORV2) = HALF +C + DO 20 I = 2, NDIAG + IM1 = I - 1 + DWORK(JWORV2+IM1) = DWORK(JWORV2+I-2)*DBLE( NDIAG - IM1 )/ + $ DBLE( I*( 2*NDIAG - IM1 ) ) + 20 CONTINUE +C + VAREPS = EPS**2*( ( DBLE( BASE )**2 - ONE )/ + $ ( TWO4*LOG( DBLE( BASE ) ) ) ) + XN = DBLE( N ) + TR = ZERO +C +C Apply a translation with the mean of the eigenvalues of A*DELTA. +C + DO 40 I = 1, N + CALL DSCAL( N, DELTA, A(1,I), 1 ) + TR = TR + A(I,I) + 40 CONTINUE +C + AVGEV = TR/XN + IF ( AVGEV.GT.LOG( OVRTHR ) .OR. AVGEV.LT.LOG( UNDERF ) ) + $ AVGEV = ZERO + IF ( AVGEV.NE.ZERO ) THEN + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) +C + DO 60 I = 1, N + A(I,I) = A(I,I) - AVGEV + 60 CONTINUE +C + TEMP = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) + IF ( TEMP.GT.HALF*ANORM ) THEN +C + DO 80 I = 1, N + A(I,I) = A(I,I) + AVGEV + 80 CONTINUE +C + AVGEV = ZERO + END IF + END IF + ACTBAL = BALANC + IF ( LBALS ) THEN +C +C Balancing (scaling) has been requested. First, save A. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(JWORA1), N ) + MAXRED = TWOHND + CALL MB04MD( N, MAXRED, A, LDA, DWORK(JWORV1), INFO ) + IF ( MAXRED.LT.ONE ) THEN +C +C Recover the matrix and reset DWORK(JWORV1,...,JWORV1+N-1) +C to 1, as no reduction of the norm occured (unlikely event). +C + CALL DLACPY( 'Full', N, N, DWORK(JWORA1), N, A, LDA ) + ACTBAL = 'N' + DWORK(JWORV1) = ONE + CALL DCOPY( N-1, DWORK(JWORV1), 0, DWORK(JWORV1+1), 1 ) + IWARN = 3 + END IF + END IF +C +C Scale the matrix by 2**(-M), where M is the minimum integer +C so that the resulted matrix has the 1-norm less than 0.5. +C + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) + M = 0 + IF ( ANORM.GE.HALF ) THEN + MPOWER = INT( LOG( OVRTHR )/LOG( TWO ) ) + M = INT( LOG( ANORM )/LOG( TWO ) ) + 1 + IF ( M.GT.MPOWER ) THEN +C +C Error return: The norm of A*DELTA is too large. +C + INFO = 1 + RETURN + END IF + FACTOR = TWO**M + IF ( M+1.LT.MPOWER ) THEN + M = M + 1 + FACTOR = FACTOR*TWO + END IF +C + DO 120 I = 1, N + CALL DSCAL( N, ONE/FACTOR, A(1,I), 1 ) + 120 CONTINUE +C + END IF + NDAGM1 = NDIAG - 1 + NDAGM2 = NDAGM1 - 1 + IJ = 0 +C +C Compute the factors of the diagonal Pade approximant. +C The loop 200 takes the accuracy requirements into account: +C Pade coefficients decrease with K, so the calculations should +C be performed in backward order, one column at a time. +C (A BLAS 3 implementation in forward order, using DGEMM, could +C possibly be less accurate.) +C + DO 200 J = 1, N + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, A(1,J), 1, ZERO, + $ DWORK(JWORA2), 1 ) + IK = 0 +C + DO 140 K = 1, NDAGM2 + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, + $ DWORK(JWORA2+IK), 1, ZERO, DWORK(JWORA2+IK+N), + $ 1 ) + IK = IK + N + 140 CONTINUE +C + DO 180 I = 1, N + S = ZERO + U = ZERO + IK = NDAGM2*N + I - 1 +C + DO 160 K = NDAGM1, 1, -1 + P = DWORK(JWORV2+K)*DWORK(JWORA2+IK) + IK = IK - N + S = S + P + IF ( MOD( K+1, 2 ).EQ.0 ) THEN + U = U + P + ELSE + U = U - P + END IF + 160 CONTINUE +C + P = DWORK(JWORV2)*A(I,J) + S = S + P + U = U - P + IF ( I.EQ.J ) THEN + S = S + ONE + U = U + ONE + END IF + DWORK(JWORA3+IJ) = S + DWORK(JWORA1+IJ) = U + IJ = IJ + 1 + 180 CONTINUE +C + 200 CONTINUE +C +C Compute the exponential of the scaled matrix, using diagonal Pade +C approximants. As, in theory [1], the denominator of the Pade +C approximant should be very well conditioned, no condition estimate +C is computed. +C + CALL DGETRF( N, N, DWORK(JWORA1), N, IWORK, IFAIL ) + IF ( IFAIL.GT.0 ) THEN +C +C Error return: The matrix is exactly singular. +C + INFO = 2 + RETURN + END IF +C + CALL DLACPY( 'Full', N, N, DWORK(JWORA3), N, A, LDA ) + CALL DGETRS( 'No transpose', N, N, DWORK(JWORA1), N, IWORK, A, + $ LDA, IFAIL ) +C +C Prepare for the calculation of the accuracy estimates. +C Note that ANORM here is in the range [1, e]. +C + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) + IF ( ANORM.GE.ONE ) THEN + EABS = ( NINTEN*XN + FOUR7 )*( EPS*ANORM ) + ELSE + EABS = ( ( NINTEN*XN + FOUR7 )*EPS )*ANORM + END IF + IF ( M.NE.0 ) THEN + VAR = XN*VAREPS + FN = ( FOUR*XN )/( ( XN + TWO )*( XN + ONE ) ) + GN = ( ( TWO*XN + TEN )*XN - FOUR )/( ( ( XN + TWO )**2 ) + $ *( ( XN + ONE )**2 ) ) +C +C Square-up the computed exponential matrix M times, with caution +C for avoiding overflows. +C + DO 220 K = 1, M + IF ( ANORM.GT.OVRTH2 ) THEN +C +C The solution could overflow. +C + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, + $ ONE/ANORM, A, LDA, A, LDA, ZERO, + $ DWORK(JWORA1), N ) + S = DLANGE( '1-norm', N, N, DWORK(JWORA1), N, + $ DWORK(JWORA1) ) + IF ( ANORM.LE.OVRTHR/S ) THEN + CALL DLASCL( 'General', N, N, ONE, ANORM, N, N, + $ DWORK(JWORA1), N, INFO ) + TEMP = OVRTHR + ELSE +C +C Error return: The solution would overflow. +C This will not happen on most machines, due to the +C selection of M. +C + INFO = 3 + RETURN + END IF + ELSE + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, + $ A, LDA, A, LDA, ZERO, DWORK(JWORA1), N ) + TEMP = ANORM**2 + END IF + IF ( EABS.LT.ONE ) THEN + EABS = ( TWO*ANORM + EABS )*EABS + XN*( EPS*TEMP ) + ELSE IF ( EABS.LT.SQRT( ONE - XN*EPS + OVRTHR/TEMP )*ANORM - + $ ANORM ) THEN + EABS = XN*( EPS*TEMP ) + TWO*( ANORM*EABS ) + EABS**2 + ELSE + EABS = OVRTHR + END IF +C + TMP1 = FN*VAR + GN*( TEMP*VAREPS ) + IF ( TMP1.GT.OVRTHR/TEMP ) THEN + VAR = OVRTHR + ELSE + VAR = TMP1*TEMP + END IF +C + CALL DLACPY( 'Full', N, N, DWORK(JWORA1), N, A, LDA ) + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) + 220 CONTINUE +C + ELSE + VAR = ( TWELVE*XN )*VAREPS + END IF +C +C Apply back transformations, if balancing was effectively used. +C + CALL MB05OY( ACTBAL, N, 1, N, A, LDA, DWORK(JWORV1), INFO ) + EAVGEV = EXP( AVGEV ) + EMNORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) +C +C Compute auxiliary quantities needed for the accuracy estimates. +C + BIG = ONE + SMALL = ONE + IF ( LBALS ) THEN +C +C Compute norms of the diagonal scaling matrix and its inverse. +C + DO 240 I = 1, N + U = DWORK(JWORV1+I-1) + IF ( BIG.LT.U ) BIG = U + IF ( SMALL.GT.U ) SMALL = U + 240 CONTINUE +C + SUM2D = DNRM2( N, DWORK(JWORV1), 1 ) + ELSE + SUM2D = SQRT( XN ) + END IF +C +C Update the exponential for the initial translation, and update the +C auxiliary quantities needed for the accuracy estimates. +C + SD2 = SQRT( EIGHT*XN*VAREPS )*ANORM + BD = SQRT( VAR ) + SS = MAX( BD, SD2 ) + BD = MIN( BD, SD2 ) + SD2 = SS*SQRT( ONE + ( BD/SS )**2 ) + IF ( SD2.LE.ONE ) THEN + SD2 = ( TWO/XN )*SUM2D*SD2 + ELSE IF ( SUM2D/XN.LT.OVRTHR/TWO/SD2 ) THEN + SD2 = ( TWO/XN )*SUM2D*SD2 + ELSE + SD2 = OVRTHR + END IF + IF ( LBALS ) THEN + SIZE = ZERO + ELSE + IF ( SD2.LT.OVRTHR - EMNORM ) THEN + SIZE = EMNORM + SD2 + ELSE + SIZE = OVRTHR + END IF + END IF +C + DO 260 J = 1, N + SS = DASUM( N, A(1,J), 1 ) + CALL DSCAL( N, EAVGEV, A(1,J), 1 ) + IF ( LBALS ) THEN + BD = DWORK(JWORV1+J-1) + SIZE = MAX( SIZE, SS + SD2/BD ) + END IF + 260 CONTINUE +C +C Set the accuracy estimates and warning errors, if any. +C + RERR = LOG10( BIG ) + LOG10( EABS ) - LOG10( SMALL ) - + $ LOG10( EMNORM ) - LOG10( EPS ) + IF ( SIZE.GT.EMNORM ) THEN + RERL = LOG10( ( SIZE/EMNORM - ONE )/EPS ) + ELSE + RERL = ZERO + END IF + MDIG = MIN( NDEC - INT( RERR + HALF ), NDECM1 ) + IDIG = MIN( NDEC - INT( RERL + HALF ), NDECM1 ) +C + IF ( MDIG.LE.0 ) THEN + MDIG = 0 + IWARN = 1 + END IF + IF ( IDIG.LE.0 ) THEN + IDIG = 0 + IWARN = 2 + END IF +C + RETURN +C *** Last line of MB05OD *** + END diff --git a/mex/sources/libslicot/MB05OY.f b/mex/sources/libslicot/MB05OY.f new file mode 100644 index 000000000..a73de7039 --- /dev/null +++ b/mex/sources/libslicot/MB05OY.f @@ -0,0 +1,179 @@ + SUBROUTINE MB05OY( JOB, N, LOW, IGH, A, LDA, SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To restore a matrix after it has been transformed by applying +C balancing transformations (permutations and scalings), as +C determined by LAPACK Library routine DGEBAL. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the type of backward transformation required, +C as follows: +C = 'N', do nothing, return immediately; +C = 'P', do backward transformation for permutation only; +C = 'S', do backward transformation for scaling only; +C = 'B', do backward transformations for both permutation +C and scaling. +C JOB must be the same as the argument JOB supplied +C to DGEBAL. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C LOW (input) INTEGER +C IGH (input) INTEGER +C The integers LOW and IGH determined by DGEBAL. +C 1 <= LOW <= IGH <= N, if N > 0; LOW=1 and IGH=0, if N=0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix to be back-transformed. +C On exit, the leading N-by-N part of this array contains +C the transformed matrix. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C SCALE (input) DOUBLE PRECISION array, dimension (N) +C Details of the permutation and scaling factors, as +C returned by DGEBAL. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Let P be a permutation matrix, and D a diagonal matrix of scaling +C factors, both of order N. The routine computes +C -1 +C A <-- P D A D P'. +C +C where the permutation and scaling factors are encoded in the +C array SCALE. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires O(N ) operations. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB05CY. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations. +C +C ****************************************************************** +C + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER IGH, INFO, LDA, LOW, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), SCALE(*) +C .. Local Scalars .. + INTEGER I, II, J, K +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DSCAL, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. + $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 )THEN + INFO = -2 + ELSE IF( LOW.LT.1 .OR. LOW.GT.MAX( 1, N ) ) THEN + INFO = -3 + ELSE IF( IGH.LT.MIN( LOW, N ) .OR. IGH.GT.N ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB05OY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. LSAME( JOB, 'N' ) ) + $ RETURN +C + IF ( .NOT.LSAME( JOB, 'P' ) .AND. IGH.NE.LOW ) THEN +C + DO 20 I = LOW, IGH + CALL DSCAL( N, SCALE(I), A(I,1), LDA ) + 20 CONTINUE +C + DO 40 J = LOW, IGH + CALL DSCAL( N, ONE/SCALE(J), A(1,J), 1 ) + 40 CONTINUE +C + END IF +C + IF( .NOT.LSAME( JOB, 'S' ) ) THEN +C + DO 60 II = 1, N + I = II + IF ( I.LT.LOW .OR. I.GT.IGH ) THEN + IF ( I.LT.LOW ) I = LOW - II + K = SCALE(I) + IF ( K.NE.I ) THEN + CALL DSWAP( N, A(I,1), LDA, A(K,1), LDA ) + CALL DSWAP( N, A(1,I), 1, A(1,K), 1 ) + END IF + END IF + 60 CONTINUE +C + END IF +C + RETURN +C *** Last line of MB05OY *** + END diff --git a/mex/sources/libslicot/MB3OYZ.f b/mex/sources/libslicot/MB3OYZ.f new file mode 100644 index 000000000..054e570ad --- /dev/null +++ b/mex/sources/libslicot/MB3OYZ.f @@ -0,0 +1,395 @@ + SUBROUTINE MB3OYZ( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, + $ TAU, DWORK, ZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a rank-revealing QR factorization of a complex general +C M-by-N matrix A, which may be rank-deficient, and estimate its +C effective rank using incremental condition estimation. +C +C The routine uses a truncated QR factorization with column pivoting +C [ R11 R12 ] +C A * P = Q * R, where R = [ ], +C [ 0 R22 ] +C with R11 defined as the largest leading upper triangular submatrix +C whose estimated condition number is less than 1/RCOND. The order +C of R11, RANK, is the effective rank of A. Condition estimation is +C performed during the QR factorization process. Matrix R22 is full +C (but of small norm), or empty. +C +C MB3OYZ does not perform any scaling of the matrix A. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) COMPLEX*16 array, dimension ( LDA, N ) +C On entry, the leading M-by-N part of this array must +C contain the given matrix A. +C On exit, the leading RANK-by-RANK upper triangular part +C of A contains the triangular factor R11, and the elements +C below the diagonal in the first RANK columns, with the +C array TAU, represent the unitary matrix Q as a product +C of RANK elementary reflectors. +C The remaining N-RANK columns contain the result of the +C QR factorization process used. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of A, which +C is defined as the order of the largest leading triangular +C submatrix R11 in the QR factorization with pivoting of A, +C whose estimated condition number is less than 1/RCOND. +C 0 <= RCOND <= 1. +C NOTE that when SVLMAX > 0, the estimated rank could be +C less than that defined above (see SVLMAX). +C +C SVLMAX (input) DOUBLE PRECISION +C If A is a submatrix of another matrix B, and the rank +C decision should be related to that matrix, then SVLMAX +C should be an estimate of the largest singular value of B +C (for instance, the Frobenius norm of B). If this is not +C the case, the input value SVLMAX = 0 should work. +C SVLMAX >= 0. +C +C RANK (output) INTEGER +C The effective (estimated) rank of A, i.e., the order of +C the submatrix R11. +C +C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) +C The estimates of some of the singular values of the +C triangular factor R: +C SVAL(1): largest singular value of R(1:RANK,1:RANK); +C SVAL(2): smallest singular value of R(1:RANK,1:RANK); +C SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1), +C if RANK < MIN( M, N ), or of R(1:RANK,1:RANK), +C otherwise. +C If the triangular factorization is a rank-revealing one +C (which will be the case if the leading columns were well- +C conditioned), then SVAL(1) will also be an estimate for +C the largest singular value of A, and SVAL(2) and SVAL(3) +C will be estimates for the RANK-th and (RANK+1)-st singular +C values of A, respectively. +C By examining these values, one can confirm that the rank +C is well defined with respect to the chosen value of RCOND. +C The ratio SVAL(1)/SVAL(2) is an estimate of the condition +C number of R(1:RANK,1:RANK). +C +C JPVT (output) INTEGER array, dimension ( N ) +C If JPVT(i) = k, then the i-th column of A*P was the k-th +C column of A. +C +C TAU (output) COMPLEX*16 array, dimension ( MIN( M, N ) ) +C The leading RANK elements of TAU contain the scalar +C factors of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension ( 2*N ) +C +C ZWORK COMPLEX*16 array, dimension ( 3*N-1 ) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a truncated QR factorization with column +C pivoting of A, A * P = Q * R, with R defined above, and, +C during this process, finds the largest leading submatrix whose +C estimated condition number is less than 1/RCOND, taking the +C possible positive value of SVLMAX into account. This is performed +C using the LAPACK incremental condition estimation scheme and a +C slightly modified rank decision test. The factorization process +C stops when RANK has been determined. +C +C The matrix Q is represented as a product of elementary reflectors +C +C Q = H(1) H(2) . . . H(k), where k = rank <= min(m,n). +C +C Each H(i) has the form +C +C H = I - tau * v * v' +C +C where tau is a complex scalar, and v is a complex vector with +C v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in +C A(i+1:m,i), and tau in TAU(i). +C +C The matrix P is represented in jpvt as follows: If +C jpvt(j) = i +C then the jth column of P is the ith canonical unit vector. +C +C REFERENCES +C +C [1] Bischof, C.H. and P. Tang. +C Generalizing Incremental Condition Estimation. +C LAPACK Working Notes 32, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-132, +C May 1991. +C +C [2] Bischof, C.H. and P. Tang. +C Robust Incremental Condition Estimation. +C LAPACK Working Notes 33, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-133, +C May 1991. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalue problem, matrix operations, unitary transformation, +C singular values. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ZERO, ONE, P05 + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, M, N, RANK + DOUBLE PRECISION RCOND, SVLMAX +C .. Array Arguments .. + INTEGER JPVT( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), ZWORK( * ) + DOUBLE PRECISION DWORK( * ), SVAL( 3 ) +C .. +C .. Local Scalars .. + INTEGER I, ISMAX, ISMIN, ITEMP, J, MN, PVT + COMPLEX*16 AII, C1, C2, S1, S2 + DOUBLE PRECISION SMAX, SMAXPR, SMIN, SMINPR, TEMP, TEMP2 +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DZNRM2 + EXTERNAL DZNRM2, IDAMAX +C .. External Subroutines .. + EXTERNAL XERBLA, ZLAIC1, ZLARF, ZLARFG, ZSCAL, ZSWAP +C .. Intrinsic Functions .. + INTRINSIC ABS, DCONJG, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN + INFO = -5 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB3OYZ', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + MN = MIN( M, N ) + IF( MN.EQ.0 ) THEN + RANK = 0 + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF +C + ISMIN = 1 + ISMAX = ISMIN + N +C +C Initialize partial column norms and pivoting vector. The first n +C elements of DWORK store the exact column norms. +C + DO 10 I = 1, N + DWORK( I ) = DZNRM2( M, A( 1, I ), 1 ) + DWORK( N+I ) = DWORK( I ) + JPVT( I ) = I + 10 CONTINUE +C +C Compute factorization and determine RANK using incremental +C condition estimation. +C + RANK = 0 +C + 20 CONTINUE + IF( RANK.LT.MN ) THEN + I = RANK + 1 +C +C Determine ith pivot column and swap if necessary. +C + PVT = ( I-1 ) + IDAMAX( N-I+1, DWORK( I ), 1 ) +C + IF( PVT.NE.I ) THEN + CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( I ) + JPVT( I ) = ITEMP + DWORK( PVT ) = DWORK( I ) + DWORK( N+PVT ) = DWORK( N+I ) + END IF +C +C Save A(I,I) and generate elementary reflector H(i) +C such that H(i)'*[A(i,i);*] = [*;0]. +C + IF( I.LT.M ) THEN + AII = A( I, I ) + CALL ZLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) + ELSE + TAU( M ) = CZERO + END IF +C + IF( RANK.EQ.0 ) THEN +C +C Initialize; exit if matrix is zero (RANK = 0). +C + SMAX = ABS( A( 1, 1 ) ) + IF ( SMAX.EQ.ZERO ) THEN + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF + SMIN = SMAX + SMAXPR = SMAX + SMINPR = SMIN + C1 = CONE + C2 = CONE + ELSE +C +C One step of incremental condition estimation. +C + CALL ZLAIC1( IMIN, RANK, ZWORK( ISMIN ), SMIN, A( 1, I ), + $ A( I, I ), SMINPR, S1, C1 ) + CALL ZLAIC1( IMAX, RANK, ZWORK( ISMAX ), SMAX, A( 1, I ), + $ A( I, I ), SMAXPR, S2, C2 ) + END IF +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN +C +C Continue factorization, as rank is at least RANK. +C + IF( I.LT.N ) THEN +C +C Apply H(i)' to A(i:m,i+1:n) from the left. +C + AII = A( I, I ) + A( I, I ) = CONE + CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, + $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, + $ ZWORK( 2*N+1 ) ) + A( I, I ) = AII + END IF +C +C Update partial column norms. +C + DO 30 J = I + 1, N + IF( DWORK( J ).NE.ZERO ) THEN + TEMP = ONE - + $ ( ABS( A( I, J ) ) / DWORK( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = ONE + P05*TEMP* + $ ( DWORK( J ) / DWORK( N+J ) )**2 + IF( TEMP2.EQ.ONE ) THEN + IF( M-I.GT.0 ) THEN + DWORK( J ) = DZNRM2( M-I, A( I+1, J ), 1 ) + DWORK( N+J ) = DWORK( J ) + ELSE + DWORK( J ) = ZERO + DWORK( N+J ) = ZERO + END IF + ELSE + DWORK( J ) = DWORK( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE +C + DO 40 I = 1, RANK + ZWORK( ISMIN+I-1 ) = S1*ZWORK( ISMIN+I-1 ) + ZWORK( ISMAX+I-1 ) = S2*ZWORK( ISMAX+I-1 ) + 40 CONTINUE +C + ZWORK( ISMIN+RANK ) = C1 + ZWORK( ISMAX+RANK ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + GO TO 20 + END IF + END IF + END IF + END IF +C +C Restore the changed part of the (RANK+1)-th column and set SVAL. +C + IF ( RANK.LT.N ) THEN + IF ( I.LT.M ) THEN + CALL ZSCAL( M-I, -A( I, I )*TAU( I ), A( I+1, I ), 1 ) + A( I, I ) = AII + END IF + END IF + IF ( RANK.EQ.0 ) THEN + SMIN = ZERO + SMINPR = ZERO + END IF + SVAL( 1 ) = SMAX + SVAL( 2 ) = SMIN + SVAL( 3 ) = SMINPR +C + RETURN +C *** Last line of MB3OYZ *** + END diff --git a/mex/sources/libslicot/MB3PYZ.f b/mex/sources/libslicot/MB3PYZ.f new file mode 100644 index 000000000..119bca081 --- /dev/null +++ b/mex/sources/libslicot/MB3PYZ.f @@ -0,0 +1,398 @@ + SUBROUTINE MB3PYZ( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, + $ TAU, DWORK, ZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a rank-revealing RQ factorization of a complex general +C M-by-N matrix A, which may be rank-deficient, and estimate its +C effective rank using incremental condition estimation. +C +C The routine uses a truncated RQ factorization with row pivoting: +C [ R11 R12 ] +C P * A = R * Q, where R = [ ], +C [ 0 R22 ] +C with R22 defined as the largest trailing upper triangular +C submatrix whose estimated condition number is less than 1/RCOND. +C The order of R22, RANK, is the effective rank of A. Condition +C estimation is performed during the RQ factorization process. +C Matrix R11 is full (but of small norm), or empty. +C +C MB3PYZ does not perform any scaling of the matrix A. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) COMPLEX*16 array, dimension ( LDA, N ) +C On entry, the leading M-by-N part of this array must +C contain the given matrix A. +C On exit, the upper triangle of the subarray +C A(M-RANK+1:M,N-RANK+1:N) contains the RANK-by-RANK upper +C triangular matrix R22; the remaining elements in the last +C RANK rows, with the array TAU, represent the unitary +C matrix Q as a product of RANK elementary reflectors +C (see METHOD). The first M-RANK rows contain the result +C of the RQ factorization process used. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of A, which +C is defined as the order of the largest trailing triangular +C submatrix R22 in the RQ factorization with pivoting of A, +C whose estimated condition number is less than 1/RCOND. +C 0 <= RCOND <= 1. +C NOTE that when SVLMAX > 0, the estimated rank could be +C less than that defined above (see SVLMAX). +C +C SVLMAX (input) DOUBLE PRECISION +C If A is a submatrix of another matrix B, and the rank +C decision should be related to that matrix, then SVLMAX +C should be an estimate of the largest singular value of B +C (for instance, the Frobenius norm of B). If this is not +C the case, the input value SVLMAX = 0 should work. +C SVLMAX >= 0. +C +C RANK (output) INTEGER +C The effective (estimated) rank of A, i.e., the order of +C the submatrix R22. +C +C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) +C The estimates of some of the singular values of the +C triangular factor R: +C SVAL(1): largest singular value of +C R(M-RANK+1:M,N-RANK+1:N); +C SVAL(2): smallest singular value of +C R(M-RANK+1:M,N-RANK+1:N); +C SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N), +C if RANK < MIN( M, N ), or of +C R(M-RANK+1:M,N-RANK+1:N), otherwise. +C If the triangular factorization is a rank-revealing one +C (which will be the case if the trailing rows were well- +C conditioned), then SVAL(1) will also be an estimate for +C the largest singular value of A, and SVAL(2) and SVAL(3) +C will be estimates for the RANK-th and (RANK+1)-st singular +C values of A, respectively. +C By examining these values, one can confirm that the rank +C is well defined with respect to the chosen value of RCOND. +C The ratio SVAL(1)/SVAL(2) is an estimate of the condition +C number of R(M-RANK+1:M,N-RANK+1:N). +C +C JPVT (output) INTEGER array, dimension ( M ) +C If JPVT(i) = k, then the i-th row of P*A was the k-th row +C of A. +C +C TAU (output) COMPLEX*16 array, dimension ( MIN( M, N ) ) +C The trailing RANK elements of TAU contain the scalar +C factors of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension ( 2*M ) +C +C ZWORK COMPLEX*16 array, dimension ( 3*M-1 ) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a truncated RQ factorization with row +C pivoting of A, P * A = R * Q, with R defined above, and, +C during this process, finds the largest trailing submatrix whose +C estimated condition number is less than 1/RCOND, taking the +C possible positive value of SVLMAX into account. This is performed +C using an adaptation of the LAPACK incremental condition estimation +C scheme and a slightly modified rank decision test. The +C factorization process stops when RANK has been determined. +C +C The matrix Q is represented as a product of elementary reflectors +C +C Q = H(k-rank+1)' H(k-rank+2)' . . . H(k)', where k = min(m,n). +C +C Each H(i) has the form +C +C H = I - tau * v * v' +C +C where tau is a complex scalar, and v is a complex vector with +C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored +C on exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). +C +C The matrix P is represented in jpvt as follows: If +C jpvt(j) = i +C then the jth row of P is the ith canonical unit vector. +C +C REFERENCES +C +C [1] Bischof, C.H. and P. Tang. +C Generalizing Incremental Condition Estimation. +C LAPACK Working Notes 32, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-132, +C May 1991. +C +C [2] Bischof, C.H. and P. Tang. +C Robust Incremental Condition Estimation. +C LAPACK Working Notes 33, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-133, +C May 1991. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalue problem, matrix operations, unitary transformation, +C singular values. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ZERO, ONE, P05 + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D+0 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, M, N, RANK + DOUBLE PRECISION RCOND, SVLMAX +C .. Array Arguments .. + INTEGER JPVT( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), ZWORK( * ) + DOUBLE PRECISION DWORK( * ), SVAL( 3 ) +C .. Local Scalars .. + INTEGER I, ISMAX, ISMIN, ITEMP, J, JWORK, K, MKI, NKI, + $ PVT + COMPLEX*16 AII, C1, C2, S1, S2 + DOUBLE PRECISION SMAX, SMAXPR, SMIN, SMINPR, TEMP, TEMP2 +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DZNRM2 + EXTERNAL DZNRM2, IDAMAX +C .. +C .. External Subroutines .. + EXTERNAL XERBLA, ZCOPY, ZLACGV, ZLAIC1, ZLARF, ZLARFG, + $ ZSCAL, ZSWAP +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN + INFO = -5 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB3PYZ', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + K = MIN( M, N ) + IF( K.EQ.0 ) THEN + RANK = 0 + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF +C + ISMIN = 1 + ISMAX = ISMIN + M + JWORK = ISMAX + M +C +C Initialize partial row norms and pivoting vector. The first m +C elements of DWORK store the exact row norms. +C + DO 10 I = 1, M + DWORK( I ) = DZNRM2( N, A( I, 1 ), LDA ) + DWORK( M+I ) = DWORK( I ) + JPVT( I ) = I + 10 CONTINUE +C +C Compute factorization and determine RANK using incremental +C condition estimation. +C + RANK = 0 +C + 20 CONTINUE + IF( RANK.LT.K ) THEN + I = K - RANK +C +C Determine ith pivot row and swap if necessary. +C + MKI = M - RANK + NKI = N - RANK + PVT = IDAMAX( MKI, DWORK, 1 ) +C + IF( PVT.NE.MKI ) THEN + CALL ZSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( MKI ) + JPVT( MKI ) = ITEMP + DWORK( PVT ) = DWORK( MKI ) + DWORK( M+PVT ) = DWORK( M+MKI ) + END IF +C + IF( NKI.GT.1 ) THEN +C +C Save A(m-k+i,n-k+i) and generate elementary reflector H(i) +C to annihilate A(m-k+i,1:n-k+i-1), k = min(m,n). +C A(m-k+i,1:n-k+i) * H(tau,v) = [0 , *] <=> +C H(conj(tau),v) A(m-k+i,1:n-k+i)^H = [0 ; *], +C using H(tau,v)^H = H(conj(tau),v). +C + CALL ZLACGV( NKI, A( MKI, 1 ), LDA ) + AII = A( MKI, NKI ) + CALL ZLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I ) + $ ) + END IF +C + IF( RANK.EQ.0 ) THEN +C +C Initialize; exit if matrix is zero (RANK = 0). +C + SMAX = ABS( A( M, N ) ) + IF ( SMAX.EQ.ZERO ) THEN + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF + SMIN = SMAX + SMAXPR = SMAX + SMINPR = SMIN + C1 = CONE + C2 = CONE + ELSE +C +C One step of incremental condition estimation. +C + CALL ZCOPY ( RANK, A( MKI, NKI+1 ), LDA, ZWORK( JWORK ), 1 ) + CALL ZLAIC1( IMIN, RANK, ZWORK( ISMIN ), SMIN, + $ ZWORK( JWORK ), A( MKI, NKI ), SMINPR, S1, C1 ) + CALL ZLAIC1( IMAX, RANK, ZWORK( ISMAX ), SMAX, + $ ZWORK( JWORK ), A( MKI, NKI ), SMAXPR, S2, C2 ) + END IF +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN +C + IF( MKI.GT.1 ) THEN +C +C Continue factorization, as rank is at least RANK. +C Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right. +C + AII = A( MKI, NKI ) + A( MKI, NKI ) = CONE + CALL ZLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA, + $ TAU( I ), A, LDA, ZWORK( JWORK ) ) + A( MKI, NKI ) = AII +C +C Update partial row norms. +C + DO 30 J = 1, MKI - 1 + IF( DWORK( J ).NE.ZERO ) THEN + TEMP = ONE - + $ ( ABS( A( J, NKI ) )/DWORK( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = ONE + P05*TEMP* + $ ( DWORK( J ) / DWORK( M+J ) )**2 + IF( TEMP2.EQ.ONE ) THEN + DWORK( J ) = DZNRM2( NKI-1, A( J, 1 ), + $ LDA ) + DWORK( M+J ) = DWORK( J ) + ELSE + DWORK( J ) = DWORK( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE +C + END IF +C + DO 40 I = 1, RANK + ZWORK( ISMIN+I-1 ) = S1*ZWORK( ISMIN+I-1 ) + ZWORK( ISMAX+I-1 ) = S2*ZWORK( ISMAX+I-1 ) + 40 CONTINUE +C + ZWORK( ISMIN+RANK ) = C1 + ZWORK( ISMAX+RANK ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + CALL ZLACGV( NKI-1, A( MKI, 1 ), LDA ) + GO TO 20 + END IF + END IF + END IF + END IF +C +C Restore the changed part of the (M-RANK)-th row and set SVAL. +C + IF ( RANK.LT.K .AND. NKI.GT.1 ) THEN + CALL ZLACGV( NKI-1, A( MKI, 1 ), LDA ) + CALL ZSCAL( NKI-1, -A( MKI, NKI )*TAU( I ), A( MKI, 1 ), LDA ) + A( MKI, NKI ) = AII + END IF + SVAL( 1 ) = SMAX + SVAL( 2 ) = SMIN + SVAL( 3 ) = SMINPR +C + RETURN +C *** Last line of MB3PYZ *** + END diff --git a/mex/sources/libslicot/MC01MD.f b/mex/sources/libslicot/MC01MD.f new file mode 100644 index 000000000..9da419a93 --- /dev/null +++ b/mex/sources/libslicot/MC01MD.f @@ -0,0 +1,162 @@ + SUBROUTINE MC01MD( DP, ALPHA, K, P, Q, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate, for a given real polynomial P(x) and a real scalar +C alpha, the leading K coefficients of the shifted polynomial +C K-1 +C P(x) = q(1) + q(2) * (x-alpha) + ... + q(K) * (x-alpha) + ... +C +C using Horner's algorithm. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C DP (input) INTEGER +C The degree of the polynomial P(x). DP >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar value alpha of the problem. +C +C K (input) INTEGER +C The number of coefficients of the shifted polynomial to be +C computed. 1 <= K <= DP+1. +C +C P (input) DOUBLE PRECISION array, dimension (DP+1) +C This array must contain the coefficients of P(x) in +C increasing powers of x. +C +C Q (output) DOUBLE PRECISION array, dimension (DP+1) +C The leading K elements of this array contain the first +C K coefficients of the shifted polynomial in increasing +C powers of (x - alpha), and the next (DP-K+1) elements +C are used as internal workspace. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given the real polynomial +C 2 DP +C P(x) = p(1) + p(2) * x + p(3) * x + ... + p(DP+1) * x , +C +C the routine computes the leading K coefficients of the shifted +C polynomial +C K-1 +C P(x) = q(1) + q(2) * (x - alpha) + ... + q(K) * (x - alpha) +C +C as follows. +C +C Applying Horner's algorithm (see [1]) to P(x), i.e. dividing P(x) +C by (x-alpha), yields +C +C P(x) = q(1) + (x-alpha) * D(x), +C +C where q(1) is the value of the constant term of the shifted +C polynomial and D(x) is the quotient polynomial of degree (DP-1) +C given by +C 2 DP-1 +C D(x) = d(2) + d(3) * x + d(4) * x + ... + d(DP+1) * x . +C +C Applying Horner's algorithm to D(x) and subsequent quotient +C polynomials yields q(2) and q(3), q(4), ..., q(K) respectively. +C +C It follows immediately that q(1) = P(alpha), and in general +C (i-1) +C q(i) = P (alpha) / (i - 1)! for i = 1, 2, ..., K. +C +C REFERENCES +C +C [1] STOER, J. and BULIRSCH, R. +C Introduction to Numerical Analysis. +C Springer-Verlag. 1980. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01AD by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER DP, INFO, K + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION P(*), Q(*) +C .. Local Scalars .. + INTEGER I, J +C .. External Subroutines .. + EXTERNAL DCOPY, XERBLA +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( DP.LT.0 ) THEN + INFO = -1 + ELSE IF( K.LE.0 .OR. K.GT.DP+1 ) THEN + INFO = -3 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MC01MD', -INFO ) + RETURN + END IF +C + CALL DCOPY( DP+1, P, 1, Q, 1 ) + IF ( DP.EQ.0 .OR. ALPHA.EQ.ZERO ) + $ RETURN +C + DO 40 J = 1, K +C + DO 20 I = DP, J, -1 + Q(I) = Q(I) + ALPHA*Q(I+1) + 20 CONTINUE +C + 40 CONTINUE +C + RETURN +C *** Last line of MC01MD *** + END diff --git a/mex/sources/libslicot/MC01ND.f b/mex/sources/libslicot/MC01ND.f new file mode 100644 index 000000000..b45913fe7 --- /dev/null +++ b/mex/sources/libslicot/MC01ND.f @@ -0,0 +1,146 @@ + SUBROUTINE MC01ND( DP, XR, XI, P, VR, VI, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the value of the real polynomial P(x) at a given +C complex point x = x0 using Horner's algorithm. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C DP (input) INTEGER +C The degree of the polynomial P(x). DP >= 0. +C +C XR (input) DOUBLE PRECISION +C XI (input) DOUBLE PRECISION +C The real and imaginary parts, respectively, of x0. +C +C P (input) DOUBLE PRECISION array, dimension (DP+1) +C This array must contain the coefficients of the polynomial +C P(x) in increasing powers of x. +C +C VR (output) DOUBLE PRECISION +C VI (output) DOUBLE PRECISION +C The real and imaginary parts, respectively, of P(x0). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given the real polynomial +C 2 DP +C P(x) = p(1) + p(2) * x + p(3) * x + ... + p(DP+1) * x , +C +C the routine computes the value of P(x0) using the recursion +C +C q(DP+1) = p(DP+1), +C q(i) = x0*q(i+1) + p(i) for i = DP, DP-1, ..., 1, +C +C which is known as Horner's algorithm (see [1]). Then q(1) = P(x0). +C +C REFERENCES +C +C [1] STOER, J and BULIRSCH, R. +C Introduction to Numerical Analysis. +C Springer-Verlag. 1980. +C +C NUMERICAL ASPECTS +C +C The algorithm requires DP operations for real arguments and 4*DP +C for complex arguments. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01BD by Serge Steer. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER DP, INFO + DOUBLE PRECISION VI, VR, XI, XR +C .. Array Arguments .. + DOUBLE PRECISION P(*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION T +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + IF( DP.LT.0 ) THEN + INFO = -1 +C +C Error return. +C + CALL XERBLA( 'MC01ND', -INFO ) + RETURN + END IF +C + INFO = 0 + VR = P(DP+1) + VI = ZERO +C + IF ( DP.EQ.0 ) + $ RETURN +C + IF ( XI.EQ.ZERO ) THEN +C +C X real. +C + DO 20 I = DP, 1, -1 + VR = VR*XR + P(I) + 20 CONTINUE +C + ELSE +C +C X complex. +C + DO 40 I = DP, 1, -1 + T = VR*XR - VI*XI + P(I) + VI = VI*XR + VR*XI + VR = T + 40 CONTINUE +C + END IF +C + RETURN +C *** Last line of MC01ND *** + END diff --git a/mex/sources/libslicot/MC01OD.f b/mex/sources/libslicot/MC01OD.f new file mode 100644 index 000000000..2d148791f --- /dev/null +++ b/mex/sources/libslicot/MC01OD.f @@ -0,0 +1,147 @@ + SUBROUTINE MC01OD( K, REZ, IMZ, REP, IMP, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients of a complex polynomial P(x) from its +C zeros. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of zeros (and hence the degree) of P(x). +C K >= 0. +C +C REZ (input) DOUBLE PRECISION array, dimension (K) +C IMZ (input) DOUBLE PRECISION array, dimension (K) +C The real and imaginary parts of the i-th zero of P(x) +C must be stored in REZ(i) and IMZ(i), respectively, where +C i = 1, 2, ..., K. The zeros may be supplied in any order. +C +C REP (output) DOUBLE PRECISION array, dimension (K+1) +C IMP (output) DOUBLE PRECISION array, dimension (K+1) +C These arrays contain the real and imaginary parts, +C respectively, of the coefficients of P(x) in increasing +C powers of x. If K = 0, then REP(1) is set to one and +C IMP(1) is set to zero. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (2*K+2) +C If K = 0, this array is not referenced. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes the coefficients of the complex K-th degree +C polynomial P(x) as +C +C P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K)) +C +C where r(i) = (REZ(i),IMZ(i)), using real arithmetic. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01CD by Alan Brown and +C A.J. Geurts. +C +C REVISIONS +C +C V. Sima, May 2002. +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, K +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), IMP(*), IMZ(*), REP(*), REZ(*) +C .. Local Scalars .. + INTEGER I, K2 + DOUBLE PRECISION U, V +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, XERBLA +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + IF( K.LT.0 ) THEN + INFO = -1 +C +C Error return. +C + CALL XERBLA( 'MC01OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + INFO = 0 + REP(1) = ONE + IMP(1) = ZERO + IF ( K.EQ.0 ) + $ RETURN +C + K2 = K + 2 +C + DO 20 I = 1, K + U = REZ(I) + V = IMZ(I) + DWORK(1) = ZERO + DWORK(K2) = ZERO + CALL DCOPY( I, REP, 1, DWORK(2), 1 ) + CALL DCOPY( I, IMP, 1, DWORK(K2+1), 1 ) +C + IF ( U.NE.ZERO ) THEN + CALL DAXPY( I, -U, REP, 1, DWORK, 1 ) + CALL DAXPY( I, -U, IMP, 1, DWORK(K2), 1 ) + END IF +C + IF ( V.NE.ZERO ) THEN + CALL DAXPY( I, V, IMP, 1, DWORK, 1 ) + CALL DAXPY( I, -V, REP, 1, DWORK(K2), 1 ) + END IF +C + CALL DCOPY( I+1, DWORK, 1, REP, 1 ) + CALL DCOPY( I+1, DWORK(K2), 1, IMP, 1 ) + 20 CONTINUE +C + RETURN +C *** Last line of MC01OD *** + END diff --git a/mex/sources/libslicot/MC01PD.f b/mex/sources/libslicot/MC01PD.f new file mode 100644 index 000000000..f378a84bd --- /dev/null +++ b/mex/sources/libslicot/MC01PD.f @@ -0,0 +1,159 @@ + SUBROUTINE MC01PD( K, REZ, IMZ, P, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients of a real polynomial P(x) from its +C zeros. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of zeros (and hence the degree) of P(x). +C K >= 0. +C +C REZ (input) DOUBLE PRECISION array, dimension (K) +C IMZ (input) DOUBLE PRECISION array, dimension (K) +C The real and imaginary parts of the i-th zero of P(x) +C must be stored in REZ(i) and IMZ(i), respectively, where +C i = 1, 2, ..., K. The zeros may be supplied in any order, +C except that complex conjugate zeros must appear +C consecutively. +C +C P (output) DOUBLE PRECISION array, dimension (K+1) +C This array contains the coefficients of P(x) in increasing +C powers of x. If K = 0, then P(1) is set to one. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (K+1) +C If K = 0, this array is not referenced. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, (REZ(i),IMZ(i)) is a complex zero but +C (REZ(i-1),IMZ(i-1)) is not its conjugate. +C +C METHOD +C +C The routine computes the coefficients of the real K-th degree +C polynomial P(x) as +C +C P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K)) +C +C where r(i) = (REZ(i),IMZ(i)). +C +C Note that REZ(i) = REZ(j) and IMZ(i) = -IMZ(j) if r(i) and r(j) +C form a complex conjugate pair (where i <> j), and that IMZ(i) = 0 +C if r(i) is real. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01DD by A.J. Geurts. +C +C REVISIONS +C +C V. Sima, May 2002. +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, K +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), IMZ(*), P(*), REZ(*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION U, V +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, XERBLA +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + IF( K.LT.0 ) THEN + INFO = -1 +C +C Error return. +C + CALL XERBLA( 'MC01PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + INFO = 0 + P(1) = ONE + IF ( K.EQ.0 ) + $ RETURN +C + I = 1 +C WHILE ( I <= K ) DO + 20 IF ( I.LE.K ) THEN + U = REZ(I) + V = IMZ(I) + DWORK(1) = ZERO +C + IF ( V.EQ.ZERO ) THEN + CALL DCOPY( I, P, 1, DWORK(2), 1 ) + CALL DAXPY( I, -U, P, 1, DWORK, 1 ) + I = I + 1 +C + ELSE + IF ( I.EQ.K ) THEN + INFO = K + RETURN + ELSE IF ( ( U.NE.REZ(I+1) ) .OR. ( V.NE.-IMZ(I+1) ) ) THEN + INFO = I + 1 + RETURN + END IF +C + DWORK(2) = ZERO + CALL DCOPY( I, P, 1, DWORK(3), 1 ) + CALL DAXPY( I, -(U + U), P, 1, DWORK(2), 1 ) + CALL DAXPY( I, U**2+V**2, P, 1, DWORK, 1 ) + I = I + 2 + END IF +C + CALL DCOPY( I, DWORK, 1, P, 1 ) + GO TO 20 + END IF +C END WHILE 20 +C + RETURN +C *** Last line of MC01PD *** + END diff --git a/mex/sources/libslicot/MC01PY.f b/mex/sources/libslicot/MC01PY.f new file mode 100644 index 000000000..d43f9b172 --- /dev/null +++ b/mex/sources/libslicot/MC01PY.f @@ -0,0 +1,157 @@ + SUBROUTINE MC01PY( K, REZ, IMZ, P, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients of a real polynomial P(x) from its +C zeros. The coefficients are stored in decreasing order of the +C powers of x. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of zeros (and hence the degree) of P(x). +C K >= 0. +C +C REZ (input) DOUBLE PRECISION array, dimension (K) +C IMZ (input) DOUBLE PRECISION array, dimension (K) +C The real and imaginary parts of the i-th zero of P(x) +C must be stored in REZ(i) and IMZ(i), respectively, where +C i = 1, 2, ..., K. The zeros may be supplied in any order, +C except that complex conjugate zeros must appear +C consecutively. +C +C P (output) DOUBLE PRECISION array, dimension (K+1) +C This array contains the coefficients of P(x) in decreasing +C powers of x. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (K) +C If K = 0, this array is not referenced. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, (REZ(i),IMZ(i)) is a complex zero but +C (REZ(i-1),IMZ(i-1)) is not its conjugate. +C +C METHOD +C +C The routine computes the coefficients of the real K-th degree +C polynomial P(x) as +C +C P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K)) +C +C where r(i) = (REZ(i),IMZ(i)). +C +C Note that REZ(i) = REZ(j) and IMZ(i) = -IMZ(j) if r(i) and r(j) +C form a complex conjugate pair (where i <> j), and that IMZ(i) = 0 +C if r(i) is real. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2002. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, K +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), IMZ(*), P(*), REZ(*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION U, V +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, XERBLA +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + IF( K.LT.0 ) THEN + INFO = -1 +C +C Error return. +C + CALL XERBLA( 'MC01PY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + INFO = 0 + P(1) = ONE + IF ( K.EQ.0 ) + $ RETURN +C + I = 1 +C WHILE ( I <= K ) DO + 20 IF ( I.LE.K ) THEN + U = REZ(I) + V = IMZ(I) + DWORK(I) = ZERO +C + IF ( V.EQ.ZERO ) THEN + CALL DAXPY( I, -U, P, 1, DWORK, 1 ) +C + ELSE + IF ( I.EQ.K ) THEN + INFO = K + RETURN + ELSE IF ( ( U.NE.REZ(I+1) ) .OR. ( V.NE.-IMZ(I+1) ) ) THEN + INFO = I + 1 + RETURN + END IF +C + DWORK(I+1) = ZERO + CALL DAXPY( I, -(U + U), P, 1, DWORK, 1 ) + CALL DAXPY( I, U**2+V**2, P, 1, DWORK(2), 1 ) + I = I + 1 + END IF +C + CALL DCOPY( I, DWORK, 1, P(2), 1 ) + I = I + 1 + GO TO 20 + END IF +C END WHILE 20 +C + RETURN +C *** Last line of MC01PY *** + END diff --git a/mex/sources/libslicot/MC01QD.f b/mex/sources/libslicot/MC01QD.f new file mode 100644 index 000000000..652887bb6 --- /dev/null +++ b/mex/sources/libslicot/MC01QD.f @@ -0,0 +1,207 @@ + SUBROUTINE MC01QD( DA, DB, A, B, RQ, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute, for two given real polynomials A(x) and B(x), the +C quotient polynomial Q(x) and the remainder polynomial R(x) of +C A(x) divided by B(x). +C +C The polynomials Q(x) and R(x) satisfy the relationship +C +C A(x) = B(x) * Q(x) + R(x), +C +C where the degree of R(x) is less than the degree of B(x). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C DA (input) INTEGER +C The degree of the numerator polynomial A(x). DA >= -1. +C +C DB (input/output) INTEGER +C On entry, the degree of the denominator polynomial B(x). +C DB >= 0. +C On exit, if B(DB+1) = 0.0 on entry, then DB contains the +C index of the highest power of x for which B(DB+1) <> 0.0. +C +C A (input) DOUBLE PRECISION array, dimension (DA+1) +C This array must contain the coefficients of the +C numerator polynomial A(x) in increasing powers of x +C unless DA = -1 on entry, in which case A(x) is taken +C to be the zero polynomial. +C +C B (input) DOUBLE PRECISION array, dimension (DB+1) +C This array must contain the coefficients of the +C denominator polynomial B(x) in increasing powers of x. +C +C RQ (output) DOUBLE PRECISION array, dimension (DA+1) +C If DA < DB on exit, then this array contains the +C coefficients of the remainder polynomial R(x) in +C increasing powers of x; Q(x) is the zero polynomial. +C Otherwise, the leading DB elements of this array contain +C the coefficients of R(x) in increasing powers of x, and +C the next (DA-DB+1) elements contain the coefficients of +C Q(x) in increasing powers of x. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = k: if the degree of the denominator polynomial B(x) has +C been reduced to (DB - k) because B(DB+1-j) = 0.0 on +C entry for j = 0, 1, ..., k-1 and B(DB+1-k) <> 0.0. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if on entry, DB >= 0 and B(i) = 0.0, where +C i = 1, 2, ..., DB+1. +C +C METHOD +C +C Given real polynomials +C DA +C A(x) = a(1) + a(2) * x + ... + a(DA+1) * x +C +C and +C DB +C B(x) = b(1) + b(2) * x + ... + b(DB+1) * x +C +C where b(DB+1) is non-zero, the routine computes the coeffcients of +C the quotient polynomial +C DA-DB +C Q(x) = q(1) + q(2) * x + ... + q(DA-DB+1) * x +C +C and the remainder polynomial +C DB-1 +C R(x) = r(1) + r(2) * x + ... + r(DB) * x +C +C such that A(x) = B(x) * Q(x) + R(x). +C +C The algorithm used is synthetic division of polynomials (see [1]), +C which involves the following steps: +C +C (a) compute q(k+1) = a(DB+k+1) / b(DB+1) +C +C and +C +C (b) set a(j) = a(j) - q(k+1) * b(j-k) for j = k+1, ..., DB+k. +C +C Steps (a) and (b) are performed for k = DA-DB, DA-DB-1, ..., 0 and +C the algorithm terminates with r(i) = a(i) for i = 1, 2, ..., DB. +C +C REFERENCES +C +C [1] Knuth, D.E. +C The Art of Computer Programming, (Vol. 2, Seminumerical +C Algorithms). +C Addison-Wesley, Reading, Massachusetts (2nd Edition), 1981. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01ED by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER DA, DB, INFO, IWARN +C .. Array Arguments .. + DOUBLE PRECISION A(*), B(*), RQ(*) +C .. Local Scalars .. + INTEGER N + DOUBLE PRECISION Q +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, XERBLA +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + IWARN = 0 + INFO = 0 + IF( DA.LT.-1 ) THEN + INFO = -1 + ELSE IF( DB.LT.0 ) THEN + INFO = -2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MC01QD', -INFO ) + RETURN + END IF +C +C WHILE ( DB >= 0 and B(DB+1) = 0 ) DO + 20 IF ( DB.GE.0 ) THEN + IF ( B(DB+1).EQ.ZERO ) THEN + DB = DB - 1 + IWARN = IWARN + 1 + GO TO 20 + END IF + END IF +C END WHILE 20 + IF ( DB.EQ.-1 ) THEN + INFO = 1 + RETURN + END IF +C +C B(x) is non-zero. +C + IF ( DA.GE.0 ) THEN + N = DA + CALL DCOPY( N+1, A, 1, RQ, 1 ) +C WHILE ( N >= DB ) DO + 40 IF ( N.GE.DB ) THEN + IF ( RQ(N+1).NE.ZERO ) THEN + Q = RQ(N+1)/B(DB+1) + CALL DAXPY( DB, -Q, B, 1, RQ(N-DB+1), 1 ) + RQ(N+1) = Q + END IF + N = N - 1 + GO TO 40 + END IF +C END WHILE 40 + END IF +C + RETURN +C *** Last line of MC01QD *** + END diff --git a/mex/sources/libslicot/MC01RD.f b/mex/sources/libslicot/MC01RD.f new file mode 100644 index 000000000..da1b3dc2f --- /dev/null +++ b/mex/sources/libslicot/MC01RD.f @@ -0,0 +1,299 @@ + SUBROUTINE MC01RD( DP1, DP2, DP3, ALPHA, P1, P2, P3, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients of the polynomial +C +C P(x) = P1(x) * P2(x) + alpha * P3(x), +C +C where P1(x), P2(x) and P3(x) are given real polynomials and alpha +C is a real scalar. +C +C Each of the polynomials P1(x), P2(x) and P3(x) may be the zero +C polynomial. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C DP1 (input) INTEGER +C The degree of the polynomial P1(x). DP1 >= -1. +C +C DP2 (input) INTEGER +C The degree of the polynomial P2(x). DP2 >= -1. +C +C DP3 (input/output) INTEGER +C On entry, the degree of the polynomial P3(x). DP3 >= -1. +C On exit, the degree of the polynomial P(x). +C +C ALPHA (input) DOUBLE PRECISION +C The scalar value alpha of the problem. +C +C P1 (input) DOUBLE PRECISION array, dimension (lenp1) +C where lenp1 = DP1 + 1 if DP1 >= 0 and 1 otherwise. +C If DP1 >= 0, then this array must contain the +C coefficients of P1(x) in increasing powers of x. +C If DP1 = -1, then P1(x) is taken to be the zero +C polynomial, P1 is not referenced and can be supplied +C as a dummy array. +C +C P2 (input) DOUBLE PRECISION array, dimension (lenp2) +C where lenp2 = DP2 + 1 if DP2 >= 0 and 1 otherwise. +C If DP2 >= 0, then this array must contain the +C coefficients of P2(x) in increasing powers of x. +C If DP2 = -1, then P2(x) is taken to be the zero +C polynomial, P2 is not referenced and can be supplied +C as a dummy array. +C +C P3 (input/output) DOUBLE PRECISION array, dimension (lenp3) +C where lenp3 = MAX(DP1+DP2,DP3,0) + 1. +C On entry, if DP3 >= 0, then this array must contain the +C coefficients of P3(x) in increasing powers of x. +C On entry, if DP3 = -1, then P3(x) is taken to be the zero +C polynomial. +C On exit, the leading (DP3+1) elements of this array +C contain the coefficients of P(x) in increasing powers of x +C unless DP3 = -1 on exit, in which case the coefficients of +C P(x) (the zero polynomial) are not stored in the array. +C This is the case, for instance, when ALPHA = 0.0 and +C P1(x) or P2(x) is the zero polynomial. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given real polynomials +C +C DP1 i DP2 i +C P1(x) = SUM a(i+1) * x , P2(x) = SUM b(i+1) * x and +C i=0 i=0 +C +C DP3 i +C P3(x) = SUM c(i+1) * x , +C i=0 +C +C the routine computes the coefficents of P(x) = P1(x) * P2(x) + +C DP3 i +C alpha * P3(x) = SUM d(i+1) * x as follows. +C i=0 +C +C Let e(i) = c(i) for 1 <= i <= DP3+1 and e(i) = 0 for i > DP3+1. +C Then if DP1 >= DP2, +C +C i +C d(i) = SUM a(k) * b(i-k+1) + f(i), for i = 1, ..., DP2+1, +C k=1 +C +C i +C d(i) = SUM a(k) * b(i-k+1) + f(i), for i = DP2+2, ..., DP1+1 +C k=i-DP2 +C +C and +C DP1+1 +C d(i) = SUM a(k) * b(i-k+1) + f(i) for i = DP1+2,...,DP1+DP2+1, +C k=i-DP2 +C +C where f(i) = alpha * e(i). +C +C Similar formulas hold for the case DP1 < DP2. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01FD by C. Klimann and +C A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER DP1, DP2, DP3, INFO + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION P1(*), P2(*), P3(*) +C .. Local Scalars .. + INTEGER D1, D2, D3, DMAX, DMIN, DSUM, E3, I, J, K, L +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( DP1.LT.-1 ) THEN + INFO = -1 + ELSE IF( DP2.LT.-1 ) THEN + INFO = -2 + ELSE IF( DP3.LT.-1 ) THEN + INFO = -3 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MC01RD', -INFO ) + RETURN + END IF +C +C Computation of the exact degree of the polynomials, i.e., Di such +C that either Di = -1 or Pi(Di+1) is non-zero. +C + D1 = DP1 +C WHILE ( D1 >= 0 and P1(D1+1) = 0 ) DO + 20 IF ( D1.GE.0 ) THEN + IF ( P1(D1+1).EQ.ZERO ) THEN + D1 = D1 - 1 + GO TO 20 + END IF + END IF +C END WHILE 20 + D2 = DP2 +C WHILE ( D2 >= 0 and P2(D2+1) = 0 ) DO + 40 IF ( D2.GE.0 ) THEN + IF ( P2(D2+1).EQ.ZERO ) THEN + D2 = D2 - 1 + GO TO 40 + END IF + END IF +C END WHILE 40 + IF ( ALPHA.EQ.ZERO ) THEN + D3 = -1 + ELSE + D3 = DP3 + END IF +C WHILE ( D3 >= 0 and P3(D3+1) = 0 ) DO + 60 IF ( D3.GE.0 ) THEN + IF ( P3(D3+1).EQ.ZERO ) THEN + D3 = D3 - 1 + GO TO 60 + END IF + END IF +C END WHILE 60 +C +C Computation of P3(x) := ALPHA * P3(x). +C + CALL DSCAL( D3+1, ALPHA, P3, 1 ) +C + IF ( ( D1.EQ.-1 ) .OR. ( D2.EQ.-1 ) ) THEN + DP3 = D3 + RETURN + END IF +C +C P1(x) and P2(x) are non-zero polynomials. +C + DSUM = D1 + D2 + DMAX = MAX( D1, D2 ) + DMIN = DSUM - DMAX +C + IF ( D3.LT.DSUM ) THEN + P3(D3+2) = ZERO + CALL DCOPY( DSUM-D3-1, P3(D3+2), 0, P3(D3+3), 1 ) + D3 = DSUM + END IF +C + IF ( ( D1.EQ.0 ) .OR. ( D2.EQ.0 ) ) THEN +C +C D1 or D2 is zero. +C + IF ( D1.NE.0 ) THEN + CALL DAXPY( D1+1, P2(1), P1, 1, P3, 1 ) + ELSE + CALL DAXPY( D2+1, P1(1), P2, 1, P3, 1 ) + END IF + ELSE +C +C D1 and D2 are both nonzero. +C +C First part of the computation. +C + DO 80 I = 1, DMIN + 1 + P3(I) = P3(I) + DDOT( I, P1, 1, P2, -1 ) + 80 CONTINUE +C +C Second part of the computation. +C + DO 100 I = DMIN + 2, DMAX + 1 + IF ( D1.GT.D2 ) THEN + K = I - D2 + P3(I) = P3(I) + DDOT( DMIN+1, P1(K), 1, P2, -1 ) + ELSE + K = I - D1 + P3(I) = P3(I) + DDOT( DMIN+1, P2(K), -1, P1, 1 ) + END IF + 100 CONTINUE +C +C Third part of the computation. +C + E3 = DSUM + 2 +C + DO 120 I = DMAX + 2, DSUM + 1 + J = E3 - I + K = I - DMIN + L = I - DMAX + IF ( D1.GT.D2 ) THEN + P3(I) = P3(I) + DDOT( J, P1(K), 1, P2(L), -1 ) + ELSE + P3(I) = P3(I) + DDOT( J, P1(L), -1, P2(K), 1 ) + END IF + 120 CONTINUE +C + END IF +C +C Computation of the exact degree of P3(x). +C +C WHILE ( D3 >= 0 and P3(D3+1) = 0 ) DO + 140 IF ( D3.GE.0 ) THEN + IF ( P3(D3+1).EQ.ZERO ) THEN + D3 = D3 - 1 + GO TO 140 + END IF + END IF +C END WHILE 140 + DP3 = D3 +C + RETURN +C *** Last line of MC01RD *** + END diff --git a/mex/sources/libslicot/MC01SD.f b/mex/sources/libslicot/MC01SD.f new file mode 100644 index 000000000..d84362ee2 --- /dev/null +++ b/mex/sources/libslicot/MC01SD.f @@ -0,0 +1,281 @@ + SUBROUTINE MC01SD( DP, P, S, T, MANT, E, IWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To scale the coefficients of the real polynomial P(x) such that +C the coefficients of the scaled polynomial Q(x) = sP(tx) have +C minimal variation, where s and t are real scalars. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C DP (input) INTEGER +C The degree of the polynomial P(x). DP >= 0. +C +C P (input/output) DOUBLE PRECISION array, dimension (DP+1) +C On entry, this array must contain the coefficients of P(x) +C in increasing powers of x. +C On exit, this array contains the coefficients of the +C scaled polynomial Q(x) in increasing powers of x. +C +C S (output) INTEGER +C The exponent of the floating-point representation of the +C scaling factor s = BASE**S, where BASE is the base of the +C machine representation of floating-point numbers (see +C LAPACK Library Routine DLAMCH). +C +C T (output) INTEGER +C The exponent of the floating-point representation of the +C scaling factor t = BASE**T. +C +C MANT (output) DOUBLE PRECISION array, dimension (DP+1) +C This array contains the mantissas of the standard +C floating-point representation of the coefficients of the +C scaled polynomial Q(x) in increasing powers of x. +C +C E (output) INTEGER array, dimension (DP+1) +C This array contains the exponents of the standard +C floating-point representation of the coefficients of the +C scaled polynomial Q(x) in increasing powers of x. +C +C Workspace +C +C IWORK INTEGER array, dimension (DP+1) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if on entry, P(x) is the zero polynomial. +C +C METHOD +C +C Define the variation of the coefficients of the real polynomial +C +C 2 DP +C P(x) = p(0) + p(1) * x + p(2) * x + ... + p(DP) x +C +C whose non-zero coefficients can be represented as +C e(i) +C p(i) = m(i) * BASE (where 1 <= ABS(m(i)) < BASE) +C +C by +C +C V = max(e(i)) - min(e(i)), +C +C where max and min are taken over the indices i for which p(i) is +C non-zero. +C DP i i +C For the scaled polynomial P(cx) = SUM p(i) * c * x with +C i=0 +C j +C c = (BASE) , the variation V(j) is given by +C +C V(j) = max(e(i) + j * i) - min(e(i) + j * i). +C +C Using the fact that V(j) is a convex function of j, the routine +C determines scaling factors s = (BASE)**S and t = (BASE)**T such +C that the coefficients of the scaled polynomial Q(x) = sP(tx) +C satisfy the following conditions: +C +C (a) 1 <= q(0) < BASE and +C +C (b) the variation of the coefficients of Q(x) is minimal. +C +C Further details can be found in [1]. +C +C REFERENCES +C +C [1] Dunaway, D.K. +C Calculation of Zeros of a Real Polynomial through +C Factorization using Euclid's Algorithm. +C SIAM J. Numer. Anal., 11, pp. 1087-1104, 1974. +C +C NUMERICAL ASPECTS +C +C Since the scaling is performed on the exponents of the floating- +C point representation of the coefficients of P(x), no rounding +C errors occur during the computation of the coefficients of Q(x). +C +C FURTHER COMMENTS +C +C The scaling factors s and t are BASE dependent. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01GD by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER DP, INFO, S, T +C .. Array Arguments .. + INTEGER E(*), IWORK(*) + DOUBLE PRECISION MANT(*), P(*) +C .. Local Scalars .. + LOGICAL OVFLOW + INTEGER BETA, DV, I, INC, J, LB, M, UB, V0, V1 +C .. External Functions .. + INTEGER MC01SX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, MC01SX +C .. External Subroutines .. + EXTERNAL MC01SW, MC01SY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, NINT +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + IF( DP.LT.0 ) THEN + INFO = -1 +C +C Error return. +C + CALL XERBLA( 'MC01SD', -INFO ) + RETURN + END IF +C + INFO = 0 + LB = 1 +C WHILE ( LB <= DP+1 and P(LB) = 0 ) DO + 20 IF ( LB.LE.DP+1 ) THEN + IF ( P(LB).EQ.ZERO ) THEN + LB = LB + 1 + GO TO 20 + END IF + END IF +C END WHILE 20 +C +C LB = MIN( i: P(i) non-zero). +C + IF ( LB.EQ.DP+2 ) THEN + INFO = 1 + RETURN + END IF +C + UB = DP + 1 +C WHILE ( P(UB) = 0 ) DO + 40 IF ( P(UB).EQ.ZERO ) THEN + UB = UB - 1 + GO TO 40 + END IF +C END WHILE 40 +C +C UB = MAX(i: P(i) non-zero). +C + BETA = DLAMCH( 'Base' ) +C + DO 60 I = 1, DP + 1 + CALL MC01SW( P(I), BETA, MANT(I), E(I) ) + 60 CONTINUE +C +C First prescaling. +C + M = E(LB) + IF ( M.NE.0 ) THEN +C + DO 80 I = LB, UB + IF ( MANT(I).NE.ZERO ) E(I) = E(I) - M + 80 CONTINUE +C + END IF + S = -M +C +C Second prescaling. +C + IF ( UB.GT.1 ) M = NINT( DBLE( E(UB) )/DBLE( UB-1 ) ) +C + DO 100 I = LB, UB + IF ( MANT(I).NE.ZERO ) E(I) = E(I) - M*(I-1) + 100 CONTINUE +C + T = -M +C + V0 = MC01SX( LB, UB, E, MANT ) + J = 1 +C + DO 120 I = LB, UB + IF ( MANT(I).NE.ZERO ) IWORK(I) = E(I) + (I-1) + 120 CONTINUE +C + V1 = MC01SX( LB, UB, IWORK, MANT ) + DV = V1 - V0 + IF ( DV.NE.0 ) THEN + IF ( DV.GT.0 ) THEN + J = 0 + INC = -1 + V1 = V0 + DV = -DV +C + DO 130 I = LB, UB + IWORK(I) = E(I) + 130 CONTINUE +C + ELSE + INC = 1 + END IF +C WHILE ( DV < 0 ) DO + 140 IF ( DV.LT.0 ) THEN + V0 = V1 +C + DO 150 I = LB, UB + E(I) = IWORK(I) + 150 CONTINUE +C + J = J + INC +C + DO 160 I = LB, UB + IWORK(I) = E(I) + INC*(I-1 ) + 160 CONTINUE +C + V1 = MC01SX( LB, UB, IWORK, MANT ) + DV = V1 - V0 + GO TO 140 + END IF +C END WHILE 140 + T = T + J - INC + END IF +C +C Evaluation of the output parameters. +C + DO 180 I = LB, UB + CALL MC01SY( MANT(I), E(I), BETA, P(I), OVFLOW ) + 180 CONTINUE +C + RETURN +C *** Last line of MC01SD *** + END diff --git a/mex/sources/libslicot/MC01SW.f b/mex/sources/libslicot/MC01SW.f new file mode 100644 index 000000000..55e155e59 --- /dev/null +++ b/mex/sources/libslicot/MC01SW.f @@ -0,0 +1,104 @@ + SUBROUTINE MC01SW( A, B, M, E ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find the mantissa M and the exponent E of a real number A such +C that +C A = M * B**E +C 1 <= ABS( M ) < B +C if A is non-zero. If A is zero, then M and E are set to 0. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C A (input) DOUBLE PRECISION +C The number whose mantissa and exponent are required. +C +C B (input) INTEGER +C The base of the floating-point arithmetic. +C +C M (output) DOUBLE PRECISION +C The mantissa of the floating-point representation of A. +C +C E (output) INTEGER +C The exponent of the floating-point representation of A. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01GZ by A.J. Geurts. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER B, E + DOUBLE PRECISION A, M +C .. Local Scalars .. + DOUBLE PRECISION DB +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE +C .. Executable Statements .. +C +C Quick return if possible. +C + IF ( A.EQ.ZERO ) THEN + M = ZERO + E = 0 + RETURN + END IF +C +C A non-zero. +C + DB = DBLE( B ) + M = ABS( A ) + E = 0 +C WHILE ( M >= B ) DO + 20 IF ( M.GE.DB ) THEN + M = M/DB + E = E + 1 + GO TO 20 + END IF +C END WHILE 20 +C WHILE ( M < 1 ) DO + 40 IF ( M.LT.ONE ) THEN + M = M*DB + E = E - 1 + GO TO 40 + END IF +C END WHILE 40 +C + IF ( A.LT.ZERO ) M = -M +C + RETURN +C *** Last line of MC01SW *** + END diff --git a/mex/sources/libslicot/MC01SX.f b/mex/sources/libslicot/MC01SX.f new file mode 100644 index 000000000..c20360154 --- /dev/null +++ b/mex/sources/libslicot/MC01SX.f @@ -0,0 +1,68 @@ + INTEGER FUNCTION MC01SX( LB, UB, E, MANT ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the variation V of the exponents of a series of +C non-zero floating-point numbers: a(j) = MANT(j) * beta**(E(j)), +C where beta is the base of the machine representation of +C floating-point numbers, i.e., +C V = max(E(j)) - min(E(j)), j = LB,...,UB and MANT(j) non-zero. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01GX by A.J. Geurts. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER LB, UB +C .. Array Arguments .. + INTEGER E(*) + DOUBLE PRECISION MANT(*) +C .. Local Scalars .. + INTEGER J, MAXE, MINE +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + MAXE = E(LB) + MINE = MAXE +C + DO 20 J = LB + 1, UB + IF ( MANT(J).NE.ZERO ) THEN + MAXE = MAX( MAXE, E(J) ) + MINE = MIN( MINE, E(J) ) + END IF + 20 CONTINUE +C + MC01SX = MAXE - MINE +C + RETURN +C *** Last line of MC01SX *** + END diff --git a/mex/sources/libslicot/MC01SY.f b/mex/sources/libslicot/MC01SY.f new file mode 100644 index 000000000..ab187aa50 --- /dev/null +++ b/mex/sources/libslicot/MC01SY.f @@ -0,0 +1,146 @@ + SUBROUTINE MC01SY( M, E, B, A, OVFLOW ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a real number A from its mantissa M and its exponent E, +C i.e., +C A = M * B**E. +C M and E need not be the standard floating-point values. +C If ABS(A) < B**(EMIN-1), i.e. the smallest positive model number, +C then the routine returns A = 0. +C If M = 0, then the routine returns A = 0 regardless of the value +C of E. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) DOUBLE PRECISION +C The mantissa of the floating-point representation of A. +C +C E (input) INTEGER +C The exponent of the floating-point representation of A. +C +C B (input) INTEGER +C The base of the floating-point arithmetic. +C +C A (output) DOUBLE PRECISION +C The value of M * B**E. +C +C OVFLOW (output) LOGICAL +C The value .TRUE., if ABS(M) * B**E >= B**EMAX (where EMAX +C is the largest possible exponent) and .FALSE. otherwise. +C A is not defined if OVFLOW = .TRUE.. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01GY by A.J. Geurts. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + LOGICAL OVFLOW + INTEGER B, E + DOUBLE PRECISION A, M +C .. Local Scalars .. + INTEGER EMAX, EMIN, ET, EXPON + DOUBLE PRECISION BASE, MT +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. Intrinsic Functions .. + INTRINSIC ABS, MOD +C .. Executable Statements .. +C + OVFLOW = .FALSE. +C + IF ( ( M.EQ.ZERO ) .OR. ( E.EQ.0 ) ) THEN + A = M + RETURN + END IF +C +C Determination of the mantissa MT and the exponent ET of the +C standard floating-point representation. +C + EMIN = DLAMCH( 'Minimum exponent' ) + EMAX = DLAMCH( 'Largest exponent' ) + MT = M + ET = E +C WHILE ( ABS( MT ) >= B ) DO + 20 IF ( ABS( MT ).GE.B ) THEN + MT = MT/B + ET = ET + 1 + GO TO 20 + END IF +C END WHILE 20 +C WHILE ( ABS( MT ) < 1 ) DO + 40 IF ( ABS( MT ).LT.ONE ) THEN + MT = MT*B + ET = ET - 1 + GO TO 40 + END IF +C END WHILE 40 +C + IF ( ET.LT.EMIN ) THEN + A = ZERO + RETURN + END IF +C + IF ( ET.GE.EMAX ) THEN + OVFLOW = .TRUE. + RETURN + END IF +C +C Computation of the value of A by the relation +C M * B**E = A * (BASE)**EXPON +C + EXPON = ABS( ET ) + A = MT + BASE = B + IF ( ET.LT.0 ) BASE = ONE/BASE +C WHILE ( not EXPON = 0 ) DO + 60 IF ( EXPON.NE.0 ) THEN + IF ( MOD( EXPON, 2 ).EQ.0 ) THEN + BASE = BASE*BASE + EXPON = EXPON/2 + ELSE + A = A*BASE + EXPON = EXPON - 1 + END IF + GO TO 60 + END IF +C END WHILE 60 +C + RETURN +C *** Last line of MC01SY *** + END diff --git a/mex/sources/libslicot/MC01TD.f b/mex/sources/libslicot/MC01TD.f new file mode 100644 index 000000000..249f5c367 --- /dev/null +++ b/mex/sources/libslicot/MC01TD.f @@ -0,0 +1,305 @@ + SUBROUTINE MC01TD( DICO, DP, P, STABLE, NZ, DWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine whether or not a given polynomial P(x) with real +C coefficients is stable, either in the continuous-time or discrete- +C time case. +C +C A polynomial is said to be stable in the continuous-time case +C if all its zeros lie in the left half-plane, and stable in the +C discrete-time case if all its zeros lie inside the unit circle. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Indicates whether the stability test to be applied to +C P(x) is in the continuous-time or discrete-time case as +C follows: +C = 'C': Continuous-time case; +C = 'D': Discrete-time case. +C +C Input/Output Parameters +C +C DP (input/output) INTEGER +C On entry, the degree of the polynomial P(x). DP >= 0. +C On exit, if P(DP+1) = 0.0 on entry, then DP contains the +C index of the highest power of x for which P(DP+1) <> 0.0. +C +C P (input) DOUBLE PRECISION array, dimension (DP+1) +C This array must contain the coefficients of P(x) in +C increasing powers of x. +C +C STABLE (output) LOGICAL +C Contains the value .TRUE. if P(x) is stable and the value +C .FALSE. otherwise (see also NUMERICAL ASPECTS). +C +C NZ (output) INTEGER +C If INFO = 0, contains the number of unstable zeros - that +C is, the number of zeros of P(x) in the right half-plane if +C DICO = 'C' or the number of zeros of P(x) outside the unit +C circle if DICO = 'D' (see also NUMERICAL ASPECTS). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (2*DP+2) +C The leading (DP+1) elements of DWORK contain the Routh +C coefficients, if DICO = 'C', or the constant terms of +C the Schur-Cohn transforms, if DICO = 'D'. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = k: if the degree of the polynomial P(x) has been +C reduced to (DB - k) because P(DB+1-j) = 0.0 on entry +C for j = 0, 1,..., k-1 and P(DB+1-k) <> 0.0. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if on entry, P(x) is the zero polynomial; +C = 2: if the polynomial P(x) is most probably unstable, +C although it may be stable with one or more zeros +C very close to either the imaginary axis if +C DICO = 'C' or the unit circle if DICO = 'D'. +C The number of unstable zeros (NZ) is not determined. +C +C METHOD +C +C The stability of the real polynomial +C 2 DP +C P(x) = p(0) + p(1) * x + p(2) * x + ... + p(DP) x +C +C is determined as follows. +C +C In the continuous-time case (DICO = 'C') the Routh algorithm +C (see [1]) is used. The routine computes the Routh coefficients and +C if they are non-zero then the number of sign changes in the +C sequence of the coefficients is equal to the number of zeros with +C positive imaginary part. +C +C In the discrete-time case (DICO = 'D') the Schur-Cohn +C algorithm (see [2] and [3]) is applied to the reciprocal +C polynomial +C 2 DP +C Q(x) = p(DP) + p(DP-1) * x + p(DP-2) * x + ... + p(0) x . +C +C The routine computes the constant terms of the Schur transforms +C and if all of them are non-zero then the number of zeros of P(x) +C with modulus greater than unity is obtained from the sequence of +C constant terms. +C +C REFERENCES +C +C [1] Gantmacher, F.R. +C Applications of the Theory of Matrices. +C Interscience Publishers, New York, 1959. +C +C [2] Kucera, V. +C Discrete Linear Control. The Algorithmic Approach. +C John Wiley & Sons, Chichester, 1979. +C +C [3] Henrici, P. +C Applied and Computational Complex Analysis (Vol. 1). +C John Wiley & Sons, New York, 1974. +C +C NUMERICAL ASPECTS +C +C The algorithm used by the routine is numerically stable. +C +C Note that if some of the Routh coefficients (DICO = 'C') or +C some of the constant terms of the Schur-Cohn transforms (DICO = +C 'D') are small relative to EPS (the machine precision), then +C the number of unstable zeros (and hence the value of STABLE) may +C be incorrect. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01HD by F. Delebecque and +C A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations, +C stability, stability criteria, zeros. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO + LOGICAL STABLE + INTEGER DP, INFO, IWARN, NZ +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), P(*) +C .. Local Scalars .. + LOGICAL DICOC + INTEGER I, K, K1, K2, SIGNUM + DOUBLE PRECISION ALPHA, P1, PK1 +C .. External Functions .. + INTEGER IDAMAX + LOGICAL LSAME + EXTERNAL IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DRSCL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC SIGN +C .. Executable Statements .. +C + IWARN = 0 + INFO = 0 + DICOC = LSAME( DICO, 'C' ) +C +C Test the input scalar arguments. +C + IF( .NOT.DICOC .AND. .NOT.LSAME( DICO, 'D' ) ) THEN + INFO = -1 + ELSE IF( DP.LT.0 ) THEN + INFO = -2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MC01TD', -INFO ) + RETURN + END IF +C +C WHILE (DP >= 0 and P(DP+1) = 0 ) DO + 20 IF ( DP.GE.0 ) THEN + IF ( P(DP+1).EQ.ZERO ) THEN + DP = DP - 1 + IWARN = IWARN + 1 + GO TO 20 + END IF + END IF +C END WHILE 20 +C + IF ( DP.EQ.-1 ) THEN + INFO = 1 + RETURN + END IF +C +C P(x) is not the zero polynomial and its degree is exactly DP. +C + IF ( DICOC ) THEN +C +C Continuous-time case. +C +C Compute the Routh coefficients and the number of sign changes. +C + CALL DCOPY( DP+1, P, 1, DWORK, 1 ) + NZ = 0 + K = DP +C WHILE ( K > 0 and DWORK(K) non-zero) DO + 40 IF ( K.GT.0 ) THEN + IF ( DWORK(K).EQ.ZERO ) THEN + INFO = 2 + ELSE + ALPHA = DWORK(K+1)/DWORK(K) + IF ( ALPHA.LT.ZERO ) NZ = NZ + 1 + K = K - 1 +C + DO 60 I = K, 2, -2 + DWORK(I) = DWORK(I) - ALPHA*DWORK(I-1) + 60 CONTINUE +C + GO TO 40 + END IF + END IF +C END WHILE 40 + ELSE +C +C Discrete-time case. +C +C To apply [3], section 6.8, on the reciprocal of polynomial +C P(x) the elements of the array P are copied in DWORK in +C reverse order. +C + CALL DCOPY( DP+1, P, 1, DWORK, -1 ) +C K-1 +C DWORK(K),...,DWORK(DP+1), are the coefficients of T P(x) +C scaled with a factor alpha(K) in order to avoid over- or +C underflow, +C i-1 +C DWORK(i), i = 1,...,K, contains alpha(i) * T P(0). +C + SIGNUM = ONE + NZ = 0 + K = 1 +C WHILE ( K <= DP and DWORK(K) non-zero ) DO + 80 IF ( ( K.LE.DP ) .AND. ( INFO.EQ.0 ) ) THEN +C K +C Compute the coefficients of T P(x). +C + K1 = DP - K + 2 + K2 = DP + 2 + ALPHA = DWORK(K-1+IDAMAX( K1, DWORK(K), 1 )) + IF ( ALPHA.EQ.ZERO ) THEN + INFO = 2 + ELSE + CALL DCOPY( K1, DWORK(K), 1, DWORK(K2), 1 ) + CALL DRSCL( K1, ALPHA, DWORK(K2), 1 ) + P1 = DWORK(K2) + PK1 = DWORK(K2+K1-1) +C + DO 100 I = 1, K1 - 1 + DWORK(K+I) = P1*DWORK(DP+1+I) - PK1*DWORK(K2+K1-I) + 100 CONTINUE +C +C Compute the number of unstable zeros. +C + K = K + 1 + IF ( DWORK(K).EQ.ZERO ) THEN + INFO = 2 + ELSE + SIGNUM = SIGNUM*SIGN( ONE, DWORK(K) ) + IF ( SIGNUM.LT.ZERO ) NZ = NZ + 1 + END IF + GO TO 80 + END IF +C END WHILE 80 + END IF + END IF +C + IF ( ( INFO.EQ.0 ) .AND. ( NZ.EQ.0 ) ) THEN + STABLE = .TRUE. + ELSE + STABLE = .FALSE. + END IF +C + RETURN +C *** Last line of MC01TD *** + END diff --git a/mex/sources/libslicot/MC01VD.f b/mex/sources/libslicot/MC01VD.f new file mode 100644 index 000000000..4d03390b1 --- /dev/null +++ b/mex/sources/libslicot/MC01VD.f @@ -0,0 +1,304 @@ + SUBROUTINE MC01VD( A, B, C, Z1RE, Z1IM, Z2RE, Z2IM, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the roots of a quadratic equation with real +C coefficients. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C A (input) DOUBLE PRECISION +C The value of the coefficient of the quadratic term. +C +C B (input) DOUBLE PRECISION +C The value of the coefficient of the linear term. +C +C C (input) DOUBLE PRECISION +C The value of the coefficient of the constant term. +C +C Z1RE (output) DOUBLE PRECISION +C Z1IM (output) DOUBLE PRECISION +C The real and imaginary parts, respectively, of the largest +C root in magnitude. +C +C Z2RE (output) DOUBLE PRECISION +C Z2IM (output) DOUBLE PRECISION +C The real and imaginary parts, respectively, of the +C smallest root in magnitude. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if on entry, either A = B = 0.0 or A = 0.0 and the +C root -C/B overflows; in this case Z1RE, Z1IM, Z2RE +C and Z2IM are unassigned; +C = 2: if on entry, A = 0.0; in this case Z1RE contains +C BIG and Z1IM contains zero, where BIG is a +C representable number near the overflow threshold +C of the machine (see LAPACK Library Routine DLAMCH); +C = 3: if on entry, either C = 0.0 and the root -B/A +C overflows or A, B and C are non-zero and the largest +C real root in magnitude cannot be computed without +C overflow; in this case Z1RE contains BIG and Z1IM +C contains zero; +C = 4: if the roots cannot be computed without overflow; in +C this case Z1RE, Z1IM, Z2RE and Z2IM are unassigned. +C +C METHOD +C +C The routine computes the roots (r1 and r2) of the real quadratic +C equation +C 2 +C a * x + b * x + c = 0 +C +C as +C - b - SIGN(b) * SQRT(b * b - 4 * a * c) c +C r1 = --------------------------------------- and r2 = ------ +C 2 * a a * r1 +C +C unless a = 0, in which case +C +C -c +C r1 = --. +C b +C +C Precautions are taken to avoid overflow and underflow wherever +C possible. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01JD by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Quadratic equation, zeros. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, FOUR + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, FOUR=4.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO + DOUBLE PRECISION A, B, C, Z1IM, Z1RE, Z2IM, Z2RE +C .. Local Scalars .. + LOGICAL OVFLOW + INTEGER BETA, EA, EAPLEC, EB, EB2, EC, ED + DOUBLE PRECISION ABSA, ABSB, ABSC, BIG, M1, M2, MA, MB, MC, MD, + $ SFMIN, W +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. External Subroutines .. + EXTERNAL MC01SW, MC01SY +C .. Intrinsic Functions .. + INTRINSIC ABS, MOD, SIGN, SQRT +C .. Executable Statements .. +C +C Detect special cases. +C + INFO = 0 + BETA = DLAMCH( 'Base' ) + SFMIN = DLAMCH( 'Safe minimum' ) + BIG = ONE/SFMIN + IF ( A.EQ.ZERO ) THEN + IF ( B.EQ.ZERO ) THEN + INFO = 1 + ELSE + OVFLOW = .FALSE. + Z2RE = ZERO + IF ( C.NE.ZERO ) THEN + ABSB = ABS( B ) + IF ( ABSB.GE.ONE ) THEN + IF ( ABS( C ).GE.ABSB*SFMIN ) Z2RE = -C/B + ELSE + IF ( ABS( C ).LE.ABSB*BIG ) THEN + Z2RE = -C/B + ELSE + OVFLOW = .TRUE. + Z2RE = BIG + IF ( SIGN( ONE, B )*SIGN( ONE, C ).GT.ZERO ) + $ Z2RE = -BIG + END IF + END IF + END IF + IF ( OVFLOW ) THEN + INFO = 1 + ELSE + Z1RE = BIG + Z1IM = ZERO + Z2IM = ZERO + INFO = 2 + END IF + END IF + RETURN + END IF +C + IF ( C.EQ.ZERO ) THEN + OVFLOW = .FALSE. + Z1RE = ZERO + IF ( B.NE.ZERO ) THEN + ABSA = ABS( A ) + IF ( ABSA.GE.ONE ) THEN + IF ( ABS( B ).GE.ABSA*SFMIN ) Z1RE = -B/A + ELSE + IF ( ABS( B ).LE.ABSA*BIG ) THEN + Z1RE = -B/A + ELSE + OVFLOW = .TRUE. + Z1RE = BIG + END IF + END IF + END IF + IF ( OVFLOW ) INFO = 3 + Z1IM = ZERO + Z2RE = ZERO + Z2IM = ZERO + RETURN + END IF +C +C A and C are non-zero. +C + IF ( B.EQ.ZERO ) THEN + OVFLOW = .FALSE. + ABSC = SQRT( ABS( C ) ) + ABSA = SQRT( ABS( A ) ) + W = ZERO + IF ( ABSA.GE.ONE ) THEN + IF ( ABSC.GE.ABSA*SFMIN ) W = ABSC/ABSA + ELSE + IF ( ABSC.LE.ABSA*BIG ) THEN + W = ABSC/ABSA + ELSE + OVFLOW = .TRUE. + W = BIG + END IF + END IF + IF ( OVFLOW ) THEN + INFO = 4 + ELSE + IF ( SIGN( ONE, A )*SIGN( ONE, C ).GT.ZERO ) THEN + Z1RE = ZERO + Z2RE = ZERO + Z1IM = W + Z2IM = -W + ELSE + Z1RE = W + Z2RE = -W + Z1IM = ZERO + Z2IM = ZERO + END IF + END IF + RETURN + END IF +C +C A, B and C are non-zero. +C + CALL MC01SW( A, BETA, MA, EA ) + CALL MC01SW( B, BETA, MB, EB ) + CALL MC01SW( C, BETA, MC, EC ) +C +C Compute a 'near' floating-point representation of the discriminant +C D = MD * BETA**ED. +C + EAPLEC = EA + EC + EB2 = 2*EB + IF ( EAPLEC.GT.EB2 ) THEN + CALL MC01SY( MB*MB, EB2-EAPLEC, BETA, W, OVFLOW ) + W = W - FOUR*MA*MC + CALL MC01SW( W, BETA, MD, ED ) + ED = ED + EAPLEC + ELSE + CALL MC01SY( FOUR*MA*MC, EAPLEC-EB2, BETA, W, OVFLOW ) + W = MB*MB - W + CALL MC01SW( W, BETA, MD, ED ) + ED = ED + EB2 + END IF +C + IF ( MOD( ED, 2 ).NE.0 ) THEN + ED = ED + 1 + MD = MD/BETA + END IF +C +C Complex roots. +C + IF ( MD.LT.ZERO ) THEN + CALL MC01SY( -MB/( 2*MA ), EB-EA, BETA, Z1RE, OVFLOW ) + IF ( OVFLOW ) THEN + INFO = 4 + ELSE + CALL MC01SY( SQRT( -MD )/( 2*MA ), ED/2-EA, BETA, Z1IM, + $ OVFLOW ) + IF ( OVFLOW ) THEN + INFO = 4 + ELSE + Z2RE = Z1RE + Z2IM = -Z1IM + END IF + END IF + RETURN + END IF +C +C Real roots. +C + MD = SQRT( MD ) + ED = ED/2 + IF ( ED.GT.EB ) THEN + CALL MC01SY( ABS( MB ), EB-ED, BETA, W, OVFLOW ) + W = W + MD + M1 = -SIGN( ONE, MB )*W/( 2*MA ) + CALL MC01SY( M1, ED-EA, BETA, Z1RE, OVFLOW ) + IF ( OVFLOW ) THEN + Z1RE = BIG + INFO = 3 + END IF + M2 = -SIGN( ONE, MB )*2*MC/W + CALL MC01SY( M2, EC-ED, BETA, Z2RE, OVFLOW ) + ELSE + CALL MC01SY( MD, ED-EB, BETA, W, OVFLOW ) + W = W + ABS( MB ) + M1 = -SIGN( ONE, MB )*W/( 2*MA ) + CALL MC01SY( M1, EB-EA, BETA, Z1RE, OVFLOW ) + IF ( OVFLOW ) THEN + Z1RE = BIG + INFO = 3 + END IF + M2 = -SIGN( ONE, MB )*2*MC/W + CALL MC01SY( M2, EC-EB, BETA, Z2RE, OVFLOW ) + END IF + Z1IM = ZERO + Z2IM = ZERO +C + RETURN +C *** Last line of MC01VD *** + END diff --git a/mex/sources/libslicot/MC01WD.f b/mex/sources/libslicot/MC01WD.f new file mode 100644 index 000000000..5ef42154c --- /dev/null +++ b/mex/sources/libslicot/MC01WD.f @@ -0,0 +1,156 @@ + SUBROUTINE MC01WD( DP, P, U1, U2, Q, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute, for a given real polynomial P(x) and a quadratic +C polynomial B(x), the quotient polynomial Q(x) and the linear +C remainder polynomial R(x) such that +C +C P(x) = B(x) * Q(x) + R(x), +C +C 2 +C where B(x) = u1 + u2 * x + x , R(x) = q(1) + q(2) * (u2 + x) +C and u1, u2, q(1) and q(2) are real scalars. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C DP (input) INTEGER +C The degree of the polynomial P(x). DP >= 0. +C +C P (input) DOUBLE PRECISION array, dimension (DP+1) +C This array must contain the coefficients of P(x) in +C increasing powers of x. +C +C U1 (input) DOUBLE PRECISION +C The value of the constant term of the quadratic +C polynomial B(x). +C +C U2 (input) DOUBLE PRECISION +C The value of the coefficient of x of the quadratic +C polynomial B(x). +C +C Q (output) DOUBLE PRECISION array, dimension (DP+1) +C If DP >= 1 on entry, then elements Q(1) and Q(2) contain +C the coefficients q(1) and q(2), respectively, of the +C remainder polynomial R(x), and the next (DP-1) elements +C of this array contain the coefficients of the quotient +C polynomial Q(x) in increasing powers of x. +C If DP = 0 on entry, then element Q(1) contains the +C coefficient q(1) of the remainder polynomial R(x) = q(1); +C Q(x) is the zero polynomial. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given the real polynomials +C +C DP i 2 +C P(x) = SUM p(i+1) * x and B(x) = u1 + u2 * x + x +C i=0 +C +C the routine uses the recurrence relationships +C +C q(DP+1) = p(DP+1), +C +C q(DP) = p(DP) - u2 * q(DP+1) and +C +C q(i) = p(i) - u2 * q(i+1) - u1 * q(i+2) for i = DP-1, ..., 1 +C +C to determine the coefficients of the quotient polynomial +C +C DP-2 i +C Q(x) = SUM q(i+3) * x +C i=0 +C +C and the remainder polynomial +C +C R(x) = q(1) + q(2) * (u2 + x). +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01KD by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations, +C quadratic polynomial. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER DP, INFO + DOUBLE PRECISION U1, U2 +C .. Array Arguments .. + DOUBLE PRECISION P(*), Q(*) +C .. Local Scalars .. + INTEGER I, N + DOUBLE PRECISION A, B, C +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + IF ( DP.LT.0 ) THEN + INFO = -1 + CALL XERBLA( 'MC01WD', -INFO ) + RETURN + END IF +C + INFO = 0 + N = DP + 1 + Q(N) = P(N) + IF ( N.GT.1 ) THEN + B = Q(N) + Q(N-1) = P(N-1) - U2*B + IF ( N.GT.2 ) THEN + A = Q(N-1) +C + DO 20 I = N - 2, 1, -1 + C = P(I) - U2*A - U1*B + Q(I) = C + B = A + A = C + 20 CONTINUE +C + END IF + END IF +C + RETURN +C *** Last line of MC01WD *** + END diff --git a/mex/sources/libslicot/MC03MD.f b/mex/sources/libslicot/MC03MD.f new file mode 100644 index 000000000..36e69719c --- /dev/null +++ b/mex/sources/libslicot/MC03MD.f @@ -0,0 +1,351 @@ + SUBROUTINE MC03MD( RP1, CP1, CP2, DP1, DP2, DP3, ALPHA, P1, + $ LDP11, LDP12, P2, LDP21, LDP22, P3, LDP31, + $ LDP32, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients of the real polynomial matrix +C +C P(x) = P1(x) * P2(x) + alpha * P3(x), +C +C where P1(x), P2(x) and P3(x) are given real polynomial matrices +C and alpha is a real scalar. +C +C Each of the polynomial matrices P1(x), P2(x) and P3(x) may be the +C zero matrix. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C RP1 (input) INTEGER +C The number of rows of the matrices P1(x) and P3(x). +C RP1 >= 0. +C +C CP1 (input) INTEGER +C The number of columns of matrix P1(x) and the number of +C rows of matrix P2(x). CP1 >= 0. +C +C CP2 (input) INTEGER +C The number of columns of the matrices P2(x) and P3(x). +C CP2 >= 0. +C +C DP1 (input) INTEGER +C The degree of the polynomial matrix P1(x). DP1 >= -1. +C +C DP2 (input) INTEGER +C The degree of the polynomial matrix P2(x). DP2 >= -1. +C +C DP3 (input/output) INTEGER +C On entry, the degree of the polynomial matrix P3(x). +C DP3 >= -1. +C On exit, the degree of the polynomial matrix P(x). +C +C ALPHA (input) DOUBLE PRECISION +C The scalar value alpha of the problem. +C +C P1 (input) DOUBLE PRECISION array, dimension (LDP11,LDP12,*) +C If DP1 >= 0, then the leading RP1-by-CP1-by-(DP1+1) part +C of this array must contain the coefficients of the +C polynomial matrix P1(x). Specifically, P1(i,j,k) must +C contain the coefficient of x**(k-1) of the polynomial +C which is the (i,j)-th element of P1(x), where i = 1,2,..., +C RP1, j = 1,2,...,CP1 and k = 1,2,...,DP1+1. +C If DP1 = -1, then P1(x) is taken to be the zero polynomial +C matrix, P1 is not referenced and can be supplied as a +C dummy array (i.e. set the parameters LDP11 = LDP12 = 1 and +C declare this array to be P1(1,1,1) in the calling +C program). +C +C LDP11 INTEGER +C The leading dimension of array P1. +C LDP11 >= MAX(1,RP1) if DP1 >= 0, +C LDP11 >= 1 if DP1 = -1. +C +C LDP12 INTEGER +C The second dimension of array P1. +C LDP12 >= MAX(1,CP1) if DP1 >= 0, +C LDP12 >= 1 if DP1 = -1. +C +C P2 (input) DOUBLE PRECISION array, dimension (LDP21,LDP22,*) +C If DP2 >= 0, then the leading CP1-by-CP2-by-(DP2+1) part +C of this array must contain the coefficients of the +C polynomial matrix P2(x). Specifically, P2(i,j,k) must +C contain the coefficient of x**(k-1) of the polynomial +C which is the (i,j)-th element of P2(x), where i = 1,2,..., +C CP1, j = 1,2,...,CP2 and k = 1,2,...,DP2+1. +C If DP2 = -1, then P2(x) is taken to be the zero polynomial +C matrix, P2 is not referenced and can be supplied as a +C dummy array (i.e. set the parameters LDP21 = LDP22 = 1 and +C declare this array to be P2(1,1,1) in the calling +C program). +C +C LDP21 INTEGER +C The leading dimension of array P2. +C LDP21 >= MAX(1,CP1) if DP2 >= 0, +C LDP21 >= 1 if DP2 = -1. +C +C LDP22 INTEGER +C The second dimension of array P2. +C LDP22 >= MAX(1,CP2) if DP2 >= 0, +C LDP22 >= 1 if DP2 = -1. +C +C P3 (input/output) DOUBLE PRECISION array, dimension +C (LDP31,LDP32,n), where n = MAX(DP1+DP2,DP3,0)+1. +C On entry, if DP3 >= 0, then the leading +C RP1-by-CP2-by-(DP3+1) part of this array must contain the +C coefficients of the polynomial matrix P3(x). Specifically, +C P3(i,j,k) must contain the coefficient of x**(k-1) of the +C polynomial which is the (i,j)-th element of P3(x), where +C i = 1,2,...,RP1, j = 1,2,...,CP2 and k = 1,2,...,DP3+1. +C If DP3 = -1, then P3(x) is taken to be the zero polynomial +C matrix. +C On exit, if DP3 >= 0 on exit (ALPHA <> 0.0 and DP3 <> -1, +C on entry, or DP1 <> -1 and DP2 <> -1), then the leading +C RP1-by-CP2-by-(DP3+1) part of this array contains the +C coefficients of P(x). Specifically, P3(i,j,k) contains the +C coefficient of x**(k-1) of the polynomial which is the +C (i,j)-th element of P(x), where i = 1,2,...,RP1, j = 1,2, +C ...,CP2 and k = 1,2,...,DP3+1. +C If DP3 = -1 on exit, then the coefficients of P(x) (the +C zero polynomial matrix) are not stored in the array. +C +C LDP31 INTEGER +C The leading dimension of array P3. LDP31 >= MAX(1,RP1). +C +C LDP32 INTEGER +C The second dimension of array P3. LDP32 >= MAX(1,CP2). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (CP1) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given real polynomial matrices +C +C DP1 i +C P1(x) = SUM (A(i+1) * x ), +C i=0 +C +C DP2 i +C P2(x) = SUM (B(i+1) * x ), +C i=0 +C +C DP3 i +C P3(x) = SUM (C(i+1) * x ) +C i=0 +C +C and a real scalar alpha, the routine computes the coefficients +C d ,d ,..., of the polynomial matrix +C 1 2 +C +C P(x) = P1(x) * P2(x) + alpha * P3(x) +C +C from the formula +C +C s +C d = SUM (A(k+1) * B(i-k+1)) + alpha * C(i+1), +C i+1 k=r +C +C where i = 0,1,...,DP1+DP2 and r and s depend on the value of i +C (e.g. if i <= DP1 and i <= DP2, then r = 0 and s = i). +C +C NUMERICAL ASPECTS +C +C None. +C +C FURTHER COMMENTS +C +C Other elementary operations involving polynomial matrices can +C easily be obtained by calling the appropriate BLAS routine(s). +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC03AD by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, input output description, +C polynomial matrix, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER CP1, CP2, DP1, DP2, DP3, INFO, LDP11, LDP12, + $ LDP21, LDP22, LDP31, LDP32, RP1 + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), P1(LDP11,LDP12,*), P2(LDP21,LDP22,*), + $ P3(LDP31,LDP32,*) +C .. Local Scalars .. + LOGICAL CFZERO + INTEGER DPOL3, E, H, I, J, K +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL DCOPY, DLASET, DSCAL, XERBLA +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( RP1.LT.0 ) THEN + INFO = -1 + ELSE IF( CP1.LT.0 ) THEN + INFO = -2 + ELSE IF( CP2.LT.0 ) THEN + INFO = -3 + ELSE IF( DP1.LT.-1 ) THEN + INFO = -4 + ELSE IF( DP2.LT.-1 ) THEN + INFO = -5 + ELSE IF( DP3.LT.-1 ) THEN + INFO = -6 + ELSE IF( ( DP1.EQ.-1 .AND. LDP11.LT.1 ) .OR. + $ ( DP1.GE. 0 .AND. LDP11.LT.MAX( 1, RP1 ) ) ) THEN + INFO = -9 + ELSE IF( ( DP1.EQ.-1 .AND. LDP12.LT.1 ) .OR. + $ ( DP1.GE. 0 .AND. LDP12.LT.MAX( 1, CP1 ) ) ) THEN + INFO = -10 + ELSE IF( ( DP2.EQ.-1 .AND. LDP21.LT.1 ) .OR. + $ ( DP2.GE. 0 .AND. LDP21.LT.MAX( 1, CP1 ) ) ) THEN + INFO = -12 + ELSE IF( ( DP2.EQ.-1 .AND. LDP22.LT.1 ) .OR. + $ ( DP2.GE. 0 .AND. LDP22.LT.MAX( 1, CP2 ) ) ) THEN + INFO = -13 + ELSE IF( LDP31.LT.MAX( 1, RP1 ) ) THEN + INFO = -15 + ELSE IF( LDP32.LT.MAX( 1, CP2 ) ) THEN + INFO = -16 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MC03MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( RP1.EQ.0 .OR. CP2.EQ.0 ) + $ RETURN +C + IF ( ALPHA.EQ.ZERO ) + $ DP3 = -1 +C + IF ( DP3.GE.0 ) THEN +C +C P3(x) := ALPHA * P3(x). +C + DO 40 K = 1, DP3 + 1 +C + DO 20 J = 1, CP2 + CALL DSCAL( RP1, ALPHA, P3(1,J,K), 1 ) + 20 CONTINUE +C + 40 CONTINUE + END IF +C + IF ( ( DP1.EQ.-1 ) .OR. ( DP2.EQ.-1 ) .OR. ( CP1.EQ.0 ) ) + $ RETURN +C +C Neither of P1(x) and P2(x) is the zero polynomial. +C + DPOL3 = DP1 + DP2 + IF ( DPOL3.GT.DP3 ) THEN +C +C Initialize the additional part of P3(x) to zero. +C + DO 80 K = DP3 + 2, DPOL3 + 1 + CALL DLASET( 'Full', RP1, CP2, ZERO, ZERO, P3(1,1,K), + $ LDP31 ) + 80 CONTINUE +C + DP3 = DPOL3 + END IF +C k-1 +C The inner product of the j-th row of the coefficient of x of P1 +C i-1 +C and the h-th column of the coefficient of x of P2(x) contribute +C k+i-2 +C the (j,h)-th element of the coefficient of x of P3(x). +C + DO 160 K = 1, DP1 + 1 +C + DO 140 J = 1, RP1 + CALL DCOPY( CP1, P1(J,1,K), LDP11, DWORK, 1 ) +C + DO 120 I = 1, DP2 + 1 + E = K + I - 1 +C + DO 100 H = 1, CP2 + P3(J,H,E) = DDOT( CP1, DWORK, 1, P2(1,H,I), 1 ) + + $ P3(J,H,E) + 100 CONTINUE +C + 120 CONTINUE +C + 140 CONTINUE +C + 160 CONTINUE +C +C Computation of the exact degree of P3(x). +C + CFZERO = .TRUE. +C WHILE ( DP3 >= 0 and CFZERO ) DO + 180 IF ( ( DP3.GE.0 ) .AND. CFZERO ) THEN + DPOL3 = DP3 + 1 +C + DO 220 J = 1, CP2 +C + DO 200 I = 1, RP1 + IF ( P3(I,J,DPOL3 ).NE.ZERO ) CFZERO = .FALSE. + 200 CONTINUE +C + 220 CONTINUE +C + IF ( CFZERO ) DP3 = DP3 - 1 + GO TO 180 + END IF +C END WHILE 180 +C + RETURN +C *** Last line of MC03MD *** + END diff --git a/mex/sources/libslicot/MC03ND.f b/mex/sources/libslicot/MC03ND.f new file mode 100644 index 000000000..5ee0fd02a --- /dev/null +++ b/mex/sources/libslicot/MC03ND.f @@ -0,0 +1,495 @@ + SUBROUTINE MC03ND( MP, NP, DP, P, LDP1, LDP2, DK, GAM, NULLSP, + $ LDNULL, KER, LDKER1, LDKER2, TOL, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients of a minimal polynomial basis +C DK +C K(s) = K(0) + K(1) * s + ... + K(DK) * s +C +C for the right nullspace of the MP-by-NP polynomial matrix of +C degree DP, given by +C DP +C P(s) = P(0) + P(1) * s + ... + P(DP) * s , +C +C which corresponds to solving the polynomial matrix equation +C P(s) * K(s) = 0. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C MP (input) INTEGER +C The number of rows of the polynomial matrix P(s). +C MP >= 0. +C +C NP (input) INTEGER +C The number of columns of the polynomial matrix P(s). +C NP >= 0. +C +C DP (input) INTEGER +C The degree of the polynomial matrix P(s). DP >= 1. +C +C P (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1) +C The leading MP-by-NP-by-(DP+1) part of this array must +C contain the coefficients of the polynomial matrix P(s). +C Specifically, P(i,j,k) must contain the (i,j)-th element +C of P(k-1), which is the cofficient of s**(k-1) of P(s), +C where i = 1,2,...,MP, j = 1,2,...,NP and k = 1,2,...,DP+1. +C +C LDP1 INTEGER +C The leading dimension of array P. LDP1 >= MAX(1,MP). +C +C LDP2 INTEGER +C The second dimension of array P. LDP2 >= MAX(1,NP). +C +C DK (output) INTEGER +C The degree of the minimal polynomial basis K(s) for the +C right nullspace of P(s) unless DK = -1, in which case +C there is no right nullspace. +C +C GAM (output) INTEGER array, dimension (DP*MP+1) +C The leading (DK+1) elements of this array contain +C information about the ordering of the right nullspace +C vectors stored in array NULLSP. +C +C NULLSP (output) DOUBLE PRECISION array, dimension +C (LDNULL,(DP*MP+1)*NP) +C The leading NP-by-SUM(i*GAM(i)) part of this array +C contains the right nullspace vectors of P(s) in condensed +C form (as defined in METHOD), where i = 1,2,...,DK+1. +C +C LDNULL INTEGER +C The leading dimension of array NULLSP. +C LDNULL >= MAX(1,NP). +C +C KER (output) DOUBLE PRECISION array, dimension +C (LDKER1,LDKER2,DP*MP+1) +C The leading NP-by-nk-by-(DK+1) part of this array contains +C the coefficients of the minimal polynomial basis K(s), +C where nk = SUM(GAM(i)) and i = 1,2,...,DK+1. Specifically, +C KER(i,j,m) contains the (i,j)-th element of K(m-1), which +C is the coefficient of s**(m-1) of K(s), where i = 1,2,..., +C NP, j = 1,2,...,nk and m = 1,2,...,DK+1. +C +C LDKER1 INTEGER +C The leading dimension of array KER. LDKER1 >= MAX(1,NP). +C +C LDKER2 INTEGER +C The second dimension of array KER. LDKER2 >= MAX(1,NP). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance below which matrix elements are considered +C to be zero. If the user sets TOL to be less than +C 10 * EPS * MAX( ||A|| , ||E|| ), then the tolerance is +C F F +C taken as 10 * EPS * MAX( ||A|| , ||E|| ), where EPS is the +C F F +C machine precision (see LAPACK Library Routine DLAMCH) and +C A and E are matrices (as defined in METHOD). +C +C Workspace +C +C IWORK INTEGER array, dimension (m+2*MAX(n,m+1)+n), +C where m = DP*MP and n = (DP-1)*MP + NP. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK The length of the array DWORK. +C LDWORK >= m*n*n + 2*m*n + 2*n*n. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C > 0: if incorrect rank decisions were taken during the +C computations. This failure is not likely to occur. +C The possible values are: +C k, 1 <= k <= DK+1, the k-th diagonal submatrix had +C not a full row rank; +C DK+2, if incorrect dimensions of a full column +C rank submatrix; +C DK+3, if incorrect dimensions of a full row rank +C submatrix. +C +C METHOD +C +C The computation of the right nullspace of the MP-by-NP polynomial +C matrix P(s) of degree DP given by +C DP-1 DP +C P(s) = P(0) + P(1) * s + ... + P(DP-1) * s + P(DP) * s +C +C is performed via the pencil s*E - A, associated with P(s), where +C +C | I | | 0 -P(DP) | +C | . | | I . . | +C A = | . | and E = | . . . |. (1) +C | . | | . 0 . | +C | I | | I 0 -P(2) | +C | P(0) | | I -P(1) | +C +C The pencil s*E - A is transformed by unitary matrices Q and Z such +C that +C +C | sE(eps)-A(eps) | X | X | +C |----------------|----------------|------------| +C | 0 | sE(inf)-A(inf) | X | +C Q'(s*E-A)Z = |=================================|============|. +C | | | +C | 0 | sE(r)-A(r) | +C +C Since s*E(inf)-A(inf) and s*E(r)-A(r) have full column rank, the +C minimal polynomial basis for the right nullspace of Q'(s*E-A)Z +C (and consequently the basis for the right nullspace of s*E - A) is +C completely determined by s*E(eps)-A(eps). +C +C Let Veps(s) be a minimal polynomial basis for the right nullspace +C of s*E(eps)-A(eps). Then +C +C | Veps(s) | +C V(s) = Z * |---------| +C | 0 | +C +C is a minimal polynomial basis for the right nullspace of s*E - A. +C From the structure of s*E - A it can be shown that if V(s) is +C partitioned as +C +C | Vo(s) | (DP-1)*MP +C V(s) = |------ | +C | Ve(s) | NP +C +C then the columns of Ve(s) form a minimal polynomial basis for the +C right nullspace of P(s). +C +C The vectors of Ve(s) are computed and stored in array NULLSP in +C the following condensed form: +C +C || || | || | | || | | +C || U1,0 || U2,0 | U2,1 || U3,0 | U3,1 | U3,2 || U4,0 | ... |, +C || || | || | | || | | +C +C where Ui,j is an NP-by-GAM(i) matrix which contains the i-th block +C of columns of K(j), the j-th coefficient of the polynomial matrix +C representation for the right nullspace +C DK +C K(s) = K(0) + K(1) * s + . . . + K(DK) * s . +C +C The coefficients K(0), K(1), ..., K(DK) are NP-by-nk matrices +C given by +C +C K(0) = | U1,0 | U2,0 | U3,0 | . . . | U(DK+1,0) | +C +C K(1) = | 0 | U2,1 | U3,1 | . . . | U(DK+1,1) | +C +C K(2) = | 0 | 0 | U3,2 | . . . | U(DK+1,2) | +C +C . . . . . . . . . . +C +C K(DK) = | 0 | 0 | 0 | . . . | 0 | U(DK+1,DK)|. +C +C Note that the degree of K(s) satisfies the inequality DK <= +C DP * MIN(MP,NP) and that the dimension of K(s) satisfies the +C inequality (NP-MP) <= nk <= NP. +C +C REFERENCES +C +C [1] Beelen, Th.G.J. +C New Algorithms for Computing the Kronecker structure of a +C Pencil with Applications to Systems and Control Theory. +C Ph.D.Thesis, Eindhoven University of Technology, 1987. +C +C [2] Van Den Hurk, G.J.H.H. +C New Algorithms for Solving Polynomial Matrix Problems. +C Master's Thesis, Eindhoven University of Technology, 1987. +C +C NUMERICAL ASPECTS +C +C The algorithm used by the routine involves the construction of a +C special block echelon form with pivots considered to be non-zero +C when they are larger than TOL. These pivots are then inverted in +C order to construct the columns of the kernel of the polynomial +C matrix. If TOL is chosen to be too small then these inversions may +C be sensitive whereas increasing TOL will make the inversions more +C robust but will affect the block echelon form (and hence the +C column degrees of the polynomial kernel). Furthermore, if the +C elements of the computed polynomial kernel are large relative to +C the polynomial matrix, then the user should consider trying +C several values of TOL. +C +C FURTHER COMMENTS +C +C It also possible to compute a minimal polynomial basis for the +C right nullspace of a pencil, since a pencil is a polynomial matrix +C of degree 1. Thus for the pencil (s*E - A), the required input is +C P(1) = E and P(0) = -A. +C +C The routine can also be used to compute a minimal polynomial +C basis for the left nullspace of a polynomial matrix by simply +C transposing P(s). +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC03BD by A.J. Geurts and MC03BZ by +C Th.G.J. Beelen, A.J. Geurts, and G.J.H.H. van den Hurk. +C +C REVISIONS +C +C Jan. 1998. +C +C KEYWORDS +C +C Echelon form, elementary polynomial operations, input output +C description, polynomial matrix, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TEN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 ) +C .. Scalar Arguments .. + INTEGER DK, DP, INFO, LDKER1, LDKER2, LDNULL, LDP1, + $ LDP2, LDWORK, MP, NP + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER GAM(*), IWORK(*) + DOUBLE PRECISION DWORK(*), KER(LDKER1,LDKER2,*), + $ NULLSP(LDNULL,*), P(LDP1,LDP2,*) +C .. Local Scalars .. + INTEGER GAMJ, H, I, IDIFF, IFIR, J, JWORKA, JWORKE, + $ JWORKQ, JWORKV, JWORKZ, K, M, MUK, N, NBLCKS, + $ NBLCKI, NCA, NCV, NRA, NUK, RANKE, SGAMK, TAIL, + $ VC1, VR2 + DOUBLE PRECISION TOLER +C .. Local Arrays .. + INTEGER MNEI(3) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 + EXTERNAL DLAMCH, DLANGE, DLAPY2 +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASET, MB04UD, MB04VD, MC03NX, + $ MC03NY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, SQRT +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + M = DP*MP + H = M - MP + N = H + NP + INFO = 0 + IF( MP.LT.0 ) THEN + INFO = -1 + ELSE IF( NP.LT.0 ) THEN + INFO = -2 + ELSE IF( DP.LE.0 ) THEN + INFO = -3 + ELSE IF( LDP1.LT.MAX( 1, MP ) ) THEN + INFO = -5 + ELSE IF( LDP2.LT.MAX( 1, NP ) ) THEN + INFO = -6 + ELSE IF( LDNULL.LT.MAX( 1, NP ) ) THEN + INFO = -10 + ELSE IF( LDKER1.LT.MAX( 1, NP ) ) THEN + INFO = -12 + ELSE IF( LDKER2.LT.MAX( 1, NP ) ) THEN + INFO = -13 + ELSE IF( LDWORK.LT.( N*( M*N + 2*( M + N ) ) ) ) THEN + INFO = -17 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MC03ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MP.EQ.0 .OR. NP.EQ.0 ) THEN + DK = -1 + RETURN + END IF +C + JWORKA = 1 + JWORKE = JWORKA + M*N + JWORKZ = JWORKE + M*N + JWORKV = JWORKZ + N*N + JWORKQ = JWORKA +C +C Construct the matrices A and E in the pencil s*E-A in (1). +C Workspace: 2*M*N. +C + CALL MC03NX( MP, NP, DP, P, LDP1, LDP2, DWORK(JWORKA), M, + $ DWORK(JWORKE), M ) +C +C Computation of the tolerance. +C + TOLER = MAX( DLANGE( 'F', M, NP, DWORK(JWORKE+H*M), M, DWORK ), + $ DLANGE( 'F', MP, NP, P, LDP1, DWORK ) ) + TOLER = TEN*DLAMCH( 'Epsilon' ) + $ *DLAPY2( TOLER, SQRT( DBLE( H ) ) ) + IF ( TOLER.LE.TOL ) TOLER = TOL +C +C Reduction of E to column echelon form E0 = Q' x E x Z and +C transformation of A, A0 = Q' x A x Z. +C Workspace: 2*M*N + N*N + max(M,N). +C + CALL MB04UD( 'No Q', 'Identity Z', M, N, DWORK(JWORKA), M, + $ DWORK(JWORKE), M, DWORK(JWORKQ), M, DWORK(JWORKZ), N, + $ RANKE, IWORK, TOLER, DWORK(JWORKV), INFO ) +C +C The contents of ISTAIR is transferred from MB04UD to MB04VD by +C IWORK(i), i=1,...,M. +C In the sequel the arrays IMUK and INUK are part of IWORK, namely: +C IWORK(i), i = M+1,...,M+max(N,M+1), contains IMUK, +C IWORK(i), i = M+max(N,M+1)+1,...,M+2*max(N,M+1), contains INUK. +C IWORK(i), i = M+2*max(N,M+1)+1,...,M+2*max(N,M+1)+N, contains +C IMUK0 (not needed), and is also used as workspace. +C + MUK = M + 1 + NUK = MUK + MAX( N, M+1 ) + TAIL = NUK + MAX( N, M+1 ) +C + CALL MB04VD( 'Separation', 'No Q', 'Update Z', M, N, RANKE, + $ DWORK(JWORKA), M, DWORK(JWORKE), M, DWORK(JWORKQ), M, + $ DWORK(JWORKZ), N, IWORK, NBLCKS, NBLCKI, IWORK(MUK), + $ IWORK(NUK), IWORK(TAIL), MNEI, TOLER, IWORK(TAIL), + $ INFO ) + IF ( INFO.GT.0 ) THEN +C +C Incorrect rank decisions. +C + INFO = INFO + NBLCKS + RETURN + END IF +C +C If NBLCKS < 1, or the column dimension of s*E(eps) - A(eps) is +C zero, then there is no right nullspace. +C + IF ( NBLCKS.LT.1 .OR. MNEI(2).EQ.0 ) THEN + DK = -1 + RETURN + END IF +C +C Start of the computation of the minimal basis. +C + DK = NBLCKS - 1 + NRA = MNEI(1) + NCA = MNEI(2) +C +C Determine a minimal basis VEPS(s) for the right nullspace of the +C pencil s*E(eps)-A(eps) associated with the polynomial matrix P(s). +C Workspace: 2*M*N + N*N + N*N*(M+1). +C + CALL MC03NY( NBLCKS, NRA, NCA, DWORK(JWORKA), M, DWORK(JWORKE), M, + $ IWORK(MUK), IWORK(NUK), DWORK(JWORKV), N, INFO ) +C + IF ( INFO.GT.0 ) + $ RETURN +C + NCV = IWORK(MUK) - IWORK(NUK) + GAM(1) = NCV + IWORK(1) = 0 + IWORK(TAIL) = IWORK(MUK) +C + DO 20 I = 2, NBLCKS + IDIFF = IWORK(MUK+I-1) - IWORK(NUK+I-1) + GAM(I) = IDIFF + IWORK(I) = NCV + NCV = NCV + I*IDIFF + IWORK(TAIL+I-1) = IWORK(TAIL+I-2) + IWORK(MUK+I-1) + 20 CONTINUE +C +C Determine a basis for the right nullspace of the polynomial +C matrix P(s). This basis is stored in array NULLSP in condensed +C form. +C + CALL DLASET( 'Full', NP, NCV, ZERO, ZERO, NULLSP, LDNULL ) +C +C |VEPS(s)| +C The last NP rows of the product matrix Z x |-------| contain the +C | 0 | +C polynomial basis for the right nullspace of the polynomial matrix +C P(s) in condensed form. The multiplication is restricted to the +C nonzero submatrices Vij,k of VEPS, the result is stored in the +C array NULLSP. +C + VC1 = 1 +C + DO 60 I = 1, NBLCKS + VR2 = IWORK(TAIL+I-1) +C + DO 40 J = 1, I +C +C Multiplication of Z(H+1:N,1:VR2) with V.i,j-1 stored in +C VEPS(1:VR2,VC1:VC1+GAM(I)-1). +C + CALL DGEMM( 'No transpose', 'No transpose', NP, GAM(I), VR2, + $ ONE, DWORK(JWORKZ+H), N, + $ DWORK(JWORKV+(VC1-1)*N), N, ZERO, NULLSP(1,VC1), + $ LDNULL ) + VC1 = VC1 + GAM(I) + VR2 = VR2 - IWORK(MUK+I-J) + 40 CONTINUE +C + 60 CONTINUE +C +C Transfer of the columns of NULLSP to KER in order to obtain the +C polynomial matrix representation of K(s), the right nullspace +C of P(s). +C + SGAMK = 1 +C + DO 100 K = 1, NBLCKS + CALL DLASET( 'Full', NP, SGAMK-1, ZERO, ZERO, KER(1,1,K), + $ LDKER1 ) + IFIR = SGAMK +C +C Copy the appropriate columns of NULLSP into KER(k). +C SGAMK = 1 + SUM(i=1,..,k-1) GAM(i), is the first nontrivial +C column of KER(k), the first SGAMK - 1 columns of KER(k) are +C zero. IFIR denotes the position of the first column in KER(k) +C in the set of columns copied for a value of J. +C VC1 is the first column of NULLSP to be copied. +C + DO 80 J = K, NBLCKS + GAMJ = GAM(J) + VC1 = IWORK(J) + (K-1)*GAMJ + 1 + CALL DLACPY( 'Full', NP, GAMJ, NULLSP(1,VC1), LDNULL, + $ KER(1,IFIR,K), LDKER1 ) + IFIR = IFIR + GAMJ + 80 CONTINUE +C + SGAMK = SGAMK + GAM(K) + 100 CONTINUE +C + RETURN +C *** Last line of MC03ND *** + END diff --git a/mex/sources/libslicot/MC03NX.f b/mex/sources/libslicot/MC03NX.f new file mode 100644 index 000000000..7376234df --- /dev/null +++ b/mex/sources/libslicot/MC03NX.f @@ -0,0 +1,146 @@ + SUBROUTINE MC03NX( MP, NP, DP, P, LDP1, LDP2, A, LDA, E, LDE ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C Given an MP-by-NP polynomial matrix of degree dp +C dp-1 dp +C P(s) = P(0) + ... + P(dp-1) * s + P(dp) * s (1) +C +C the routine composes the related pencil s*E-A where +C +C | I | | O -P(dp) | +C | . | | I . . | +C A = | . | and E = | . . . |. (2) +C | . | | . O . | +C | I | | I O -P(2) | +C | P(0) | | I -P(1) | +C +C ================================================================== +C REMARK: This routine is intended to be called only from the SLICOT +C routine MC03ND. +C ================================================================== +C +C ARGUMENTS +C +C Input/Output Parameters +C +C MP (input) INTEGER +C The number of rows of the polynomial matrix P(s). +C MP >= 0. +C +C NP (input) INTEGER +C The number of columns of the polynomial matrix P(s). +C NP >= 0. +C +C DP (input) INTEGER +C The degree of the polynomial matrix P(s). DP >= 1. +C +C P (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1) +C The leading MP-by-NP-by-(DP+1) part of this array must +C contain the coefficients of the polynomial matrix P(s) +C in (1) in increasing powers of s. +C +C LDP1 INTEGER +C The leading dimension of array P. LDP1 >= MAX(1,MP). +C +C LDP2 INTEGER +C The second dimension of array P. LDP2 >= MAX(1,NP). +C +C A (output) DOUBLE PRECISION array, dimension +C (LDA,(DP-1)*MP+NP) +C The leading DP*MP-by-((DP-1)*MP+NP) part of this array +C contains the matrix A as described in (2). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,DP*MP). +C +C E (output) DOUBLE PRECISION array, dimension +C (LDE,(DP-1)*MP+NP) +C The leading DP*MP-by-((DP-1)*MP+NP) part of this array +C contains the matrix E as described in (2). +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,DP*MP). +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC03BX by G.J.H.H. van den Hurk. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, input output description, +C polynomial matrix, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER DP, LDA, LDE, LDP1, LDP2, MP, NP +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), E(LDE,*), P(LDP1,LDP2,*) +C .. Local Scalars .. + INTEGER H1, HB, HE, HI, J, K +C .. External Subroutines .. + EXTERNAL DLACPY, DLASET, DSCAL +C .. Executable Statements .. +C + IF ( MP.LE.0 .OR. NP.LE.0 ) + $ RETURN +C +C Initialisation of matrices A and E. +C + H1 = DP*MP + HB = H1 - MP + HE = HB + NP + CALL DLASET( 'Full', H1, HE, ZERO, ONE, A, LDA ) + CALL DLASET( 'Full', MP, HB, ZERO, ZERO, E, LDE ) + CALL DLACPY( 'Full', HB, HB, A, LDA, E(MP+1,1), LDE ) +C +C Insert the matrices P(0), P(1), ..., P(dp) at the right places +C in the matrices A and E. +C + HB = HB + 1 + CALL DLACPY( 'Full', MP, NP, P(1,1,1), LDP1, A(HB,HB), LDA ) + HI = 1 +C + DO 20 K = DP + 1, 2, -1 + CALL DLACPY( 'Full', MP, NP, P(1,1,K), LDP1, E(HI,HB), LDE ) + HI = HI + MP + 20 CONTINUE +C + DO 40 J = HB, HE + CALL DSCAL( H1, -ONE, E(1,J), 1 ) + 40 CONTINUE +C + RETURN +C *** Last line of MC03NX *** + END diff --git a/mex/sources/libslicot/MC03NY.f b/mex/sources/libslicot/MC03NY.f new file mode 100644 index 000000000..9966e02a5 --- /dev/null +++ b/mex/sources/libslicot/MC03NY.f @@ -0,0 +1,412 @@ + SUBROUTINE MC03NY( NBLCKS, NRA, NCA, A, LDA, E, LDE, IMUK, INUK, + $ VEPS, LDVEPS, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine a minimal basis of the right nullspace of the +C subpencil s*E(eps)-A(eps) using the method given in [1] (see +C Eqs.(4.6.8), (4.6.9)). +C This pencil only contains Kronecker column indices, and it must be +C in staircase form as supplied by SLICOT Library Routine MB04VD. +C The basis vectors are represented by matrix V(s) having the form +C +C | V11(s) V12(s) V13(s) . . V1n(s) | +C | V22(s) V23(s) V2n(s) | +C | V33(s) . | +C V(s) = | . . | +C | . . | +C | . . | +C | Vnn(s) | +C +C where n is the number of full row rank blocks in matrix A(eps) and +C +C k j-i +C Vij(s) = Vij,0 + Vij,1*s +...+ Vij,k*s +...+ Vij,j-i*s . (1) +C +C In other words, Vij,k is the coefficient corresponding to degree k +C in the matrix polynomial Vij(s). +C Vij,k has dimensions mu(i)-by-(mu(j)-nu(j)). +C The coefficients Vij,k are stored in the matrix VEPS as follows +C (for the case n = 3): +C +C sizes m1-n1 m2-n2 m2-n2 m3-n3 m3-n3 m3-n3 +C +C m1 { | V11,0 || V12,0 | V12,1 || V13,0 | V13,1 | V13,2 || +C | || | || | | || +C VEPS = m2 { | || V22,0 | || V23,0 | V23,1 | || +C | || | || | | || +C m3 { | || | || V33,0 | | || +C +C where mi = mu(i), ni = nu(i). +C Matrix VEPS has dimensions nrv-by-ncv where +C nrv = Sum(i=1,...,n) mu(i) +C ncv = Sum(i=1,...,n) i*(mu(i)-nu(i)) +C +C ================================================================== +C REMARK: This routine is intended to be called only from the SLICOT +C routine MC03ND. +C ================================================================== +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NBLCKS (input) INTEGER +C Number of full row rank blocks in subpencil +C s*E(eps)-A(eps) that contains all Kronecker column indices +C of s*E-A. NBLCKS >= 0. +C +C NRA (input) INTEGER +C Number of rows of the subpencil s*E(eps)-A(eps) in s*E-A. +C NRA = nu(1) + nu(2) + ... + nu(NBLCKS). NRA >= 0. +C +C NCA (input) INTEGER +C Number of columns of the subpencil s*E(eps)-A(eps) in +C s*E-A. +C NCA = mu(1) + mu(2) + ... + mu(NBLCKS). NCA >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,NCA) +C E (input/output) DOUBLE PRECISION array, dimension (LDE,NCA) +C On entry, the leading NRA-by-NCA part of these arrays must +C contain the matrices A and E, where s*E-A is the +C transformed pencil s*E0-A0 which is the pencil associated +C with P(s) as described in [1] Section 4.6. The pencil +C s*E-A is assumed to be in generalized Schur form. +C On exit, these arrays contain no useful information. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,NRA). +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,NRA). +C +C IMUK (input) INTEGER array, dimension (NBLCKS) +C This array must contain the column dimensions mu(k) of the +C full column rank blocks in the subpencil s*E(eps)-A(eps) +C of s*E-A. The content of IMUK is modified by the routine +C but restored on exit. +C +C INUK (input) INTEGER array, dimension (NBLCKS) +C This array must contain the row dimensions nu(k) of the +C full row rank blocks in the subpencil s*E(eps)-A(eps) of +C s*E-A. +C +C VEPS (output) DOUBLE PRECISION array, dimension (LDVEPS,ncv) +C Let nrv = Sum(i=1,...,NBLCKS) mu(i) = NCA, +C ncv = Sum(i=1,...,NBLCKS) i*(mu(i)-nu(i)). +C The leading nrv-by-ncv part of this array contains the +C column vectors of a minimal polynomial basis for the right +C nullspace of the subpencil s*E(eps)-A(eps). (See [1] +C Section 4.6.4.) An upper bound for ncv is (NRA+1)*NCA. +C +C LDVEPS INTEGER +C The leading dimension of array VEPS. +C LDVEPS >= MAX(1,NCA). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = k, the k-th diagonal block of A had not a +C full row rank. +C +C REFERENCES +C +C [1] Th.G.J. Beelen, New Algorithms for Computing the Kronecker +C structure of a Pencil with Applications to Systems and +C Control Theory. +C Ph.D.Thesis, Eindhoven University of Technology, 1987. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC03BY by Th.G.J. Beelen, +C A.J. Geurts, and G.J.H.H. van den Hurk. +C +C REVISIONS +C +C Dec. 1997. +C +C KEYWORDS +C +C Elementary polynomial operations, Kronecker form, polynomial +C matrix, polynomial operations, staircase form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDE, LDVEPS, NBLCKS, NCA, NRA +C .. Array Arguments .. + INTEGER IMUK(*), INUK(*) + DOUBLE PRECISION A(LDA,*), E(LDE,*), VEPS(LDVEPS,*) +C .. Local Scalars .. + INTEGER AC1, AC2, AR1, ARI, ARK, DIF, EC1, ER1, I, J, K, + $ MUI, NCV, NRV, NUI, SMUI, SMUI1, VC1, VC2, VR1, + $ VR2, WC1, WR1 +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1) +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLASET, DSCAL, DTRTRS, XERBLA +C .. Executable Statements .. +C + INFO = 0 + IF( NBLCKS.LT.0 ) THEN + INFO = -1 + ELSE IF( NRA.LT.0 ) THEN + INFO = -2 + ELSE IF( NCA.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, NRA ) ) THEN + INFO = -5 + ELSE IF( LDE.LT.MAX( 1, NRA ) ) THEN + INFO = -7 + ELSE IF( LDVEPS.LT.MAX( 1, NCA ) ) THEN + INFO = -11 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MC03NY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( NBLCKS.EQ.0 .OR. NRA.EQ.0 .OR. NCA.EQ.0 ) + $ RETURN +C +C Computation of the nonzero parts of W1 and W2: +C +C | AH11 AH12 ... AH1n | | EH11 EH12 ... EH1n | +C | AH22 AH2n | | EH22 EH2n | +C W1 = | . . |, W2 = | . . | +C | . . | | . . | +C | AHnn | | EHnn | +C +C with AHij = -pinv(Aii) * Aij, EHij = pinv(Aii) * Eij and EHii = 0, +C AHij and EHij have dimensions mu(i)-by-mu(j), Aii = [ Oi | Ri ], +C and +C Ri is a regular nu(i)-by-nu(i) upper triangular matrix; +C Oi is a not necessarily square null matrix. +C Note that the first mu(i)-nu(i) rows in AHij and EHij are zero. +C For memory savings, the nonzero parts of W1 and W2 are constructed +C over A and E, respectively. +C +C (AR1,AC1) denotes the position of the first element of the +C submatrix Ri in matrix Aii. +C EC1 is the index of the first column of Ai,i+1/Ei,i+1. +C + EC1 = 1 + AR1 = 1 +C + DO 40 I = 1, NBLCKS - 1 + NUI = INUK(I) + IF ( NUI.EQ.0 ) GO TO 60 + MUI = IMUK(I) + EC1 = EC1 + MUI + AC1 = EC1 - NUI + CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', NUI, + $ NCA-EC1+1, A(AR1,AC1), LDA, E(AR1,EC1), LDE, + $ INFO ) + IF ( INFO.GT.0 ) THEN + INFO = I + RETURN + END IF +C + DO 20 J = 1, NUI + CALL DSCAL( J, -ONE, A(AR1,AC1+J-1), 1 ) + 20 CONTINUE +C + CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', NUI, + $ NCA-EC1+1, A(AR1,AC1), LDA, A(AR1,EC1), LDA, + $ INFO ) + AR1 = AR1 + NUI + 40 CONTINUE +C + 60 CONTINUE +C +C The contents of the array IMUK is changed for temporary use in +C this routine as follows: +C +C IMUK(i) = Sum(j=1,...,i) mu(j). +C +C On return, the original contents of IMUK is restored. +C In the same loop the actual number of columns of VEPS is computed. +C The number of rows of VEPS is NCA. +C +C NRV = Sum(i=1,...,NBLCKS) mu(i) = NCA, +C NCV = Sum(i=1,...,NBLCKS) i*(mu(i)-nu(i)). +C + SMUI = 0 + NCV = 0 +C + DO 80 I = 1, NBLCKS + MUI = IMUK(I) + SMUI = SMUI + MUI + IMUK(I) = SMUI + NCV = NCV + I*( MUI - INUK(I) ) + 80 CONTINUE +C + NRV = NCA +C +C Computation of the matrix VEPS. +C +C Initialisation of VEPS to zero. +C + CALL DLASET( 'Full', NRV, NCV, ZERO, ZERO, VEPS, LDVEPS ) +C | I | +C Set Vii,0 = Kii in VEPS , i=1,...,NBLCKS, where Kii = |---| +C | O | +C and I is an identity matrix of size mu(i)-nu(i), +C O is a null matrix, dimensions nu(i)-by-(mu(i)-nu(i)). +C +C WR1 := Sum(j=1,...,i-1) mu(j) + 1 +C is the index of the first row in Vii,0 in VEPS. +C WC1 := Sum(j=1,...,i-1) j*(mu(j)-nu(j)) + 1 +C is the index of the first column in Vii,0 in VEPS. +C + DUMMY(1) = ONE + NUI = IMUK(1) - INUK(1) + CALL DCOPY( NUI, DUMMY, 0, VEPS, LDVEPS+1 ) + WR1 = IMUK(1) + 1 + WC1 = NUI + 1 +C + DO 100 I = 2, NBLCKS + NUI = IMUK(I) - IMUK(I-1) - INUK(I) + CALL DCOPY( NUI, DUMMY, 0, VEPS(WR1,WC1), LDVEPS+1 ) + WR1 = IMUK(I) + 1 + WC1 = WC1 + I*NUI + 100 CONTINUE +C +C Determination of the remaining nontrivial matrices in Vij,k +C block column by block column with decreasing block row index. +C +C The computation starts with the second block column since V11,0 +C has already been determined. +C The coefficients Vij,k satisfy the recurrence relation: +C +C Vij,k = Sum(r=i+1,...,j-k) AHir*Vrj,k + +C + Sum(r=i+1,...,j-k+1) EHir*Vrj,k-1, i + k < j, +C +C = EHi,i+1 * Vi+1,j,k-1 i + k = j. +C +C This recurrence relation can be derived from [1], (4.6.8) +C and formula (1) in Section PURPOSE. +C + VC1 = IMUK(1) - INUK(1) + 1 + ARI = 1 +C + DO 180 J = 2, NBLCKS + DIF = IMUK(J) - IMUK(J-1) - INUK(J) + ARI = ARI + INUK(J-1) + ARK = ARI +C +C Computation of the matrices Vij,k where i + k < j. +C Each matrix Vij,k has dimension mu(i)-by-(mu(j) - nu(j)). +C + DO 160 K = 0, J - 2 +C +C VC1, VC2 are the first and last column index of Vij,k. +C + VC2 = VC1 + DIF - 1 + AC2 = IMUK(J-K) + AR1 = ARK + ARK = ARK - INUK(J-K-1) +C + DO 120 I = J - K - 1, 1, -1 +C +C Compute the first part of Vij,k in decreasing order: +C Vij,k := Vij,k + Sum(r=i+1,..,j-k) AHir*Vrj,k. +C The non-zero parts of AHir are stored in +C A(AR1:AR1+nu(i)-1,AC1:AC2) and Vrj,k are stored in +C VEPS(AC1:AC2,VC1:VC2). +C The non-zero part of the result is stored in +C VEPS(VR1:VR2,VC1:VC2). +C + VR2 = IMUK(I) + AC1 = VR2 + 1 + VR1 = AC1 - INUK(I) + AR1 = AR1 - INUK(I) + CALL DGEMM( 'No transpose', 'No transpose', INUK(I), + $ DIF, AC2-VR2, ONE, A(AR1,AC1), LDA, + $ VEPS(AC1,VC1), LDVEPS, ONE, VEPS(VR1,VC1), + $ LDVEPS ) + 120 CONTINUE +C + ER1 = 1 +C + DO 140 I = 1, J - K - 1 +C +C Compute the second part of Vij,k+1 in normal order: +C Vij,k+1 := Sum(r=i+1,..,j-k) EHir*Vrj,k. +C The non-zero parts of EHir are stored in +C E(ER1:ER1+nu(i)-1,EC1:AC2) and Vrj,k are stored in +C VEPS(EC1:AC2,VC1:VC2). +C The non-zero part of the result is stored in +C VEPS(VR1:VR2,VC2+1:VC2+DIF), where +C DIF = VC2 - VC1 + 1 = mu(j) - nu(j). +C This code portion also computes Vij,k+1 for i + k = j. +C + VR2 = IMUK(I) + EC1 = VR2 + 1 + VR1 = EC1 - INUK(I) + CALL DGEMM( 'No transpose', 'No transpose', INUK(I), + $ DIF, AC2-VR2, ONE, E(ER1,EC1), LDE, + $ VEPS(EC1,VC1), LDVEPS, ZERO, VEPS(VR1,VC2+1), + $ LDVEPS ) + ER1 = ER1 + INUK(I) + 140 CONTINUE +C + VC1 = VC2 + 1 + 160 CONTINUE +C + VC1 = VC1 + DIF + 180 CONTINUE +C +C Restore original contents of the array IMUK. +C +C Since, at the moment: +C IMUK(i) = Sum(j=1,...,i) mu(j), (i=1,...,NBLCKS), +C the original values are: +C mu(i) = IMUK(i) - IMUK(i-1) with IMUK(0 ) = 0. +C + SMUI1 = 0 +C + DO 200 I = 1, NBLCKS + SMUI = IMUK(I) + IMUK(I) = SMUI - SMUI1 + SMUI1 = SMUI + 200 CONTINUE +C + RETURN +C *** Last line of MC03NY *** + END diff --git a/mex/sources/libslicot/MD03AD.f b/mex/sources/libslicot/MD03AD.f new file mode 100644 index 000000000..6eca057c4 --- /dev/null +++ b/mex/sources/libslicot/MD03AD.f @@ -0,0 +1,973 @@ + SUBROUTINE MD03AD( XINIT, ALG, STOR, UPLO, FCN, JPJ, M, N, ITMAX, + $ NPRINT, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, X, NFEV, NJEV, TOL, CGTOL, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To minimize the sum of the squares of m nonlinear functions, e, in +C n variables, x, by a modification of the Levenberg-Marquardt +C algorithm, using either a Cholesky-based or a conjugate gradients +C solver. The user must provide a subroutine FCN which calculates +C the functions and the Jacobian J (possibly by finite differences), +C and another subroutine JPJ, which computes either J'*J + par*I +C (if ALG = 'D'), or (J'*J + par*I)*x (if ALG = 'I'), where par is +C the Levenberg factor, exploiting the possible structure of the +C Jacobian matrix. Template implementations of these routines are +C included in the SLICOT Library. +C +C ARGUMENTS +C +C Mode Parameters +C +C XINIT CHARACTER*1 +C Specifies how the variables x are initialized, as follows: +C = 'R' : the array X is initialized to random values; the +C entries DWORK(1:4) are used to initialize the +C random number generator: the first three values +C are converted to integers between 0 and 4095, and +C the last one is converted to an odd integer +C between 1 and 4095; +C = 'G' : the given entries of X are used as initial values +C of variables. +C +C ALG CHARACTER*1 +C Specifies the algorithm used for solving the linear +C systems involving a Jacobian matrix J, as follows: +C = 'D' : a direct algorithm, which computes the Cholesky +C factor of the matrix J'*J + par*I is used; +C = 'I' : an iterative Conjugate Gradients algorithm, which +C only needs the matrix J, is used. +C In both cases, matrix J is stored in a compressed form. +C +C STOR CHARACTER*1 +C If ALG = 'D', specifies the storage scheme for the +C symmetric matrix J'*J, as follows: +C = 'F' : full storage is used; +C = 'P' : packed storage is used. +C The option STOR = 'F' usually ensures a faster execution. +C This parameter is not relevant if ALG = 'I'. +C +C UPLO CHARACTER*1 +C If ALG = 'D', specifies which part of the matrix J'*J +C is stored, as follows: +C = 'U' : the upper triagular part is stored; +C = 'L' : the lower triagular part is stored. +C The option UPLO = 'U' usually ensures a faster execution. +C This parameter is not relevant if ALG = 'I'. +C +C Function Parameters +C +C FCN EXTERNAL +C Subroutine which evaluates the functions and the Jacobian. +C FCN must be declared in an external statement in the user +C calling program, and must have the following interface: +C +C SUBROUTINE FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, +C $ DPAR2, LDPAR2, X, NFEVL, E, J, LDJ, JTE, +C $ DWORK, LDWORK, INFO ) +C +C where +C +C IFLAG (input/output) INTEGER +C On entry, this parameter must contain a value +C defining the computations to be performed: +C = 0 : Optionally, print the current iterate X, +C function values E, and Jacobian matrix J, +C or other results defined in terms of these +C values. See the argument NPRINT of MD03AD. +C Do not alter E and J. +C = 1 : Calculate the functions at X and return +C this vector in E. Do not alter J. +C = 2 : Calculate the Jacobian at X and return +C this matrix in J. Also return J'*e in JTE +C and NFEVL (see below). Do not alter E. +C = 3 : Do not compute neither the functions nor +C the Jacobian, but return in LDJ and +C IPAR/DPAR1,DPAR2 (some of) the integer/real +C parameters needed. +C On exit, the value of this parameter should not be +C changed by FCN unless the user wants to terminate +C execution of MD03AD, in which case IFLAG must be +C set to a negative integer. +C +C M (input) INTEGER +C The number of functions. M >= 0. +C +C N (input) INTEGER +C The number of variables. M >= N >= 0. +C +C IPAR (input/output) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of +C the Jacobian matrix or needed for problem solving. +C IPAR is an input parameter, except for IFLAG = 3 +C on entry, when it is also an output parameter. +C On exit, if IFLAG = 3, IPAR(1) contains the length +C of the array J, for storing the Jacobian matrix, +C and the entries IPAR(2:5) contain the workspace +C required by FCN for IFLAG = 1, FCN for IFLAG = 2, +C JPJ for ALG = 'D', and JPJ for ALG = 'I', +C respectively. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 5. +C +C DPAR1 (input/output) DOUBLE PRECISION array, dimension +C (LDPAR1,*) or (LDPAR1) +C A first set of real parameters needed for +C describing or solving the problem. +C DPAR1 can also be used as an additional array for +C intermediate results when computing the functions +C or the Jacobian. For control problems, DPAR1 could +C store the input trajectory of a system. +C +C LDPAR1 (input) INTEGER +C The leading dimension or the length of the array +C DPAR1, as convenient. LDPAR1 >= 0. (LDPAR1 >= 1, +C if leading dimension.) +C +C DPAR2 (input/output) DOUBLE PRECISION array, dimension +C (LDPAR2,*) or (LDPAR2) +C A second set of real parameters needed for +C describing or solving the problem. +C DPAR2 can also be used as an additional array for +C intermediate results when computing the functions +C or the Jacobian. For control problems, DPAR2 could +C store the output trajectory of a system. +C +C LDPAR2 (input) INTEGER +C The leading dimension or the length of the array +C DPAR2, as convenient. LDPAR2 >= 0. (LDPAR2 >= 1, +C if leading dimension.) +C +C X (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the value of the +C variables x where the functions or the Jacobian +C must be evaluated. +C +C NFEVL (input/output) INTEGER +C The number of function evaluations needed to +C compute the Jacobian by a finite difference +C approximation. +C NFEVL is an input parameter if IFLAG = 0, or an +C output parameter if IFLAG = 2. If the Jacobian is +C computed analytically, NFEVL should be set to a +C non-positive value. +C +C E (input/output) DOUBLE PRECISION array, +C dimension (M) +C This array contains the value of the (error) +C functions e evaluated at X. +C E is an input parameter if IFLAG = 0 or 2, or an +C output parameter if IFLAG = 1. +C +C J (input/output) DOUBLE PRECISION array, dimension +C (LDJ,NC), where NC is the number of columns +C needed. +C This array contains a possibly compressed +C representation of the Jacobian matrix evaluated +C at X. If full Jacobian is stored, then NC = N. +C J is an input parameter if IFLAG = 0, or an output +C parameter if IFLAG = 2. +C +C LDJ (input/output) INTEGER +C The leading dimension of array J. LDJ >= 1. +C LDJ is essentially used inside the routines FCN +C and JPJ. +C LDJ is an input parameter, except for IFLAG = 3 +C on entry, when it is an output parameter. +C It is assumed in MD03AD that LDJ is not larger +C than needed. +C +C JTE (output) DOUBLE PRECISION array, dimension (N) +C If IFLAG = 2, the matrix-vector product J'*e. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C The workspace array for subroutine FCN. +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C +C LDWORK (input) INTEGER +C The size of the array DWORK (as large as needed +C in the subroutine FCN). LDWORK >= 1. +C +C INFO INTEGER +C Error indicator, set to a negative value if an +C input (scalar) argument is erroneous, and to +C positive values for other possible errors in the +C subroutine FCN. The LAPACK Library routine XERBLA +C should be used in conjunction with negative INFO. +C INFO must be zero if the subroutine finished +C successfully. +C +C Parameters marked with "(input)" must not be changed. +C +C JPJ EXTERNAL +C Subroutine which computes J'*J + par*I, if ALG = 'D', and +C J'*J*x + par*x, if ALG = 'I', where J is the Jacobian as +C described above. +C +C JPJ must have the following interface: +C +C SUBROUTINE JPJ( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, +C $ J, LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO ) +C +C if ALG = 'D', and +C +C SUBROUTINE JPJ( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, +C $ INCX, DWORK, LDWORK, INFO ) +C +C if ALG = 'I', where +C +C STOR (input) CHARACTER*1 +C Specifies the storage scheme for the symmetric +C matrix J'*J, as follows: +C = 'F' : full storage is used; +C = 'P' : packed storage is used. +C +C UPLO (input) CHARACTER*1 +C Specifies which part of the matrix J'*J is stored, +C as follows: +C = 'U' : the upper triagular part is stored; +C = 'L' : the lower triagular part is stored. +C +C N (input) INTEGER +C The number of columns of the matrix J. N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of +C the Jacobian matrix. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 0. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C DPAR(1) must contain an initial estimate of the +C Levenberg-Marquardt parameter, par. DPAR(1) >= 0. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 1. +C +C J (input) DOUBLE PRECISION array, dimension +C (LDJ, NC), where NC is the number of columns. +C The leading NR-by-NC part of this array must +C contain the (compressed) representation of the +C Jacobian matrix J, where NR is the number of rows +C of J (function of IPAR entries). +C +C LDJ (input) INTEGER +C The leading dimension of array J. +C LDJ >= MAX(1,NR). +C +C JTJ (output) DOUBLE PRECISION array, +C dimension (LDJTJ,N), if STOR = 'F', +C dimension (N*(N+1)/2), if STOR = 'P'. +C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 +C (if STOR = 'P') part of this array contains the +C upper or lower triangle of the matrix J'*J+par*I, +C depending on UPLO = 'U', or UPLO = 'L', +C respectively, stored either as a two-dimensional, +C or one-dimensional array, depending on STOR. +C +C LDJTJ (input) INTEGER +C The leading dimension of the array JTJ. +C LDJTJ >= MAX(1,N), if STOR = 'F'. +C LDJTJ >= 1, if STOR = 'P'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C The workspace array for subroutine JPJ. +C +C LDWORK (input) INTEGER +C The size of the array DWORK (as large as needed +C in the subroutine JPJ). +C +C INFO INTEGER +C Error indicator, set to a negative value if an +C input (scalar) argument is erroneous, and to +C positive values for other possible errors in the +C subroutine JPJ. The LAPACK Library routine XERBLA +C should be used in conjunction with negative INFO +C values. INFO must be zero if the subroutine +C finished successfully. +C +C If ALG = 'I', the parameters in common with those for +C ALG = 'D', have the same meaning, and the additional +C parameters are: +C +C X (input/output) DOUBLE PRECISION array, dimension +C (1+(N-1)*INCX) +C On entry, this incremented array must contain the +C vector x. +C On exit, this incremented array contains the value +C of the matrix-vector product (J'*J + par)*x. +C +C INCX (input) INTEGER +C The increment for the elements of X. INCX > 0. +C +C Parameters marked with "(input)" must not be changed. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of functions. M >= 0. +C +C N (input) INTEGER +C The number of variables. M >= N >= 0. +C +C ITMAX (input) INTEGER +C The maximum number of iterations. ITMAX >= 0. +C +C NPRINT (input) INTEGER +C This parameter enables controlled printing of iterates if +C it is positive. In this case, FCN is called with IFLAG = 0 +C at the beginning of the first iteration and every NPRINT +C iterations thereafter and immediately prior to return, +C with X, E, and J available for printing. If NPRINT is not +C positive, no special calls of FCN with IFLAG = 0 are made. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters needed, for instance, for +C describing the structure of the Jacobian matrix, which +C are handed over to the routines FCN and JPJ. +C The first five entries of this array are modified +C internally by a call to FCN (with IFLAG = 3), but are +C restored on exit. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 5. +C +C DPAR1 (input/output) DOUBLE PRECISION array, dimension +C (LDPAR1,*) or (LDPAR1) +C A first set of real parameters needed for describing or +C solving the problem. This argument is not used by MD03AD +C routine, but it is passed to the routine FCN. +C +C LDPAR1 (input) INTEGER +C The leading dimension or the length of the array DPAR1, as +C convenient. LDPAR1 >= 0. (LDPAR1 >= 1, if leading +C dimension.) +C +C DPAR2 (input/output) DOUBLE PRECISION array, dimension +C (LDPAR2,*) or (LDPAR2) +C A second set of real parameters needed for describing or +C solving the problem. This argument is not used by MD03AD +C routine, but it is passed to the routine FCN. +C +C LDPAR2 (input) INTEGER +C The leading dimension or the length of the array DPAR2, as +C convenient. LDPAR2 >= 0. (LDPAR2 >= 1, if leading +C dimension.) +C +C X (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, if XINIT = 'G', this array must contain the +C vector of initial variables x to be optimized. +C If XINIT = 'R', this array need not be set before entry, +C and random values will be used to initialize x. +C On exit, if INFO = 0, this array contains the vector of +C values that (approximately) minimize the sum of squares of +C error functions. The values returned in IWARN and +C DWORK(1:5) give details on the iterative process. +C +C NFEV (output) INTEGER +C The number of calls to FCN with IFLAG = 1. If FCN is +C properly implemented, this includes the function +C evaluations needed for finite difference approximation +C of the Jacobian. +C +C NJEV (output) INTEGER +C The number of calls to FCN with IFLAG = 2. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If TOL >= 0, the tolerance which measures the relative +C error desired in the sum of squares. Termination occurs +C when the actual relative reduction in the sum of squares +C is at most TOL. If the user sets TOL < 0, then SQRT(EPS) +C is used instead TOL, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH). +C +C CGTOL DOUBLE PRECISION +C If ALG = 'I' and CGTOL > 0, the tolerance which measures +C the relative residual of the solutions computed by the +C conjugate gradients (CG) algorithm. Termination of a +C CG process occurs when the relative residual is at +C most CGTOL. If the user sets CGTOL <= 0, then SQRT(EPS) +C is used instead CGTOL. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, DWORK(2) returns the residual error norm (the +C sum of squares), DWORK(3) returns the number of iterations +C performed, DWORK(4) returns the total number of conjugate +C gradients iterations performed (zero, if ALG = 'D'), and +C DWORK(5) returns the final Levenberg factor. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( 5, M + 2*N + size(J) + +C max( DW( FCN|IFLAG = 1 ) + N, +C DW( FCN|IFLAG = 2 ), +C DW( sol ) ) ), +C where size(J) is the size of the Jacobian (provided by FCN +C in IPAR(1), for IFLAG = 3), DW( f ) is the workspace +C needed by the routine f, where f is FCN or JPJ (provided +C by FCN in IPAR(2:5), for IFLAG = 3), and DW( sol ) is the +C workspace needed for solving linear systems, +C DW( sol ) = N*N + DW( JPJ ), if ALG = 'D', STOR = 'F'; +C DW( sol ) = N*(N+1)/2 + DW( JPJ ), +C if ALG = 'D', STOR = 'P'; +C DW( sol ) = 3*N + DW( JPJ ), if ALG = 'I'. +C +C Warning Indicator +C +C IWARN INTEGER +C < 0: the user set IFLAG = IWARN in the subroutine FCN; +C = 0: no warning; +C = 1: if the iterative process did not converge in ITMAX +C iterations with tolerance TOL; +C = 2: if ALG = 'I', and in one or more iterations of the +C Levenberg-Marquardt algorithm, the conjugate +C gradient algorithm did not finish after 3*N +C iterations, with the accuracy required in the +C call; +C = 3: the cosine of the angle between e and any column of +C the Jacobian is at most FACTOR*EPS in absolute +C value, where FACTOR = 100 is defined in a PARAMETER +C statement; +C = 4: TOL is too small: no further reduction in the sum +C of squares is possible. +C In all these cases, DWORK(1:5) are set as described +C above. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: user-defined routine FCN returned with INFO <> 0 +C for IFLAG = 1; +C = 2: user-defined routine FCN returned with INFO <> 0 +C for IFLAG = 2; +C = 3: SLICOT Library routine MB02XD, if ALG = 'D', or +C SLICOT Library routine MB02WD, if ALG = 'I' (or +C user-defined routine JPJ), returned with INFO <> 0. +C +C METHOD +C +C If XINIT = 'R', the initial value for X is set to a vector of +C pseudo-random values uniformly distributed in [-1,1]. +C +C The Levenberg-Marquardt algorithm (described in [1]) is used for +C optimizing the parameters. This algorithm needs the Jacobian +C matrix J, which is provided by the subroutine FCN. The algorithm +C tries to update x by the formula +C +C x = x - p, +C +C using the solution of the system of linear equations +C +C (J'*J + PAR*I)*p = J'*e, +C +C where I is the identity matrix, and e the error function vector. +C The Levenberg factor PAR is decreased after each successfull step +C and increased in the other case. +C +C If ALG = 'D', a direct method, which evaluates the matrix product +C J'*J + par*I and then factors it using Cholesky algorithm, +C implemented in the SLICOT Libray routine MB02XD, is used for +C solving the linear system above. +C +C If ALG = 'I', the Conjugate Gradients method, described in [2], +C and implemented in the SLICOT Libray routine MB02WD, is used for +C solving the linear system above. The main advantage of this method +C is that in most cases the solution of the system can be computed +C in less time than the time needed to compute the matrix J'*J +C This is, however, problem dependent. +C +C REFERENCES +C +C [1] Kelley, C.T. +C Iterative Methods for Optimization. +C Society for Industrial and Applied Mathematics (SIAM), +C Philadelphia (Pa.), 1999. +C +C [2] Golub, G.H. and van Loan, C.F. +C Matrix Computations. Third Edition. +C M. D. Johns Hopkins University Press, Baltimore, pp. 520-528, +C 1996. +C +C [3] More, J.J. +C The Levenberg-Marquardt algorithm: implementation and theory. +C In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in +C Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg +C and New York, pp. 105-116, 1978. +C +C NUMERICAL ASPECTS +C +C The Levenberg-Marquardt algorithm described in [3] is scaling +C invariant and globally convergent to (maybe local) minima. +C According to [1], the convergence rate near a local minimum is +C quadratic, if the Jacobian is computed analytically, and linear, +C if the Jacobian is computed numerically. +C +C Whether or not the direct algorithm is faster than the iterative +C Conjugate Gradients algorithm for solving the linear systems +C involved depends on several factors, including the conditioning +C of the Jacobian matrix, and the ratio between its dimensions. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Oct. 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, +C Mar. 2002. +C +C KEYWORDS +C +C Conjugate gradients, least-squares approximation, +C Levenberg-Marquardt algorithm, matrix operations, optimization. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, FOUR, FIVE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, FOUR = 4.0D0, + $ FIVE = 5.0D0 ) + DOUBLE PRECISION FACTOR, MARQF, MINIMP, PARMAX + PARAMETER ( FACTOR = 10.0D0**2, MARQF = 2.0D0**2, + $ MINIMP = 2.0D0**(-3), PARMAX = 1.0D20 ) +C .. Scalar Arguments .. + CHARACTER ALG, STOR, UPLO, XINIT + INTEGER INFO, ITMAX, IWARN, LDPAR1, LDPAR2, LDWORK, + $ LIPAR, M, N, NFEV, NJEV, NPRINT + DOUBLE PRECISION CGTOL, TOL +C .. Array Arguments .. + DOUBLE PRECISION DPAR1(LDPAR1,*), DPAR2(LDPAR2,*), DWORK(*), X(*) + INTEGER IPAR(*) +C .. Local Scalars .. + LOGICAL CHOL, FULL, INIT, UPPER + INTEGER DWJTJ, E, I, IFLAG, INFOL, ITER, ITERCG, IW1, + $ IW2, IWARNL, JAC, JTE, JW1, JW2, JWORK, LDJ, + $ LDW, LFCN1, LFCN2, LJTJ, LJTJD, LJTJI, NFEVL, + $ SIZEJ, WRKOPT + DOUBLE PRECISION ACTRED, BIGNUM, CGTDEF, EPSMCH, FNORM, FNORM1, + $ GNORM, GSMIN, PAR, SMLNUM, SQREPS, TOLDEF +C .. Local Arrays .. + INTEGER SEED(4) +C .. External Functions .. + DOUBLE PRECISION DDOT, DLAMCH, DNRM2 + LOGICAL LSAME + EXTERNAL DDOT, DLAMCH, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLABAD, DLARNV, FCN, JPJ, MB02WD, MB02XD, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN, MOD, SQRT +C .. +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INIT = LSAME( XINIT, 'R' ) + CHOL = LSAME( ALG, 'D' ) + FULL = LSAME( STOR, 'F' ) + UPPER = LSAME( UPLO, 'U' ) +C +C Check the scalar input parameters. +C + IWARN = 0 + INFO = 0 + IF( .NOT.( INIT .OR. LSAME( XINIT, 'G' ) ) ) THEN + INFO = -1 + ELSEIF ( .NOT.( CHOL .OR. LSAME( ALG, 'I' ) ) ) THEN + INFO = -2 + ELSEIF ( CHOL .AND. .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN + INFO = -3 + ELSEIF ( CHOL .AND. .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -4 + ELSEIF ( M.LT.0 ) THEN + INFO = -7 + ELSEIF ( N.LT.0 .OR. N.GT.M ) THEN + INFO = -8 + ELSEIF ( ITMAX.LT.0 ) THEN + INFO = -9 + ELSEIF ( LIPAR.LT.5 ) THEN + INFO = -12 + ELSEIF( LDPAR1.LT.0 ) THEN + INFO = -14 + ELSEIF( LDPAR2.LT.0 ) THEN + INFO = -16 + ELSEIF ( LDWORK.LT.5 ) THEN + INFO = -23 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MD03AD', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + NFEV = 0 + NJEV = 0 + IF ( MIN( N, ITMAX ).EQ.0 ) THEN + DWORK(1) = FIVE + DWORK(2) = ZERO + DWORK(3) = ZERO + DWORK(4) = ZERO + DWORK(5) = ZERO + RETURN + ENDIF +C +C Call FCN to get the size of the array J, for storing the Jacobian +C matrix, the leading dimension LDJ and the workspace required +C by FCN for IFLAG = 1 and IFLAG = 2, and JPJ. The entries +C DWORK(1:4) should not be modified by the special call of FCN +C below, if XINIT = 'R' and the values in DWORK(1:4) are explicitly +C desired for initialization of the random number generator. +C + IFLAG = 3 + IW1 = IPAR(1) + IW2 = IPAR(2) + JW1 = IPAR(3) + JW2 = IPAR(4) + LJTJ = IPAR(5) +C + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, + $ X, NFEVL, DWORK, DWORK, LDJ, DWORK, DWORK, LDWORK, + $ INFOL ) +C + SIZEJ = IPAR(1) + LFCN1 = IPAR(2) + LFCN2 = IPAR(3) + LJTJD = IPAR(4) + LJTJI = IPAR(5) +C + IPAR(1) = IW1 + IPAR(2) = IW2 + IPAR(3) = JW1 + IPAR(4) = JW2 + IPAR(5) = LJTJ +C +C Define pointers to the array variables stored in DWORK. +C + JAC = 1 + E = JAC + SIZEJ + JTE = E + M + IW1 = JTE + N + IW2 = IW1 + N + JW1 = IW2 + JW2 = IW2 + N +C +C Check the workspace length. +C + JWORK = JW1 + IF ( CHOL ) THEN + IF ( FULL ) THEN + LDW = N*N + ELSE + LDW = ( N*( N + 1 ) ) / 2 + ENDIF + DWJTJ = JWORK + JWORK = DWJTJ + LDW + LJTJ = LJTJD + ELSE + LDW = 3*N + LJTJ = LJTJI + ENDIF + IF ( LDWORK.LT.MAX( 5, SIZEJ + M + 2*N + + $ MAX( LFCN1 + N, LFCN2, LDW + LJTJ ) ) ) + $ THEN + INFO = -23 + ENDIF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MD03AD', -INFO ) + RETURN + ENDIF +C +C Set default tolerances. SQREPS is the square root of the machine +C precision, and GSMIN is used in the tests of the gradient norm. +C + EPSMCH = DLAMCH( 'Epsilon' ) + SQREPS = SQRT( EPSMCH ) + TOLDEF = TOL + IF ( TOLDEF.LT.ZERO ) + $ TOLDEF = SQREPS + CGTDEF = CGTOL + IF ( CGTDEF.LE.ZERO ) + $ CGTDEF = SQREPS + GSMIN = FACTOR*EPSMCH + WRKOPT = 5 +C + SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C +C Initialization. +C + IF ( INIT ) THEN +C +C SEED is the initial state of the random number generator. +C SEED(4) must be odd. +C + SEED(1) = MOD( INT( DWORK(1) ), 4096 ) + SEED(2) = MOD( INT( DWORK(2) ), 4096 ) + SEED(3) = MOD( INT( DWORK(3) ), 4096 ) + SEED(4) = MOD( 2*INT( DWORK(4) ) + 1, 4096 ) + CALL DLARNV( 2, SEED, N, X ) + ENDIF +C +C Evaluate the function at the starting point and calculate +C its norm. +C Workspace: need: SIZEJ + M + 2*N + LFCN1; +C prefer: larger. +C + IFLAG = 1 + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, + $ X, NFEVL, DWORK(E), DWORK(JAC), LDJ, DWORK(JTE), + $ DWORK(JW1), LDWORK-JW1+1, INFOL ) +C + IF ( INFOL.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) + NFEV = 1 + FNORM = DNRM2( M, DWORK(E), 1 ) + ACTRED = ZERO + ITERCG = 0 + ITER = 0 + IWARNL = 0 + PAR = ZERO + IF ( IFLAG.LT.0 .OR. FNORM.EQ.ZERO ) + $ GO TO 40 +C +C Set the initial vector for the conjugate gradients algorithm. +C + DWORK(IW1) = ZERO + CALL DCOPY( N, DWORK(IW1), 0, DWORK(IW1), 1 ) +C +C WHILE ( nonconvergence and ITER < ITMAX ) DO +C +C Beginning of the outer loop. +C + 10 CONTINUE +C +C Calculate the Jacobian matrix. +C Workspace: need: SIZEJ + M + 2*N + LFCN2; +C prefer: larger. +C + ITER = ITER + 1 + IFLAG = 2 + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, X, NFEVL, DWORK(E), DWORK(JAC), LDJ, + $ DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL ) +C + IF ( INFOL.NE.0 ) THEN + INFO = 2 + RETURN + END IF +C +C Compute the gradient norm. +C + GNORM = DNRM2( N, DWORK(JTE), 1 ) + IF ( NFEVL.GT.0 ) + $ NFEV = NFEV + NFEVL + NJEV = NJEV + 1 + IF ( GNORM.LE.GSMIN ) + $ IWARN = 3 + IF ( IWARN.NE.0 ) + $ GO TO 40 + IF ( ITER.EQ.1 ) THEN + WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) + PAR = MIN( GNORM, SQRT( PARMAX ) ) + END IF + IF ( IFLAG.LT.0 ) + $ GO TO 40 +C +C If requested, call FCN to enable printing of iterates. +C + IF ( NPRINT.GT.0 ) THEN + IFLAG = 0 + IF ( MOD( ITER-1, NPRINT ).EQ.0 ) THEN + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, + $ DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL ) +C + IF ( IFLAG.LT.0 ) + $ GO TO 40 + END IF + END IF +C +C Beginning of the inner loop. +C + 20 CONTINUE +C +C Store the Levenberg factor in DWORK(E) (which is no longer +C needed), to pass it to JPJ routine. +C + DWORK(E) = PAR +C +C Solve (J'*J + PAR*I)*x = J'*e, and store x in DWORK(IW1). +C Additional workspace: +C N*N + DW(JPJ), if ALG = 'D', STOR = 'F'; +C N*( N + 1)/2 + DW(JPJ), if ALG = 'D', STOR = 'P'; +C 3*N + DW(JPJ), if ALG = 'I'. +C + IF ( CHOL ) THEN + CALL DCOPY( N, DWORK(JTE), 1, DWORK(IW1), 1 ) + CALL MB02XD( 'Function', STOR, UPLO, JPJ, M, N, 1, IPAR, + $ LIPAR, DWORK(E), 1, DWORK(JAC), LDJ, + $ DWORK(IW1), N, DWORK(DWJTJ), N, + $ DWORK(JWORK), LDWORK-JWORK+1, INFOL ) + ELSE + CALL MB02WD( 'Function', JPJ, N, IPAR, LIPAR, DWORK(E), + $ 1, 3*N, DWORK(JAC), LDJ, DWORK(JTE), 1, + $ DWORK(IW1), 1, CGTOL*GNORM, DWORK(JWORK), + $ LDWORK-JWORK+1, IWARN, INFOL ) + ITERCG = ITERCG + INT( DWORK(JWORK) ) + IWARNL = MAX( 2*IWARN, IWARNL ) + ENDIF +C + IF ( INFOL.NE.0 ) THEN + INFO = 3 + RETURN + ENDIF +C +C Compute updated X. +C + DO 30 I = 0, N - 1 + DWORK(IW2+I) = X(I+1) - DWORK(IW1+I) + 30 CONTINUE +C +C Evaluate the function at x - p and calculate its norm. +C Workspace: need: SIZEJ + M + 3*N + LFCN1; +C prefer: larger. +C + IFLAG = 1 + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, DWORK(IW2), NFEVL, DWORK(E), DWORK(JAC), + $ LDJ, DWORK(JTE), DWORK(JW2), LDWORK-JW2+1, INFOL ) +C + IF ( INFOL.NE.0 ) THEN + INFO = 1 + RETURN + END IF +C + NFEV = NFEV + 1 + IF ( IFLAG.LT.0 ) + $ GO TO 40 + FNORM1 = DNRM2( M, DWORK(E), 1 ) +C +C Now, check whether this step was successful and update the +C Levenberg factor. +C + IF ( FNORM.LT.FNORM1 ) THEN +C +C Unsuccessful step: increase PAR. +C + ACTRED = ONE + IF ( PAR.GT.PARMAX ) THEN + IF ( PAR/MARQF.LE.BIGNUM ) + $ PAR = PAR*MARQF + ELSE + PAR = PAR*MARQF + END IF +C + ELSE +C +C Successful step: update PAR, X, and FNORM. +C + ACTRED = ONE - ( FNORM1/FNORM )**2 + IF ( ( FNORM - FNORM1 )*( FNORM + FNORM1 ) .LT. + $ MINIMP*DDOT( N, DWORK(IW1), 1, + $ DWORK(JTE), 1 ) ) THEN + IF ( PAR.GT.PARMAX ) THEN + IF ( PAR/MARQF.LE.BIGNUM ) + $ PAR = PAR*MARQF + ELSE + PAR = PAR*MARQF + END IF + ELSE + PAR = MAX( PAR/MARQF, SMLNUM ) + ENDIF + CALL DCOPY( N, DWORK(IW2), 1, X, 1 ) + FNORM = FNORM1 + ENDIF +C + IF ( ( ACTRED.LE.TOLDEF ) .OR. ( ITER.GT.ITMAX ) .OR. + $ ( PAR.GT.PARMAX ) ) + $ GO TO 40 + IF ( ACTRED.LE.EPSMCH ) THEN + IWARN = 4 + GO TO 40 + ENDIF +C +C End of the inner loop. Repeat if unsuccessful iteration. +C + IF ( FNORM.LT.FNORM1 ) + $ GO TO 20 +C +C End of the outer loop. +C + GO TO 10 +C +C END WHILE 10 +C + 40 CONTINUE +C +C Termination, either normal or user imposed. +C + IF ( ACTRED.GT.TOLDEF ) + $ IWARN = 1 + IF ( IWARNL.NE.0 ) + $ IWARN = 2 +C + IF ( IFLAG.LT.0 ) + $ IWARN = IFLAG + IF ( NPRINT.GT.0 ) THEN + IFLAG = 0 + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, + $ DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL ) + IF ( IFLAG.LT.0 ) + $ IWARN = IFLAG + END IF +C + DWORK(1) = WRKOPT + DWORK(2) = FNORM + DWORK(3) = ITER + DWORK(4) = ITERCG + DWORK(5) = PAR +C + RETURN +C *** Last line of MD03AD *** + END diff --git a/mex/sources/libslicot/MD03BA.f b/mex/sources/libslicot/MD03BA.f new file mode 100644 index 000000000..ac2782e3a --- /dev/null +++ b/mex/sources/libslicot/MD03BA.f @@ -0,0 +1,151 @@ + SUBROUTINE MD03BA( N, IPAR, LIPAR, FNORM, J, LDJ, E, JNORMS, + $ GNORM, IPVT, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the QR factorization with column pivoting of an +C m-by-n Jacobian matrix J (m >= n), that is, J*P = Q*R, where Q is +C a matrix with orthogonal columns, P a permutation matrix, and +C R an upper trapezoidal matrix with diagonal elements of +C nonincreasing magnitude, and to apply the transformation Q' on +C the error vector e (in-situ). The 1-norm of the scaled gradient +C is also returned. +C +C This routine is an interface to SLICOT Library routine MD03BX, +C for solving standard nonlinear least squares problems using SLICOT +C routine MD03BD. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of columns of the Jacobian matrix J. N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix J, as follows: +C IPAR(1) must contain the number of rows M of the Jacobian +C matrix J. M >= N. +C IPAR is provided for compatibility with SLICOT Library +C routine MD03BD. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 1. +C +C FNORM (input) DOUBLE PRECISION +C The Euclidean norm of the vector e. FNORM >= 0. +C +C J (input/output) DOUBLE PRECISION array, dimension (LDJ, N) +C On entry, the leading M-by-N part of this array must +C contain the Jacobian matrix J. +C On exit, the leading N-by-N upper triangular part of this +C array contains the upper triangular factor R of the +C Jacobian matrix. Note that for efficiency of the later +C calculations, the matrix R is delivered with the leading +C dimension MAX(1,N), possibly much smaller than the value +C of LDJ on entry. +C +C LDJ (input/output) INTEGER +C The leading dimension of array J. +C On entry, LDJ >= MAX(1,M). +C On exit, LDJ >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (M) +C On entry, this array must contain the error vector e. +C On exit, this array contains the updated vector Q'*e. +C +C JNORMS (output) DOUBLE PRECISION array, dimension (N) +C This array contains the Euclidean norms of the columns +C of the Jacobian matrix, considered in the initial order. +C +C GNORM (output) DOUBLE PRECISION +C If FNORM > 0, the 1-norm of the scaled vector +C J'*Q'*e/FNORM, with each element i further divided +C by JNORMS(i) (if JNORMS(i) is nonzero). +C If FNORM = 0, the returned value of GNORM is 0. +C +C IPVT (output) INTEGER array, dimension (N) +C This array defines the permutation matrix P such that +C J*P = Q*R. Column j of P is column IPVT(j) of the identity +C matrix. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 1, if N = 0 or M = 1; +C LDWORK >= 4*N+1, if N > 1. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C This routine calls SLICOT Library routine MD03BX to perform the +C calculations. +C +C FURTHER COMMENTS +C +C For efficiency, the arguments are not checked. This is done in +C the routine MD03BX (except for LIPAR). +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, Jacobian matrix, matrix algebra, +C matrix operations. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INFO, LDJ, LDWORK, LIPAR, N + DOUBLE PRECISION FNORM, GNORM +C .. Array Arguments .. + INTEGER IPAR(*), IPVT(*) + DOUBLE PRECISION DWORK(*), E(*), J(*), JNORMS(*) +C .. External Subroutines .. + EXTERNAL MD03BX +C .. +C .. Executable Statements .. +C + CALL MD03BX( IPAR(1), N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT, + $ DWORK, LDWORK, INFO ) + RETURN +C +C *** Last line of MD03BA *** + END diff --git a/mex/sources/libslicot/MD03BB.f b/mex/sources/libslicot/MD03BB.f new file mode 100644 index 000000000..67772e407 --- /dev/null +++ b/mex/sources/libslicot/MD03BB.f @@ -0,0 +1,203 @@ + SUBROUTINE MD03BB( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB, + $ DELTA, PAR, RANKS, X, RX, TOL, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine a value for the parameter PAR such that if x solves +C the system +C +C A*x = b , sqrt(PAR)*D*x = 0 , +C +C in the least squares sense, where A is an m-by-n matrix, D is an +C n-by-n nonsingular diagonal matrix, and b is an m-vector, and if +C DELTA is a positive number, DXNORM is the Euclidean norm of D*x, +C then either PAR is zero and +C +C ( DXNORM - DELTA ) .LE. 0.1*DELTA , +C +C or PAR is positive and +C +C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . +C +C It is assumed that a QR factorization, with column pivoting, of A +C is available, that is, A*P = Q*R, where P is a permutation matrix, +C Q has orthogonal columns, and R is an upper triangular matrix +C with diagonal elements of nonincreasing magnitude. +C The routine needs the full upper triangle of R, the permutation +C matrix P, and the first n components of Q'*b (' denotes the +C transpose). On output, MD03BB also provides an upper triangular +C matrix S such that +C +C P'*(A'*A + PAR*D*D)*P = S'*S . +C +C Matrix S is used in the solution process. +C +C This routine is an interface to SLICOT Library routine MD03BY, +C for solving standard nonlinear least squares problems using SLICOT +C routine MD03BD. +C +C ARGUMENTS +C +C Mode Parameters +C +C COND CHARACTER*1 +C Specifies whether the condition of the matrices R and S +C should be estimated, as follows: +C = 'E' : use incremental condition estimation for R and S; +C = 'N' : do not use condition estimation, but check the +C diagonal entries of R and S for zero values; +C = 'U' : use the rank already stored in RANKS (for R). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix R. N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix R. IPAR and LIPAR are not used by this routine, +C but are provided for compatibility with SLICOT Library +C routine MD03BD. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR, N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix R. +C On exit, the full upper triangle is unaltered, and the +C strict lower triangle contains the strict upper triangle +C (transposed) of the upper triangular matrix S. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C IPVT (input) INTEGER array, dimension (N) +C This array must define the permutation matrix P such that +C A*P = Q*R. Column j of P is column IPVT(j) of the identity +C matrix. +C +C DIAG (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the diagonal elements of the +C matrix D. DIAG(I) <> 0, I = 1,...,N. +C +C QTB (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the first n elements of the +C vector Q'*b. +C +C DELTA (input) DOUBLE PRECISION +C An upper bound on the Euclidean norm of D*x. DELTA > 0. +C +C PAR (input/output) DOUBLE PRECISION +C On entry, PAR must contain an initial estimate of the +C Levenberg-Marquardt parameter. PAR >= 0. +C On exit, it contains the final estimate of this parameter. +C +C RANKS (input or output) INTEGER array, dimension (1) +C On entry, if COND = 'U' and N > 0, this array must contain +C the numerical rank of the matrix R. +C On exit, this array contains the numerical rank of the +C matrix S. +C RANKS is defined as an array for compatibility with SLICOT +C Library routine MD03BD. +C +C X (output) DOUBLE PRECISION array, dimension (N) +C This array contains the least squares solution of the +C system A*x = b, sqrt(PAR)*D*x = 0. +C +C RX (output) DOUBLE PRECISION array, dimension (N) +C This array contains the matrix-vector product -R*P'*x. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If COND = 'E', the tolerance to be used for finding the +C rank of the matrices R and S. If the user sets TOL > 0, +C then the given value of TOL is used as a lower bound for +C the reciprocal condition number; a (sub)matrix whose +C estimated condition number is less than 1/TOL is +C considered to be of full rank. If the user sets TOL <= 0, +C then an implicitly computed, default tolerance, defined by +C TOLDEF = N*EPS, is used instead, where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C This parameter is not relevant if COND = 'U' or 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, the first N elements of this array contain the +C diagonal elements of the upper triangular matrix S. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 4*N, if COND = 'E'; +C LDWORK >= 2*N, if COND <> 'E'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C This routine calls SLICOT Library routine MD03BY to perform the +C calculations. +C +C FURTHER COMMENTS +C +C For efficiency, the arguments are not checked. This is done in +C the routine MD03BY (except for LIPAR). +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Linear system of equations, matrix operations, plane rotations. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER COND + INTEGER INFO, LDR, LDWORK, LIPAR, N + DOUBLE PRECISION DELTA, PAR, TOL +C .. Array Arguments .. + INTEGER IPAR(*), IPVT(*), RANKS(*) + DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*) +C .. External Subroutines .. + EXTERNAL MD03BY +C .. +C .. Executable Statements .. +C + CALL MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, + $ RANKS(1), X, RX, TOL, DWORK, LDWORK, INFO ) + RETURN +C +C *** Last line of MD03BB *** + END diff --git a/mex/sources/libslicot/MD03BD.f b/mex/sources/libslicot/MD03BD.f new file mode 100644 index 000000000..eccd179e7 --- /dev/null +++ b/mex/sources/libslicot/MD03BD.f @@ -0,0 +1,1206 @@ + SUBROUTINE MD03BD( XINIT, SCALE, COND, FCN, QRFACT, LMPARM, M, N, + $ ITMAX, FACTOR, NPRINT, IPAR, LIPAR, DPAR1, + $ LDPAR1, DPAR2, LDPAR2, X, DIAG, NFEV, NJEV, + $ FTOL, XTOL, GTOL, TOL, IWORK, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To minimize the sum of the squares of m nonlinear functions, e, in +C n variables, x, by a modification of the Levenberg-Marquardt +C algorithm. The user must provide a subroutine FCN which calculates +C the functions and the Jacobian (possibly by finite differences). +C In addition, specialized subroutines QRFACT, for QR factorization +C with pivoting of the Jacobian, and LMPARM, for the computation of +C Levenberg-Marquardt parameter, exploiting the possible structure +C of the Jacobian matrix, should be provided. Template +C implementations of these routines are included in SLICOT Library. +C +C ARGUMENTS +C +C Mode Parameters +C +C XINIT CHARACTER*1 +C Specifies how the variables x are initialized, as follows: +C = 'R' : the array X is initialized to random values; the +C entries DWORK(1:4) are used to initialize the +C random number generator: the first three values +C are converted to integers between 0 and 4095, and +C the last one is converted to an odd integer +C between 1 and 4095; +C = 'G' : the given entries of X are used as initial values +C of variables. +C +C SCALE CHARACTER*1 +C Specifies how the variables will be scaled, as follows: +C = 'I' : use internal scaling; +C = 'S' : use specified scaling factors, given in DIAG. +C +C COND CHARACTER*1 +C Specifies whether the condition of the linear systems +C involved should be estimated, as follows: +C = 'E' : use incremental condition estimation to find the +C numerical rank; +C = 'N' : do not use condition estimation, but check the +C diagonal entries of matrices for zero values. +C +C Function Parameters +C +C FCN EXTERNAL +C Subroutine which evaluates the functions and the Jacobian. +C FCN must be declared in an external statement in the user +C calling program, and must have the following interface: +C +C SUBROUTINE FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, +C $ DPAR2, LDPAR2, X, NFEVL, E, J, LDJ, DWORK, +C $ LDWORK, INFO ) +C +C where +C +C IFLAG (input/output) INTEGER +C On entry, this parameter must contain a value +C defining the computations to be performed: +C = 0 : Optionally, print the current iterate X, +C function values E, and Jacobian matrix J, +C or other results defined in terms of these +C values. See the argument NPRINT of MD03BD. +C Do not alter E and J. +C = 1 : Calculate the functions at X and return +C this vector in E. Do not alter J. +C = 2 : Calculate the Jacobian at X and return +C this matrix in J. Also return NFEVL +C (see below). Do not alter E. +C = 3 : Do not compute neither the functions nor +C the Jacobian, but return in LDJ and +C IPAR/DPAR1,DPAR2 (some of) the integer/real +C parameters needed. +C On exit, the value of this parameter should not be +C changed by FCN unless the user wants to terminate +C execution of MD03BD, in which case IFLAG must be +C set to a negative integer. +C +C M (input) INTEGER +C The number of functions. M >= 0. +C +C N (input) INTEGER +C The number of variables. M >= N >= 0. +C +C IPAR (input/output) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of +C the Jacobian matrix or needed for problem solving. +C IPAR is an input parameter, except for IFLAG = 3 +C on entry, when it is also an output parameter. +C On exit, if IFLAG = 3, IPAR(1) contains the length +C of the array J, for storing the Jacobian matrix, +C and the entries IPAR(2:5) contain the workspace +C required by FCN for IFLAG = 1, FCN for IFLAG = 2, +C QRFACT, and LMPARM, respectively. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 5. +C +C DPAR1 (input/output) DOUBLE PRECISION array, dimension +C (LDPAR1,*) or (LDPAR1) +C A first set of real parameters needed for +C describing or solving the problem. +C DPAR1 can also be used as an additional array for +C intermediate results when computing the functions +C or the Jacobian. For control problems, DPAR1 could +C store the input trajectory of a system. +C +C LDPAR1 (input) INTEGER +C The leading dimension or the length of the array +C DPAR1, as convenient. LDPAR1 >= 0. (LDPAR1 >= 1, +C if leading dimension.) +C +C DPAR2 (input/output) DOUBLE PRECISION array, dimension +C (LDPAR2,*) or (LDPAR2) +C A second set of real parameters needed for +C describing or solving the problem. +C DPAR2 can also be used as an additional array for +C intermediate results when computing the functions +C or the Jacobian. For control problems, DPAR2 could +C store the output trajectory of a system. +C +C LDPAR2 (input) INTEGER +C The leading dimension or the length of the array +C DPAR2, as convenient. LDPAR2 >= 0. (LDPAR2 >= 1, +C if leading dimension.) +C +C X (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the value of the +C variables x where the functions or the Jacobian +C must be evaluated. +C +C NFEVL (input/output) INTEGER +C The number of function evaluations needed to +C compute the Jacobian by a finite difference +C approximation. +C NFEVL is an input parameter if IFLAG = 0, or an +C output parameter if IFLAG = 2. If the Jacobian is +C computed analytically, NFEVL should be set to a +C non-positive value. +C +C E (input/output) DOUBLE PRECISION array, +C dimension (M) +C This array contains the value of the (error) +C functions e evaluated at X. +C E is an input parameter if IFLAG = 0 or 2, or an +C output parameter if IFLAG = 1. +C +C J (input/output) DOUBLE PRECISION array, dimension +C (LDJ,NC), where NC is the number of columns +C needed. +C This array contains a possibly compressed +C representation of the Jacobian matrix evaluated +C at X. If full Jacobian is stored, then NC = N. +C J is an input parameter if IFLAG = 0, or an output +C parameter if IFLAG = 2. +C +C LDJ (input/output) INTEGER +C The leading dimension of array J. LDJ >= 1. +C LDJ is essentially used inside the routines FCN, +C QRFACT and LMPARM. +C LDJ is an input parameter, except for IFLAG = 3 +C on entry, when it is an output parameter. +C It is assumed in MD03BD that LDJ is not larger +C than needed. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C The workspace array for subroutine FCN. +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C +C LDWORK (input) INTEGER +C The size of the array DWORK (as large as needed +C in the subroutine FCN). LDWORK >= 1. +C +C INFO INTEGER +C Error indicator, set to a negative value if an +C input (scalar) argument is erroneous, and to +C positive values for other possible errors in the +C subroutine FCN. The LAPACK Library routine XERBLA +C should be used in conjunction with negative INFO. +C INFO must be zero if the subroutine finished +C successfully. +C +C Parameters marked with "(input)" must not be changed. +C +C QRFACT EXTERNAL +C Subroutine which computes the QR factorization with +C (block) column pivoting of the Jacobian matrix, J*P = Q*R. +C QRFACT must be declared in an external statement in the +C calling program, and must have the following interface: +C +C SUBROUTINE QRFACT( N, IPAR, LIPAR, FNORM, J, LDJ, E, +C $ JNORMS, GNORM, IPVT, DWORK, LDWORK, +C $ INFO ) +C +C where +C +C N (input) INTEGER +C The number of columns of the Jacobian matrix J. +C N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of +C the Jacobian matrix. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 0. +C +C FNORM (input) DOUBLE PRECISION +C The Euclidean norm of the vector e. FNORM >= 0. +C +C J (input/output) DOUBLE PRECISION array, dimension +C (LDJ, NC), where NC is the number of columns. +C On entry, the leading NR-by-NC part of this array +C must contain the (compressed) representation +C of the Jacobian matrix J, where NR is the number +C of rows of J (function of IPAR entries). +C On exit, the leading N-by-NC part of this array +C contains a (compressed) representation of the +C upper triangular factor R of the Jacobian matrix. +C For efficiency of the later calculations, the +C matrix R is delivered with the leading dimension +C MAX(1,N), possibly much smaller than the value +C of LDJ on entry. +C +C LDJ (input/output) INTEGER +C The leading dimension of array J. +C On entry, LDJ >= MAX(1,NR). +C On exit, LDJ >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension +C (NR) +C On entry, this array contains the error vector e. +C On exit, this array contains the updated vector +C Z*Q'*e, where Z is a block row permutation matrix +C (possibly identity) used in the QR factorization +C of J. (See, for example, the SLICOT Library +C routine NF01BS, Section METHOD.) +C +C JNORMS (output) DOUBLE PRECISION array, dimension (N) +C This array contains the Euclidean norms of the +C columns of the Jacobian matrix (in the original +C order). +C +C GNORM (output) DOUBLE PRECISION +C If FNORM > 0, the 1-norm of the scaled vector +C J'*e/FNORM, with each element i further divided +C by JNORMS(i) (if JNORMS(i) is nonzero). +C If FNORM = 0, the returned value of GNORM is 0. +C +C IPVT (output) INTEGER array, dimension (N) +C This array defines the permutation matrix P such +C that J*P = Q*R. Column j of P is column IPVT(j) of +C the identity matrix. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C The workspace array for subroutine QRFACT. +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C +C LDWORK (input) INTEGER +C The size of the array DWORK (as large as needed +C in the subroutine QRFACT). LDWORK >= 1. +C +C INFO INTEGER +C Error indicator, set to a negative value if an +C input (scalar) argument is erroneous, and to +C positive values for other possible errors in the +C subroutine QRFACT. The LAPACK Library routine +C XERBLA should be used in conjunction with negative +C INFO. INFO must be zero if the subroutine finished +C successfully. +C +C Parameters marked with "(input)" must not be changed. +C +C LMPARM EXTERNAL +C Subroutine which determines a value for the Levenberg- +C Marquardt parameter PAR such that if x solves the system +C +C J*x = b , sqrt(PAR)*D*x = 0 , +C +C in the least squares sense, where J is an m-by-n matrix, +C D is an n-by-n nonsingular diagonal matrix, and b is an +C m-vector, and if DELTA is a positive number, DXNORM is +C the Euclidean norm of D*x, then either PAR is zero and +C +C ( DXNORM - DELTA ) .LE. 0.1*DELTA , +C +C or PAR is positive and +C +C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . +C +C It is assumed that a block QR factorization, with column +C pivoting, of J is available, that is, J*P = Q*R, where P +C is a permutation matrix, Q has orthogonal columns, and +C R is an upper triangular matrix (possibly stored in a +C compressed form), with diagonal elements of nonincreasing +C magnitude for each block. On output, LMPARM also provides +C a (compressed) representation of an upper triangular +C matrix S, such that +C +C P'*(J'*J + PAR*D*D)*P = S'*S . +C +C LMPARM must be declared in an external statement in the +C calling program, and must have the following interface: +C +C SUBROUTINE LMPARM( COND, N, IPAR, LIPAR, R, LDR, IPVT, +C $ DIAG, QTB, DELTA, PAR, RANKS, X, RX, +C $ TOL, DWORK, LDWORK, INFO ) +C +C where +C +C COND CHARACTER*1 +C Specifies whether the condition of the linear +C systems involved should be estimated, as follows: +C = 'E' : use incremental condition estimation +C to find the numerical rank; +C = 'N' : do not use condition estimation, but +C check the diagonal entries for zero +C values; +C = 'U' : use the ranks already stored in RANKS +C (for R). +C +C N (input) INTEGER +C The order of the matrix R. N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of +C the Jacobian matrix. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension +C (LDR, NC), where NC is the number of columns. +C On entry, the leading N-by-NC part of this array +C must contain the (compressed) representation (Rc) +C of the upper triangular matrix R. +C On exit, the full upper triangular part of R +C (in representation Rc), is unaltered, and the +C remaining part contains (part of) the (compressed) +C representation of the transpose of the upper +C triangular matrix S. +C +C LDR (input) INTEGER +C The leading dimension of array R. +C LDR >= MAX(1,N). +C +C IPVT (input) INTEGER array, dimension (N) +C This array must define the permutation matrix P +C such that J*P = Q*R. Column j of P is column +C IPVT(j) of the identity matrix. +C +C DIAG (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the diagonal elements of +C the matrix D. DIAG(I) <> 0, I = 1,...,N. +C +C QTB (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the first n elements of +C the vector Q'*b. +C +C DELTA (input) DOUBLE PRECISION +C An upper bound on the Euclidean norm of D*x. +C DELTA > 0. +C +C PAR (input/output) DOUBLE PRECISION +C On entry, PAR must contain an initial estimate of +C the Levenberg-Marquardt parameter. PAR >= 0. +C On exit, it contains the final estimate of this +C parameter. +C +C RANKS (input or output) INTEGER array, dimension (r), +C where r is the number of diagonal blocks R_k in R, +C corresponding to the block column structure of J. +C On entry, if COND = 'U' and N > 0, this array must +C contain the numerical ranks of the submatrices +C R_k, k = 1:r. The number r is defined in terms of +C the entries of IPAR. +C On exit, if N > 0, this array contains the +C numerical ranks of the submatrices S_k, k = 1:r. +C +C X (output) DOUBLE PRECISION array, dimension (N) +C This array contains the least squares solution of +C the system J*x = b, sqrt(PAR)*D*x = 0. +C +C RX (output) DOUBLE PRECISION array, dimension (N) +C This array contains the matrix-vector product +C -R*P'*x. +C +C TOL (input) DOUBLE PRECISION +C If COND = 'E', the tolerance to be used for +C finding the ranks of the submatrices R_k and S_k. +C If the user sets TOL > 0, then the given value of +C TOL is used as a lower bound for the reciprocal +C condition number; a (sub)matrix whose estimated +C condition number is less than 1/TOL is considered +C to be of full rank. If the user sets TOL <= 0, +C then an implicitly computed, default tolerance, +C defined by TOLDEF = N*EPS, is used instead, +C where EPS is the machine precision (see LAPACK +C Library routine DLAMCH). +C This parameter is not relevant if COND = 'U' +C or 'N'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C The workspace array for subroutine LMPARM. +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C +C LDWORK (input) INTEGER +C The size of the array DWORK (as large as needed +C in the subroutine LMPARM). LDWORK >= 1. +C +C INFO INTEGER +C Error indicator, set to a negative value if an +C input (scalar) argument is erroneous, and to +C positive values for other possible errors in the +C subroutine LMPARM. The LAPACK Library routine +C XERBLA should be used in conjunction with negative +C INFO. INFO must be zero if the subroutine finished +C successfully. +C +C Parameters marked with "(input)" must not be changed. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of functions. M >= 0. +C +C N (input) INTEGER +C The number of variables. M >= N >= 0. +C +C ITMAX (input) INTEGER +C The maximum number of iterations. ITMAX >= 0. +C +C FACTOR (input) DOUBLE PRECISION +C The value used in determining the initial step bound. This +C bound is set to the product of FACTOR and the Euclidean +C norm of DIAG*X if nonzero, or else to FACTOR itself. +C In most cases FACTOR should lie in the interval (.1,100). +C A generally recommended value is 100. FACTOR > 0. +C +C NPRINT (input) INTEGER +C This parameter enables controlled printing of iterates if +C it is positive. In this case, FCN is called with IFLAG = 0 +C at the beginning of the first iteration and every NPRINT +C iterations thereafter and immediately prior to return, +C with X, E, and J available for printing. Note that when +C called immediately prior to return, J normally contains +C the result returned by QRFACT and LMPARM (the compressed +C R and S factors). If NPRINT is not positive, no special +C calls of FCN with IFLAG = 0 are made. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters needed, for instance, for +C describing the structure of the Jacobian matrix, which +C are handed over to the routines FCN, QRFACT and LMPARM. +C The first five entries of this array are modified +C internally by a call to FCN (with IFLAG = 3), but are +C restored on exit. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 5. +C +C DPAR1 (input/output) DOUBLE PRECISION array, dimension +C (LDPAR1,*) or (LDPAR1) +C A first set of real parameters needed for describing or +C solving the problem. This argument is not used by MD03BD +C routine, but it is passed to the routine FCN. +C +C LDPAR1 (input) INTEGER +C The leading dimension or the length of the array DPAR1, as +C convenient. LDPAR1 >= 0. (LDPAR1 >= 1, if leading +C dimension.) +C +C DPAR2 (input/output) DOUBLE PRECISION array, dimension +C (LDPAR2,*) or (LDPAR2) +C A second set of real parameters needed for describing or +C solving the problem. This argument is not used by MD03BD +C routine, but it is passed to the routine FCN. +C +C LDPAR2 (input) INTEGER +C The leading dimension or the length of the array DPAR2, as +C convenient. LDPAR2 >= 0. (LDPAR2 >= 1, if leading +C dimension.) +C +C X (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, if XINIT = 'G', this array must contain the +C vector of initial variables x to be optimized. +C If XINIT = 'R', this array need not be set before entry, +C and random values will be used to initialize x. +C On exit, if INFO = 0, this array contains the vector of +C values that (approximately) minimize the sum of squares of +C error functions. The values returned in IWARN and +C DWORK(1:4) give details on the iterative process. +C +C DIAG (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, if SCALE = 'S', this array must contain some +C positive entries that serve as multiplicative scale +C factors for the variables x. DIAG(I) > 0, I = 1,...,N. +C If SCALE = 'I', DIAG is internally set. +C On exit, this array contains the scale factors used +C (or finally used, if SCALE = 'I'). +C +C NFEV (output) INTEGER +C The number of calls to FCN with IFLAG = 1. If FCN is +C properly implemented, this includes the function +C evaluations needed for finite difference approximation +C of the Jacobian. +C +C NJEV (output) INTEGER +C The number of calls to FCN with IFLAG = 2. +C +C Tolerances +C +C FTOL DOUBLE PRECISION +C If FTOL >= 0, the tolerance which measures the relative +C error desired in the sum of squares. Termination occurs +C when both the actual and predicted relative reductions in +C the sum of squares are at most FTOL. If the user sets +C FTOL < 0, then SQRT(EPS) is used instead FTOL, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). +C +C XTOL DOUBLE PRECISION +C If XTOL >= 0, the tolerance which measures the relative +C error desired in the approximate solution. Termination +C occurs when the relative error between two consecutive +C iterates is at most XTOL. If the user sets XTOL < 0, +C then SQRT(EPS) is used instead XTOL. +C +C GTOL DOUBLE PRECISION +C If GTOL >= 0, the tolerance which measures the +C orthogonality desired between the function vector e and +C the columns of the Jacobian J. Termination occurs when +C the cosine of the angle between e and any column of the +C Jacobian J is at most GTOL in absolute value. If the user +C sets GTOL < 0, then EPS is used instead GTOL. +C +C TOL DOUBLE PRECISION +C If COND = 'E', the tolerance to be used for finding the +C ranks of the matrices of linear systems to be solved. If +C the user sets TOL > 0, then the given value of TOL is used +C as a lower bound for the reciprocal condition number; a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*EPS, is used instead. +C This parameter is not relevant if COND = 'N'. +C +C Workspace +C +C IWORK INTEGER array, dimension (N+r), where r is the number +C of diagonal blocks R_k in R (see description of LMPARM). +C On output, if INFO = 0, the first N entries of this array +C define a permutation matrix P such that J*P = Q*R, where +C J is the final calculated Jacobian, Q is an orthogonal +C matrix (not stored), and R is upper triangular with +C diagonal elements of nonincreasing magnitude (possibly +C for each block column of J). Column j of P is column +C IWORK(j) of the identity matrix. If INFO = 0, the entries +C N+1:N+r of this array contain the ranks of the final +C submatrices S_k (see description of LMPARM). +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, DWORK(2) returns the residual error norm (the +C sum of squares), DWORK(3) returns the number of iterations +C performed, and DWORK(4) returns the final Levenberg +C factor. If INFO = 0, N > 0, and IWARN >= 0, the elements +C DWORK(5) to DWORK(4+M) contain the final matrix-vector +C product Z*Q'*e, and the elements DWORK(5+M) to +C DWORK(4+M+N*NC) contain the (compressed) representation of +C final upper triangular matrices R and S (if IWARN <> 4). +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( 4, M + max( size(J) + +C max( DW( FCN|IFLAG = 1 ), +C DW( FCN|IFLAG = 2 ), +C DW( QRFACT ) + N ), +C N*NC + N + +C max( M + DW( FCN|IFLAG = 1 ), +C N + DW( LMPARM ) ) ) ), +C where size(J) is the size of the Jacobian (provided by FCN +C in IPAR(1), for IFLAG = 3), and DW( f ) is the workspace +C needed by the routine f, where f is FCN, QRFACT, or LMPARM +C (provided by FCN in IPAR(2:5), for IFLAG = 3). +C +C Warning Indicator +C +C IWARN INTEGER +C < 0: the user set IFLAG = IWARN in the subroutine FCN; +C = 1: both actual and predicted relative reductions in +C the sum of squares are at most FTOL; +C = 2: relative error between two consecutive iterates is +C at most XTOL; +C = 3: conditions for IWARN = 1 and IWARN = 2 both hold; +C = 4: the cosine of the angle between e and any column of +C the Jacobian is at most GTOL in absolute value; +C = 5: the number of iterations has reached ITMAX without +C satisfying any convergence condition; +C = 6: FTOL is too small: no further reduction in the sum +C of squares is possible; +C = 7: XTOL is too small: no further improvement in the +C approximate solution x is possible; +C = 8: GTOL is too small: e is orthogonal to the columns of +C the Jacobian to machine precision. +C In all these cases, DWORK(1:4) are set as described above. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: user-defined routine FCN returned with INFO <> 0 +C for IFLAG = 1; +C = 2: user-defined routine FCN returned with INFO <> 0 +C for IFLAG = 2; +C = 3: user-defined routine QRFACT returned with INFO <> 0; +C = 4: user-defined routine LMPARM returned with INFO <> 0. +C +C METHOD +C +C If XINIT = 'R', the initial value for x is set to a vector of +C pseudo-random values uniformly distributed in (-1,1). +C +C The Levenberg-Marquardt algorithm (described in [1,3]) is used for +C optimizing the variables x. This algorithm needs the Jacobian +C matrix J, which is provided by the subroutine FCN. A trust region +C method is used. The algorithm tries to update x by the formula +C +C x = x - p, +C +C using an approximate solution of the system of linear equations +C +C (J'*J + PAR*D*D)*p = J'*e, +C +C with e the error function vector, and D a diagonal nonsingular +C matrix, where either PAR = 0 and +C +C ( norm( D*x ) - DELTA ) <= 0.1*DELTA , +C +C or PAR > 0 and +C +C ABS( norm( D*x ) - DELTA ) <= 0.1*DELTA . +C +C DELTA is the radius of the trust region. If the Gauss-Newton +C direction is not acceptable, then an iterative algorithm obtains +C improved lower and upper bounds for the Levenberg-Marquardt +C parameter PAR. Only a few iterations are generally needed for +C convergence of the algorithm. The trust region radius DELTA +C and the Levenberg factor PAR are updated based on the ratio +C between the actual and predicted reduction in the sum of squares. +C +C REFERENCES +C +C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. +C User's Guide for MINPACK-1. +C Applied Math. Division, Argonne National Laboratory, Argonne, +C Illinois, Report ANL-80-74, 1980. +C +C [2] Golub, G.H. and van Loan, C.F. +C Matrix Computations. Third Edition. +C M. D. Johns Hopkins University Press, Baltimore, pp. 520-528, +C 1996. +C +C [3] More, J.J. +C The Levenberg-Marquardt algorithm: implementation and theory. +C In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in +C Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg +C and New York, pp. 105-116, 1978. +C +C NUMERICAL ASPECTS +C +C The Levenberg-Marquardt algorithm described in [3] is scaling +C invariant and globally convergent to (maybe local) minima. +C The convergence rate near a local minimum is quadratic, if the +C Jacobian is computed analytically, and linear, if the Jacobian +C is computed numerically. +C +C FURTHER COMMENTS +C +C This routine is a more general version of the subroutines LMDER +C and LMDER1 from the MINPACK package [1], which enables to exploit +C the structure of the problem, and optionally use condition +C estimation. Unstructured problems could be solved as well. +C +C Template SLICOT Library implementations for FCN, QRFACT and +C LMPARM routines are: +C MD03BF, MD03BA, and MD03BB, respectively, for standard problems; +C NF01BF, NF01BS, and NF01BP, respectively, for optimizing the +C parameters of Wiener systems (structured problems). +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C V. Sima, Feb. 15, 2004. +C +C KEYWORDS +C +C Least-squares approximation, Levenberg-Marquardt algorithm, +C matrix operations, optimization. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, FOUR, P1, P5, P25, P75, P0001 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, FOUR = 4.0D0, + $ P1 = 1.0D-1, P5 = 5.0D-1, P25 = 2.5D-1, + $ P75 = 7.5D-1, P0001 = 1.0D-4 ) +C .. Scalar Arguments .. + CHARACTER COND, SCALE, XINIT + INTEGER INFO, ITMAX, IWARN, LDPAR1, LDPAR2, LDWORK, + $ LIPAR, M, N, NFEV, NJEV, NPRINT + DOUBLE PRECISION FACTOR, FTOL, GTOL, TOL, XTOL +C .. Array Arguments .. + INTEGER IPAR(*), IWORK(*) + DOUBLE PRECISION DIAG(*), DPAR1(*), DPAR2(*), DWORK(*), X(*) +C .. Local Scalars .. + LOGICAL BADSCL, INIT, ISCAL, SSCAL + INTEGER E, IFLAG, INFOL, ITER, IW1, IW2, IW3, J, JAC, + $ JW1, JW2, JWORK, L, LDJ, LDJSAV, LFCN1, LFCN2, + $ LLMP, LQRF, NC, NFEVL, SIZEJ, WRKOPT + DOUBLE PRECISION ACTRED, DELTA, DIRDER, EPSMCH, FNORM, FNORM1, + $ FTDEF, GNORM, GTDEF, PAR, PNORM, PRERED, RATIO, + $ TEMP, TEMP1, TEMP2, TOLDEF, XNORM, XTDEF +C .. Local Arrays .. + INTEGER SEED(4) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DNRM2 + LOGICAL LSAME + EXTERNAL DLAMCH, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARNV, FCN, LMPARM, QRFACT, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD, SQRT +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INIT = LSAME( XINIT, 'R' ) + ISCAL = LSAME( SCALE, 'I' ) + SSCAL = LSAME( SCALE, 'S' ) + INFO = 0 + IWARN = 0 + IF( .NOT.( INIT .OR. LSAME( XINIT, 'G' ) ) ) THEN + INFO = -1 + ELSEIF( .NOT.( ISCAL .OR. SSCAL ) ) THEN + INFO = -2 + ELSEIF( .NOT.( LSAME( COND, 'E' ) .OR. LSAME( COND, 'N' ) ) ) THEN + INFO = -3 + ELSEIF( M.LT.0 ) THEN + INFO = -7 + ELSEIF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -8 + ELSEIF( ITMAX.LT.0 ) THEN + INFO = -9 + ELSEIF( FACTOR.LE.ZERO ) THEN + INFO = -10 + ELSEIF( LIPAR.LT.5 ) THEN + INFO = -13 + ELSEIF( LDPAR1.LT.0 ) THEN + INFO = -15 + ELSEIF( LDPAR2.LT.0 ) THEN + INFO = -17 + ELSEIF ( LDWORK.LT.4 ) THEN + INFO = -28 + ELSEIF ( SSCAL ) THEN + BADSCL = .FALSE. +C + DO 10 J = 1, N + BADSCL = BADSCL .OR. DIAG(J).LE.ZERO + 10 CONTINUE +C + IF ( BADSCL ) + $ INFO = -19 + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MD03BD', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + NFEV = 0 + NJEV = 0 + IF ( N.EQ.0 ) THEN + DWORK(1) = FOUR + DWORK(2) = ZERO + DWORK(3) = ZERO + DWORK(4) = ZERO + RETURN + END IF +C +C Call FCN to get the size of the array J, for storing the Jacobian +C matrix, the leading dimension LDJ and the workspace required +C by FCN for IFLAG = 1 and IFLAG = 2, QRFACT and LMPARM. The +C entries DWORK(1:4) should not be modified by the special call of +C FCN below, if XINIT = 'R' and the values in DWORK(1:4) are +C explicitly desired for initialization of the random number +C generator. +C + IFLAG = 3 + IW1 = IPAR(1) + IW2 = IPAR(2) + IW3 = IPAR(3) + JW1 = IPAR(4) + JW2 = IPAR(5) +C + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, + $ X, NFEVL, DWORK, DWORK, LDJSAV, DWORK, LDWORK, INFOL ) + SIZEJ = IPAR(1) + LFCN1 = IPAR(2) + LFCN2 = IPAR(3) + LQRF = IPAR(4) + LLMP = IPAR(5) + IF ( LDJSAV.GT.0 ) THEN + NC = SIZEJ/LDJSAV + ELSE + NC = SIZEJ + END IF +C + IPAR(1) = IW1 + IPAR(2) = IW2 + IPAR(3) = IW3 + IPAR(4) = JW1 + IPAR(5) = JW2 +C +C Check the workspace length. +C + E = 1 + JAC = E + M + JW1 = JAC + SIZEJ + JW2 = JW1 + N + IW1 = JAC + N*NC + IW2 = IW1 + N + IW3 = IW2 + N + JWORK = IW2 + M +C + L = MAX( 4, M + MAX( SIZEJ + MAX( LFCN1, LFCN2, N + LQRF ), + $ N*NC + N + MAX( M + LFCN1, N + LLMP ) ) ) + IF ( LDWORK.LT.L ) THEN + INFO = -28 + CALL XERBLA( 'MD03BD', -INFO ) + RETURN + ENDIF +C +C Set default tolerances. EPSMCH is the machine precision. +C + EPSMCH = DLAMCH( 'Epsilon' ) + FTDEF = FTOL + XTDEF = XTOL + GTDEF = GTOL + TOLDEF = TOL + IF ( MIN( FTDEF, XTDEF, GTDEF, TOLDEF ).LE.ZERO ) THEN + IF ( FTDEF.LT.ZERO ) + $ FTDEF = SQRT( EPSMCH ) + IF ( XTDEF.LT.ZERO ) + $ XTDEF = SQRT( EPSMCH ) + IF ( GTDEF.LT.ZERO ) + $ GTDEF = EPSMCH + IF ( TOLDEF.LE.ZERO ) + $ TOLDEF = DBLE( N )*EPSMCH + ENDIF + WRKOPT = 1 +C +C Initialization. +C + IF ( INIT ) THEN +C +C SEED is the initial state of the random number generator. +C SEED(4) must be odd. +C + SEED(1) = MOD( INT( DWORK(1) ), 4096 ) + SEED(2) = MOD( INT( DWORK(2) ), 4096 ) + SEED(3) = MOD( INT( DWORK(3) ), 4096 ) + SEED(4) = MOD( 2*INT( DWORK(4) ) + 1, 4096 ) + CALL DLARNV( 2, SEED, N, X ) + ENDIF +C +C Initialize Levenberg-Marquardt parameter and iteration counter. +C + PAR = ZERO + ITER = 1 +C +C Evaluate the function at the starting point +C and calculate its norm. +C Workspace: need: M + SIZEJ + LFCN1; +C prefer: larger. +C + IFLAG = 1 + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, + $ X, NFEVL, DWORK(E), DWORK(JAC), LDJ, DWORK(JW1), + $ LDWORK-JW1+1, INFOL ) +C + IF ( INFOL.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) + NFEV = 1 + FNORM = DNRM2( M, DWORK(E), 1 ) + IF ( IFLAG.LT.0 .OR. FNORM.EQ.ZERO ) + $ GO TO 90 +C +C Beginning of the outer loop. +C + 20 CONTINUE +C +C Calculate the Jacobian matrix. +C Workspace: need: M + SIZEJ + LFCN2; +C prefer: larger. +C + LDJ = LDJSAV + IFLAG = 2 + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, X, NFEVL, DWORK(E), DWORK(JAC), LDJ, + $ DWORK(JW1), LDWORK-JW1+1, INFOL ) +C + IF ( INFOL.NE.0 ) THEN + INFO = 2 + RETURN + END IF + IF ( ITER.EQ.1 ) + $ WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) + IF ( NFEVL.GT.0 ) + $ NFEV = NFEV + NFEVL + NJEV = NJEV + 1 + IF ( IFLAG.LT.0 ) + $ GO TO 90 +C +C If requested, call FCN to enable printing of iterates. +C + IF ( NPRINT.GT.0 ) THEN + IFLAG = 0 + IF ( MOD( ITER-1, NPRINT ).EQ.0 ) THEN + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, + $ DWORK(JW1), LDWORK-JW1+1, INFOL ) +C + IF ( IFLAG.LT.0 ) + $ GO TO 90 + END IF + END IF +C +C Compute the QR factorization of the Jacobian. +C Workspace: need: M + SIZEJ + N + LQRF; +C prefer: larger. +C + CALL QRFACT( N, IPAR, LIPAR, FNORM, DWORK(JAC), LDJ, DWORK(E), + $ DWORK(JW1), GNORM, IWORK, DWORK(JW2), + $ LDWORK-JW2+1, INFOL ) + IF ( INFOL.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C +C On the first iteration and if SCALE = 'I', scale according +C to the norms of the columns of the initial Jacobian. +C + IF ( ITER.EQ.1 ) THEN + WRKOPT = MAX( WRKOPT, INT( DWORK(JW2) ) + JW2 - 1 ) + IF ( ISCAL ) THEN +C + DO 30 J = 1, N + DIAG(J) = DWORK(JW1+J-1) + IF ( DIAG(J).EQ.ZERO ) + $ DIAG(J) = ONE + 30 CONTINUE +C + END IF +C +C On the first iteration, calculate the norm of the scaled +C x and initialize the step bound DELTA. +C + DO 40 J = 1, N + DWORK(IW1+J-1) = DIAG(J)*X(J) + 40 CONTINUE +C + XNORM = DNRM2( N, DWORK(IW1), 1 ) + DELTA = FACTOR*XNORM + IF ( DELTA.EQ.ZERO ) + $ DELTA = FACTOR + ELSE +C +C Rescale if necessary. +C + IF ( ISCAL ) THEN +C + DO 50 J = 1, N + DIAG(J) = MAX( DIAG(J), DWORK(JW1+J-1) ) + 50 CONTINUE +C + END IF + END IF +C +C Test for convergence of the gradient norm. +C + IF ( GNORM.LE.GTDEF ) + $ IWARN = 4 + IF ( IWARN.NE.0 ) + $ GO TO 90 +C +C Beginning of the inner loop. +C + 60 CONTINUE +C +C Determine the Levenberg-Marquardt parameter and the +C direction p, and compute -R*P'*p. +C Workspace: need: M + N*NC + 2*N + LLMP; +C prefer: larger. +C + CALL LMPARM( COND, N, IPAR, LIPAR, DWORK(JAC), LDJ, + $ IWORK, DIAG, DWORK(E), DELTA, PAR, IWORK(N+1), + $ DWORK(IW1), DWORK(IW2), TOLDEF, DWORK(IW3), + $ LDWORK-IW3+1, INFOL ) + IF ( INFOL.NE.0 ) THEN + INFO = 4 + RETURN + END IF + IF ( ITER.EQ.1 ) + $ WRKOPT = MAX( WRKOPT, INT( DWORK(IW3) ) + IW3 - 1 ) +C + TEMP1 = DNRM2( N, DWORK(IW2), 1 )/FNORM +C +C Store the direction p and x - p. +C + DO 70 J = 0, N - 1 + DWORK(IW2+J) = DIAG(J+1)*DWORK(IW1+J) + DWORK(IW1+J) = X(J+1) - DWORK(IW1+J) + 70 CONTINUE +C +C Compute the norm of scaled p and the scaled predicted +C reduction and the scaled directional derivative. +C + PNORM = DNRM2( N, DWORK(IW2), 1 ) + TEMP2 = ( SQRT( PAR )*PNORM )/FNORM + PRERED = TEMP1**2 + TEMP2**2/P5 + DIRDER = -( TEMP1**2 + TEMP2**2 ) +C +C On the first iteration, adjust the initial step bound. +C + IF ( ITER.EQ.1 ) + $ DELTA = MIN( DELTA, PNORM ) +C +C Evaluate the function at x - p and calculate its norm. +C Workspace: need: 2*M + N*NC + N + LFCN1; +C prefer: larger. +C + IFLAG = 1 + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, DWORK(IW1), NFEVL, DWORK(IW2), DWORK(JAC), + $ LDJ, DWORK(JWORK), LDWORK-JWORK+1, INFOL ) + IF ( INFOL.NE.0 ) THEN + INFO = 1 + RETURN + END IF +C + NFEV = NFEV + 1 + IF ( IFLAG.LT.0 ) + $ GO TO 90 + FNORM1 = DNRM2( M, DWORK(IW2), 1 ) +C +C Compute the scaled actual reduction. +C + ACTRED = -ONE + IF ( P1*FNORM1.LT.FNORM ) + $ ACTRED = ONE - ( FNORM1/FNORM )**2 +C +C Compute the ratio of the actual to the predicted reduction. +C + RATIO = ZERO + IF ( PRERED.NE.ZERO ) + $ RATIO = ACTRED/PRERED +C +C Update the step bound. +C + IF ( RATIO.LE.P25 ) THEN + IF ( ACTRED.GE.ZERO ) THEN + TEMP = P5 + ELSE + TEMP = P5*DIRDER/( DIRDER + P5*ACTRED ) + END IF + IF ( P1*FNORM1.GE.FNORM .OR. TEMP.LT.P1 ) + $ TEMP = P1 + DELTA = TEMP*MIN( DELTA, PNORM/P1 ) + PAR = PAR/TEMP + ELSE + IF ( PAR.EQ.ZERO .OR. RATIO.GE.P75 ) THEN + DELTA = PNORM/P5 + PAR = P5*PAR + END IF + END IF +C +C Test for successful iteration. +C + IF ( RATIO.GE.P0001 ) THEN +C +C Successful iteration. Update x, e, and their norms. +C + DO 80 J = 1, N + X(J) = DWORK(IW1+J-1) + DWORK(IW1+J-1) = DIAG(J)*X(J) + 80 CONTINUE +C + CALL DCOPY( M, DWORK(IW2), 1, DWORK(E), 1 ) + XNORM = DNRM2( N, DWORK(IW1), 1 ) + FNORM = FNORM1 + ITER = ITER + 1 + END IF +C +C Tests for convergence. +C + IF ( ABS( ACTRED ).LE.FTDEF .AND. PRERED.LE.FTDEF .AND. + $ P5*RATIO.LE.ONE ) + $ IWARN = 1 + IF ( DELTA.LE.XTDEF*XNORM ) + $ IWARN = 2 + IF ( ABS( ACTRED ).LE.FTDEF .AND. PRERED.LE.FTDEF .AND. + $ P5*RATIO.LE.ONE .AND. IWARN.EQ.2 ) + $ IWARN = 3 + IF ( IWARN.NE.0 ) + $ GO TO 90 +C +C Tests for termination and stringent tolerances. +C + IF ( ITER.GE.ITMAX ) + $ IWARN = 5 + IF ( ABS( ACTRED ).LE.EPSMCH .AND. PRERED.LE.EPSMCH .AND. + $ P5*RATIO.LE.ONE ) + $ IWARN = 6 + IF ( DELTA.LE.EPSMCH*XNORM ) + $ IWARN = 7 + IF ( GNORM.LE.EPSMCH ) + $ IWARN = 8 + IF ( IWARN.NE.0 ) + $ GO TO 90 +C +C End of the inner loop. Repeat if unsuccessful iteration. +C + IF ( RATIO.LT.P0001 ) GO TO 60 +C +C End of the outer loop. +C + GO TO 20 +C + 90 CONTINUE +C +C Termination, either normal or user imposed. +C Note that DWORK(JAC) normally contains the results returned by +C QRFACT and LMPARM (the compressed R and S factors). +C + IF ( IFLAG.LT.0 ) + $ IWARN = IFLAG + IF ( NPRINT.GT.0 ) THEN + IFLAG = 0 + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, + $ DWORK(JWORK), LDWORK-JWORK+1, INFOL ) + IF ( IFLAG.LT.0 ) + $ IWARN = IFLAG + END IF +C + IF ( IWARN.GE.0 ) THEN + DO 100 J = M + N*NC, 1, -1 + DWORK(4+J) = DWORK(J) + 100 CONTINUE + END IF + DWORK(1) = WRKOPT + DWORK(2) = FNORM + DWORK(3) = ITER + DWORK(4) = PAR +C + RETURN +C *** Last line of MD03BD *** + END diff --git a/mex/sources/libslicot/MD03BF.f b/mex/sources/libslicot/MD03BF.f new file mode 100644 index 000000000..232ac807d --- /dev/null +++ b/mex/sources/libslicot/MD03BF.f @@ -0,0 +1,122 @@ + SUBROUTINE MD03BF( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, X, NFEVL, E, J, LDJ, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C This is the FCN routine for solving a standard nonlinear least +C squares problem using SLICOT Library routine MD03BD. See the +C parameter FCN in the routine MD03BD for the description of +C parameters. +C +C The example programmed in this routine is adapted from that +C accompanying the MINPACK routine LMDER. +C +C ****************************************************************** +C +C .. Parameters .. +C .. NOUT is the unit number for printing intermediate results .. + INTEGER NOUT + PARAMETER ( NOUT = 6 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER IFLAG, INFO, LDJ, LDPAR1, LDPAR2, LDWORK, LIPAR, + $ M, N, NFEVL +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DPAR1(*), DPAR2(*), DWORK(*), E(*), J(LDJ,*), + $ X(*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION ERR, TMP1, TMP2, TMP3, TMP4 +C .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +C .. DATA Statements .. + DOUBLE PRECISION Y(15) + DATA Y(1), Y(2), Y(3), Y(4), Y(5), Y(6), Y(7), Y(8), + $ Y(9), Y(10), Y(11), Y(12), Y(13), Y(14), Y(15) + $ / 1.4D-1, 1.8D-1, 2.2D-1, 2.5D-1, 2.9D-1, + $ 3.2D-1, 3.5D-1, 3.9D-1, 3.7D-1, 5.8D-1, + $ 7.3D-1, 9.6D-1, 1.34D0, 2.1D0, 4.39D0 / +C +C .. Executable Statements .. +C + INFO = 0 + IF ( IFLAG.EQ.1 ) THEN +C +C Compute the error function values. +C + DO 10 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + IF ( I.GT.8 ) THEN + TMP3 = TMP2 + ELSE + TMP3 = TMP1 + END IF + E(I) = Y(I) - ( X(1) + TMP1/( X(2)*TMP2 + X(3)*TMP3 ) ) + 10 CONTINUE +C + ELSE IF ( IFLAG.EQ.2 ) THEN +C +C Compute the Jacobian. +C + DO 30 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + IF ( I.GT.8 ) THEN + TMP3 = TMP2 + ELSE + TMP3 = TMP1 + END IF + TMP4 = ( X(2)*TMP2 + X(3)*TMP3 )**2 + J(I,1) = -ONE + J(I,2) = TMP1*TMP2/TMP4 + J(I,3) = TMP1*TMP3/TMP4 + 30 CONTINUE +C + NFEVL = 0 +C + ELSE IF ( IFLAG.EQ.3 ) THEN +C +C Set the parameter LDJ, the length of the array J, and the sizes +C of the workspace for FCN (IFLAG = 1 or 2), MD03BA and MD03BB. +C + LDJ = M + IPAR(1) = M*N + IPAR(2) = 0 + IPAR(3) = 0 + IPAR(4) = 4*N + 1 + IPAR(5) = 4*N +C + ELSE IF ( IFLAG.EQ.0 ) THEN +C +C Special call for printing intermediate results. +C + ERR = DNRM2( M, E, 1 ) + WRITE( 1, '('' Norm of current error = '', D15.6)') ERR +C + END IF +C + RETURN +C +C *** Last line of MD03BF *** + END diff --git a/mex/sources/libslicot/MD03BX.f b/mex/sources/libslicot/MD03BX.f new file mode 100644 index 000000000..7ffef61d0 --- /dev/null +++ b/mex/sources/libslicot/MD03BX.f @@ -0,0 +1,255 @@ + SUBROUTINE MD03BX( M, N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the QR factorization with column pivoting of an +C m-by-n matrix J (m >= n), that is, J*P = Q*R, where Q is a matrix +C with orthogonal columns, P a permutation matrix, and R an upper +C trapezoidal matrix with diagonal elements of nonincreasing +C magnitude, and to apply the transformation Q' on the error +C vector e (in-situ). The 1-norm of the scaled gradient is also +C returned. The matrix J could be the Jacobian of a nonlinear least +C squares problem. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the Jacobian matrix J. M >= 0. +C +C N (input) INTEGER +C The number of columns of the Jacobian matrix J. +C M >= N >= 0. +C +C FNORM (input) DOUBLE PRECISION +C The Euclidean norm of the vector e. FNORM >= 0. +C +C J (input/output) DOUBLE PRECISION array, dimension (LDJ, N) +C On entry, the leading M-by-N part of this array must +C contain the Jacobian matrix J. +C On exit, the leading N-by-N upper triangular part of this +C array contains the upper triangular factor R of the +C Jacobian matrix. Note that for efficiency of the later +C calculations, the matrix R is delivered with the leading +C dimension MAX(1,N), possibly much smaller than the value +C of LDJ on entry. +C +C LDJ (input/output) INTEGER +C The leading dimension of array J. +C On entry, LDJ >= MAX(1,M). +C On exit, LDJ >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (M) +C On entry, this array must contain the error vector e. +C On exit, this array contains the updated vector Q'*e. +C +C JNORMS (output) DOUBLE PRECISION array, dimension (N) +C This array contains the Euclidean norms of the columns of +C the Jacobian matrix, considered in the initial order. +C +C GNORM (output) DOUBLE PRECISION +C If FNORM > 0, the 1-norm of the scaled vector +C J'*Q'*e/FNORM, with each element i further divided by +C JNORMS(i) (if JNORMS(i) is nonzero). +C If FNORM = 0, the returned value of GNORM is 0. +C +C IPVT (output) INTEGER array, dimension (N) +C This array defines the permutation matrix P such that +C J*P = Q*R. Column j of P is column IPVT(j) of the identity +C matrix. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 1, if N = 0 or M = 1; +C LDWORK >= 4*N+1, if N > 1. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The algorithm uses QR factorization with column pivoting of the +C matrix J, J*P = Q*R, and applies the orthogonal matrix Q' to the +C vector e. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, Jacobian matrix, matrix algebra, +C matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDJ, LDWORK, M, N + DOUBLE PRECISION FNORM, GNORM +C .. Array Arguments .. + INTEGER IPVT(*) + DOUBLE PRECISION DWORK(*), E(*), J(*), JNORMS(*) +C .. Local Scalars .. + INTEGER I, ITAU, JWORK, L, WRKOPT + DOUBLE PRECISION SUM +C .. External Functions .. + DOUBLE PRECISION DDOT, DNRM2 + EXTERNAL DDOT, DNRM2 +C .. External Subroutines .. + EXTERNAL DGEQP3, DLACPY, DORMQR, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX +C .. +C .. Executable Statements .. +C + INFO = 0 + IF ( M.LT.0 ) THEN + INFO = -1 + ELSEIF ( N.LT.0.OR. M.LT.N ) THEN + INFO = -2 + ELSEIF ( FNORM.LT.ZERO ) THEN + INFO = -3 + ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE + IF ( N.EQ.0 .OR. M.EQ.1 ) THEN + JWORK = 1 + ELSE + JWORK = 4*N + 1 + END IF + IF ( LDWORK.LT.JWORK ) + $ INFO = -11 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MD03BX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + GNORM = ZERO + IF ( N.EQ.0 ) THEN + LDJ = 1 + DWORK(1) = ONE + RETURN + ELSEIF ( M.EQ.1 ) THEN + JNORMS(1) = ABS( J(1) ) + IF ( FNORM*J(1).NE.ZERO ) + $ GNORM = ABS( E(1)/FNORM ) + LDJ = 1 + IPVT(1) = 1 + DWORK(1) = ONE + RETURN + END IF +C +C Initialize the column pivoting indices. +C + DO 10 I = 1, N + IPVT(I) = 0 + 10 CONTINUE +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + ITAU = 1 + JWORK = ITAU + N + WRKOPT = 1 +C +C Compute the QR factorization with pivoting of J, and apply Q' to +C the vector e. +C +C Workspace: need: 4*N + 1; +C prefer: 3*N + ( N+1 )*NB. +C + CALL DGEQP3( M, N, J, LDJ, IPVT, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need: N + 1; +C prefer: N + NB. +C + CALL DORMQR( 'Left', 'Transpose', M, 1, N, J, LDJ, DWORK(ITAU), E, + $ M, DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + IF ( LDJ.GT.N ) THEN +C +C Reshape the array J to have the leading dimension N. +C This destroys the details of the orthogonal matrix Q. +C + CALL DLACPY( 'Upper', N, N, J, LDJ, J, N ) + LDJ = N + END IF +C +C Compute the norm of the scaled gradient and original column norms. +C + IF ( FNORM.NE.ZERO ) THEN +C + DO 20 I = 1, N + L = IPVT(I) + JNORMS(L) = DNRM2( I, J((I-1)*LDJ+1), 1 ) + IF ( JNORMS(L).NE.ZERO ) THEN + SUM = DDOT( I, J((I-1)*LDJ+1), 1, E, 1 )/FNORM + GNORM = MAX( GNORM, ABS( SUM/JNORMS(L) ) ) + END IF + 20 CONTINUE +C + ELSE +C + DO 30 I = 1, N + L = IPVT(I) + JNORMS(L) = DNRM2( I, J((I-1)*LDJ+1), 1 ) + 30 CONTINUE +C + END IF +C + DWORK(1) = WRKOPT + RETURN +C +C *** Last line of MD03BX *** + END diff --git a/mex/sources/libslicot/MD03BY.f b/mex/sources/libslicot/MD03BY.f new file mode 100644 index 000000000..ec4637ce4 --- /dev/null +++ b/mex/sources/libslicot/MD03BY.f @@ -0,0 +1,514 @@ + SUBROUTINE MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, + $ RANK, X, RX, TOL, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine a value for the parameter PAR such that if x solves +C the system +C +C A*x = b , sqrt(PAR)*D*x = 0 , +C +C in the least squares sense, where A is an m-by-n matrix, D is an +C n-by-n nonsingular diagonal matrix, and b is an m-vector, and if +C DELTA is a positive number, DXNORM is the Euclidean norm of D*x, +C then either PAR is zero and +C +C ( DXNORM - DELTA ) .LE. 0.1*DELTA , +C +C or PAR is positive and +C +C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . +C +C It is assumed that a QR factorization, with column pivoting, of A +C is available, that is, A*P = Q*R, where P is a permutation matrix, +C Q has orthogonal columns, and R is an upper triangular matrix +C with diagonal elements of nonincreasing magnitude. +C The routine needs the full upper triangle of R, the permutation +C matrix P, and the first n components of Q'*b (' denotes the +C transpose). On output, MD03BY also provides an upper triangular +C matrix S such that +C +C P'*(A'*A + PAR*D*D)*P = S'*S . +C +C Matrix S is used in the solution process. +C +C ARGUMENTS +C +C Mode Parameters +C +C COND CHARACTER*1 +C Specifies whether the condition of the matrices R and S +C should be estimated, as follows: +C = 'E' : use incremental condition estimation for R and S; +C = 'N' : do not use condition estimation, but check the +C diagonal entries of R and S for zero values; +C = 'U' : use the rank already stored in RANK (for R). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix R. N >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR, N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix R. +C On exit, the full upper triangle is unaltered, and the +C strict lower triangle contains the strict upper triangle +C (transposed) of the upper triangular matrix S. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C IPVT (input) INTEGER array, dimension (N) +C This array must define the permutation matrix P such that +C A*P = Q*R. Column j of P is column IPVT(j) of the identity +C matrix. +C +C DIAG (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the diagonal elements of the +C matrix D. DIAG(I) <> 0, I = 1,...,N. +C +C QTB (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the first n elements of the +C vector Q'*b. +C +C DELTA (input) DOUBLE PRECISION +C An upper bound on the Euclidean norm of D*x. DELTA > 0. +C +C PAR (input/output) DOUBLE PRECISION +C On entry, PAR must contain an initial estimate of the +C Levenberg-Marquardt parameter. PAR >= 0. +C On exit, it contains the final estimate of this parameter. +C +C RANK (input or output) INTEGER +C On entry, if COND = 'U', this parameter must contain the +C (numerical) rank of the matrix R. +C On exit, this parameter contains the numerical rank of +C the matrix S. +C +C X (output) DOUBLE PRECISION array, dimension (N) +C This array contains the least squares solution of the +C system A*x = b, sqrt(PAR)*D*x = 0. +C +C RX (output) DOUBLE PRECISION array, dimension (N) +C This array contains the matrix-vector product -R*P'*x. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If COND = 'E', the tolerance to be used for finding the +C rank of the matrices R and S. If the user sets TOL > 0, +C then the given value of TOL is used as a lower bound for +C the reciprocal condition number; a (sub)matrix whose +C estimated condition number is less than 1/TOL is +C considered to be of full rank. If the user sets TOL <= 0, +C then an implicitly computed, default tolerance, defined by +C TOLDEF = N*EPS, is used instead, where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C This parameter is not relevant if COND = 'U' or 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, the first N elements of this array contain the +C diagonal elements of the upper triangular matrix S. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 4*N, if COND = 'E'; +C LDWORK >= 2*N, if COND <> 'E'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The algorithm computes the Gauss-Newton direction. A least squares +C solution is found if the Jacobian is rank deficient. If the Gauss- +C Newton direction is not acceptable, then an iterative algorithm +C obtains improved lower and upper bounds for the parameter PAR. +C Only a few iterations are generally needed for convergence of the +C algorithm. If, however, the limit of ITMAX = 10 iterations is +C reached, then the output PAR will contain the best value obtained +C so far. If the Gauss-Newton step is acceptable, it is stored in x, +C and PAR is set to zero, hence S = R. +C +C REFERENCES +C +C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. +C User's Guide for MINPACK-1. +C Applied Math. Division, Argonne National Laboratory, Argonne, +C Illinois, Report ANL-80-74, 1980. +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C This routine is a LAPACK-based modification of LMPAR from the +C MINPACK package [1], and with optional condition estimation. +C The option COND = 'U' is useful when dealing with several +C right-hand side vectors, but RANK should be reset. +C If COND = 'E', but the matrix S is guaranteed to be nonsingular +C and well conditioned relative to TOL, i.e., rank(R) = N, and +C min(DIAG) > 0, then its condition is not estimated. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. +C +C KEYWORDS +C +C Linear system of equations, matrix operations, plane rotations. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER ITMAX + PARAMETER ( ITMAX = 10 ) + DOUBLE PRECISION P1, P001, ZERO, SVLMAX + PARAMETER ( P1 = 1.0D-1, P001 = 1.0D-3, ZERO = 0.0D0, + $ SVLMAX = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER COND + INTEGER INFO, LDR, LDWORK, N, RANK + DOUBLE PRECISION DELTA, PAR, TOL +C .. Array Arguments .. + INTEGER IPVT(*) + DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*) +C .. Local Scalars .. + INTEGER ITER, J, L, N2 + DOUBLE PRECISION DMINO, DWARF, DXNORM, FP, GNORM, PARC, PARL, + $ PARU, TEMP, TOLDEF + LOGICAL ECOND, NCOND, SING, UCOND + CHARACTER CONDL +C .. Local Arrays .. + DOUBLE PRECISION DUM(3) +C .. External Functions .. + DOUBLE PRECISION DDOT, DLAMCH, DNRM2 + LOGICAL LSAME + EXTERNAL DDOT, DLAMCH, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSWAP, DTRMV, DTRSV, MB02YD, + $ MB03OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + ECOND = LSAME( COND, 'E' ) + NCOND = LSAME( COND, 'N' ) + UCOND = LSAME( COND, 'U' ) + INFO = 0 + IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN + INFO = -1 + ELSEIF( N.LT.0 ) THEN + INFO = -2 + ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSEIF ( DELTA.LE.ZERO ) THEN + INFO = -8 + ELSEIF( PAR.LT.ZERO ) THEN + INFO = -9 + ELSEIF ( UCOND .AND. ( RANK.LT.0 .OR. RANK.GT.N ) ) THEN + INFO = -10 + ELSEIF ( LDWORK.LT.2*N .OR. ( ECOND .AND. LDWORK.LT.4*N ) ) THEN + INFO = -15 + ELSEIF ( N.GT.0 ) THEN + DMINO = DIAG(1) + SING = .FALSE. +C + DO 10 J = 1, N + IF ( DIAG(J).LT.DMINO ) + $ DMINO = DIAG(J) + SING = SING .OR. DIAG(J).EQ.ZERO + 10 CONTINUE +C + IF ( SING ) + $ INFO = -6 + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MD03BY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + PAR = ZERO + RANK = 0 + RETURN + END IF +C +C DWARF is the smallest positive magnitude. +C + DWARF = DLAMCH( 'Underflow' ) + N2 = N +C +C Estimate the rank of R, if required. +C + IF ( ECOND ) THEN + N2 = 2*N + TEMP = TOL + IF ( TEMP.LE.ZERO ) THEN +C +C Use the default tolerance in rank determination. +C + TEMP = DBLE( N )*DLAMCH( 'Epsilon' ) + END IF +C +C Estimate the reciprocal condition number of R and set the rank. +C Workspace: 2*N. +C + CALL MB03OD( 'No QR', N, N, R, LDR, IPVT, TEMP, SVLMAX, DWORK, + $ RANK, DUM, DWORK, LDWORK, INFO ) +C + ELSEIF ( NCOND ) THEN + J = 1 +C + 20 CONTINUE + IF ( R(J,J).NE.ZERO ) THEN + J = J + 1 + IF ( J.LE.N ) + $ GO TO 20 + END IF +C + RANK = J - 1 + END IF +C +C Compute and store in x the Gauss-Newton direction. If the +C Jacobian is rank-deficient, obtain a least squares solution. +C The array RX is used as workspace. +C + CALL DCOPY( RANK, QTB, 1, RX, 1 ) + DUM(1) = ZERO + IF ( RANK.LT.N ) + $ CALL DCOPY( N-RANK, DUM, 0, RX(RANK+1), 1 ) + CALL DTRSV( 'Upper', 'No transpose', 'Non unit', RANK, R, LDR, + $ RX, 1 ) +C + DO 30 J = 1, N + L = IPVT(J) + X(L) = RX(J) + 30 CONTINUE +C +C Initialize the iteration counter. +C Evaluate the function at the origin, and test +C for acceptance of the Gauss-Newton direction. +C + ITER = 0 +C + DO 40 J = 1, N + DWORK(J) = DIAG(J)*X(J) + 40 CONTINUE +C + DXNORM = DNRM2( N, DWORK, 1 ) + FP = DXNORM - DELTA + IF ( FP.GT.P1*DELTA ) THEN +C +C Set an appropriate option for estimating the condition of +C the matrix S. +C + IF ( UCOND ) THEN + IF ( LDWORK.GE.4*N ) THEN + CONDL = 'E' + TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) + ELSE + CONDL = 'N' + TOLDEF = TOL + END IF + ELSE + CONDL = COND + TOLDEF = TOL + END IF +C +C If the Jacobian is not rank deficient, the Newton +C step provides a lower bound, PARL, for the zero of +C the function. Otherwise set this bound to zero. +C + IF ( RANK.EQ.N ) THEN +C + DO 50 J = 1, N + L = IPVT(J) + RX(J) = DIAG(L)*( DWORK(L)/DXNORM ) + 50 CONTINUE +C + CALL DTRSV( 'Upper', 'Transpose', 'Non unit', N, R, LDR, + $ RX, 1 ) + TEMP = DNRM2( N, RX, 1 ) + PARL = ( ( FP/DELTA )/TEMP )/TEMP +C +C For efficiency, use CONDL = 'U', if possible. +C + IF ( .NOT.LSAME( CONDL, 'U' ) .AND. DMINO.GT.ZERO ) + $ CONDL = 'U' + ELSE + PARL = ZERO + END IF +C +C Calculate an upper bound, PARU, for the zero of the function. +C + DO 60 J = 1, N + L = IPVT(J) + RX(J) = DDOT( J, R(1,J), 1, QTB, 1 )/DIAG(L) + 60 CONTINUE +C + GNORM = DNRM2( N, RX, 1 ) + PARU = GNORM/DELTA + IF ( PARU.EQ.ZERO ) + $ PARU = DWARF/MIN( DELTA, P1 )/P001 +C +C If the input PAR lies outside of the interval (PARL,PARU), +C set PAR to the closer endpoint. +C + PAR = MAX( PAR, PARL ) + PAR = MIN( PAR, PARU ) + IF ( PAR.EQ.ZERO ) + $ PAR = GNORM/DXNORM +C +C Beginning of an iteration. +C + 70 CONTINUE + ITER = ITER + 1 +C +C Evaluate the function at the current value of PAR. +C + IF ( PAR.EQ.ZERO ) + $ PAR = MAX( DWARF, P001*PARU ) + TEMP = SQRT( PAR ) +C + DO 80 J = 1, N + RX(J) = TEMP*DIAG(J) + 80 CONTINUE +C +C Solve the system A*x = b , sqrt(PAR)*D*x = 0 , in a least +C square sense. The first N elements of DWORK contain the +C diagonal elements of the upper triangular matrix S, and +C the next N elements contain the vector z, so that x = P*z. +C The vector z is preserved if COND = 'E'. +C Workspace: 4*N, if CONDL = 'E'; +C 2*N, if CONDL <> 'E'. +C + CALL MB02YD( CONDL, N, R, LDR, IPVT, RX, QTB, RANK, X, + $ TOLDEF, DWORK, LDWORK, INFO ) +C + DO 90 J = 1, N + DWORK(N2+J) = DIAG(J)*X(J) + 90 CONTINUE +C + DXNORM = DNRM2( N, DWORK(N2+1), 1 ) + TEMP = FP + FP = DXNORM - DELTA +C +C If the function is small enough, accept the current value +C of PAR. Also test for the exceptional cases where PARL +C is zero or the number of iterations has reached ITMAX. +C + IF ( ABS( FP ).GT.P1*DELTA .AND. + $ ( PARL.NE.ZERO .OR. FP.GT.TEMP .OR. TEMP.GE.ZERO ) .AND. + $ ITER.LT.ITMAX ) THEN +C +C Compute the Newton correction. +C + DO 100 J = 1, RANK + L = IPVT(J) + RX(J) = DIAG(L)*( DWORK(N2+L)/DXNORM ) + 100 CONTINUE +C + IF ( RANK.LT.N ) + $ CALL DCOPY( N-RANK, DUM, 0, RX(RANK+1), 1 ) + CALL DSWAP( N, R, LDR+1, DWORK, 1 ) + CALL DTRSV( 'Lower', 'No transpose', 'Non Unit', RANK, + $ R, LDR, RX, 1 ) + CALL DSWAP( N, R, LDR+1, DWORK, 1 ) + TEMP = DNRM2( RANK, RX, 1 ) + PARC = ( ( FP/DELTA )/TEMP )/TEMP +C +C Depending on the sign of the function, update PARL +C or PARU. +C + IF ( FP.GT.ZERO ) THEN + PARL = MAX( PARL, PAR ) + ELSE IF ( FP.LT.ZERO ) THEN + PARU = MIN( PARU, PAR ) + END IF +C +C Compute an improved estimate for PAR. +C + PAR = MAX( PARL, PAR + PARC ) +C +C End of an iteration. +C + GO TO 70 + END IF + END IF +C +C Compute -R*P'*x = -R*z. +C + IF ( ECOND .AND. ITER.GT.0 ) THEN +C + DO 110 J = 1, N + RX(J) = -DWORK(N+J) + 110 CONTINUE +C + CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', N, R, LDR, + $ RX, 1 ) + ELSE +C + DO 120 J = 1, N + RX(J) = ZERO + L = IPVT(J) + CALL DAXPY( J, -X(L), R(1,J), 1, RX, 1 ) + 120 CONTINUE +C + END IF +C +C Termination. If PAR = 0, set S. +C + IF ( ITER.EQ.0 ) THEN + PAR = ZERO +C + DO 130 J = 1, N - 1 + DWORK(J) = R(J,J) + CALL DCOPY( N-J, R(J,J+1), LDR, R(J+1,J), 1 ) + 130 CONTINUE +C + DWORK(N) = R(N,N) + END IF +C + RETURN +C +C *** Last line of MD03BY *** + END diff --git a/mex/sources/libslicot/NF01AD.f b/mex/sources/libslicot/NF01AD.f new file mode 100644 index 000000000..16af66a25 --- /dev/null +++ b/mex/sources/libslicot/NF01AD.f @@ -0,0 +1,230 @@ + SUBROUTINE NF01AD( NSMP, M, L, IPAR, LIPAR, X, LX, U, LDU, Y, LDY, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate the output y of the Wiener system +C +C x(t+1) = A*x(t) + B*u(t) +C z(t) = C*x(t) + D*u(t), +C +C y(t) = f(z(t),wb(1:L)), +C +C where t = 1, 2, ..., NSMP, and f is a nonlinear function, +C evaluated by the SLICOT Library routine NF01AY. The parameter +C vector X is partitioned as X = ( wb(1), ..., wb(L), theta ), +C where wb(i), i = 1:L, correspond to the nonlinear part, theta +C corresponds to the linear part, and the notation is fully +C described below. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NSMP (input) INTEGER +C The number of training samples. NSMP >= 0. +C +C M (input) INTEGER +C The length of each input sample. M >= 0. +C +C L (input) INTEGER +C The length of each output sample. L >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters needed. +C IPAR(1) must contain the order of the linear part, +C referred to as N below. N >= 0. +C IPAR(2) must contain the number of neurons for the +C nonlinear part, referred to as NN below. +C NN >= 0. +C +C LIPAR (input) INTEGER +C The length of IPAR. LIPAR >= 2. +C +C X (input) DOUBLE PRECISION array, dimension (LX) +C The parameter vector, partitioned as +C X = (wb(1), ..., wb(L), theta), where the vectors +C wb(i), of length NN*(L+2)+1, are parameters for the +C static nonlinearity, which is simulated by the +C SLICOT Library routine NF01AY. See the documentation of +C NF01AY for further details. The vector theta, of length +C N*(M + L + 1) + L*M, represents the matrices A, B, C, +C D and x(1), and it can be retrieved from these matrices +C by SLICOT Library routine TB01VD and retranslated by +C TB01VY. +C +C LX (input) INTEGER +C The length of the array X. +C LX >= ( NN*(L+2)+1 )*L + N*(M + L + 1) + L*M. +C +C U (input) DOUBLE PRECISION array, dimension (LDU, M) +C The leading NSMP-by-M part of this array must contain the +C set of input samples, +C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). +C +C LDU INTEGER +C The leading dimension of the array U. LDU >= MAX(1,NSMP). +C +C Y (output) DOUBLE PRECISION array, dimension (LDY, L) +C The leading NSMP-by-L part of this array contains the +C simulated output. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= MAX(1,NSMP). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + +C MAX( N*(N + L), N + M + L ) ) +C if M > 0; +C LDWORK >= NSMP*L + MAX( 2*NN, (N + L)*N + 2*N + +C MAX( N*(N + L), L ) ), if M = 0. +C A larger value of LDWORK could improve the efficiency. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C METHOD +C +C BLAS routines are used for the matrix-vector multiplications and +C the routine NF01AY is called for the calculation of the nonlinear +C function. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Mar. 2001, during a stay at University of Twente, NL. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, +C Dec. 2001. +C +C KEYWORDS +C +C Nonlinear system, output normal form, simulation, state-space +C representation, Wiener system. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INFO, L, LDU, LDWORK, LDY, LX, LIPAR, M, NSMP +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DWORK(*), U(LDU,*), X(*), Y(LDY,*) +C .. Local Scalars .. + INTEGER AC, BD, IX, JW, LDAC, LTHS, N, NN, NTHS, Z +C .. External Subroutines .. + EXTERNAL NF01AY, TB01VY, TF01MX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C + INFO = 0 + IF ( NSMP.LT.0 ) THEN + INFO = -1 + ELSEIF ( M.LT.0 ) THEN + INFO = -2 + ELSEIF ( L.LT.0 ) THEN + INFO = -3 + ELSEIF ( LIPAR.LT.2 ) THEN + INFO = -5 + ELSE +C + N = IPAR(1) + NN = IPAR(2) + LDAC = N + L + NTHS = ( NN*( L + 2 ) + 1 )*L + LTHS = N*( M + L + 1 ) + L*M +C + IF ( N.LT.0 .OR. NN.LT.0 ) THEN + INFO = -4 + ELSEIF ( LX.LT.NTHS + LTHS ) THEN + INFO = -7 + ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN + INFO = -9 + ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN + INFO = -11 + ELSE + IF ( M.GT.0 ) THEN + JW = MAX( N*LDAC, N + M + L ) + ELSE + JW = MAX( N*LDAC, L ) + END IF + IF ( LDWORK.LT.NSMP*L + MAX( 2*NN, LDAC*( N + M ) + 2*N + + $ JW ) ) + $ INFO = -13 + ENDIF + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01AD', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( MIN( NSMP, L ).EQ.0 ) + $ RETURN +C +C Compute the output of the linear part. +C Workspace: need NSMP*L + (N + L)*(N + M) + N + N*(N + L + 1). +C (NSMP*L locations are reserved for the output of the linear part.) +C + Z = 1 + AC = Z + NSMP*L + BD = AC + LDAC*N + IX = BD + LDAC*M + JW = IX + N +C + CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), LDAC, + $ DWORK(BD), LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), + $ LDAC, DWORK(IX), DWORK(JW), LDWORK-JW+1, INFO ) +C +C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, if M>0; +C NSMP*L + (N + L)*N + 2*N + L, if M=0; +C prefer larger. +C + CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, DWORK(IX), + $ DWORK(Z), NSMP, DWORK(JW), LDWORK-JW+1, INFO ) +C +C Simulate the static nonlinearity. +C Workspace: need NSMP*L + 2*NN; +C prefer larger. +C + JW = AC + CALL NF01AY( NSMP, L, L, IPAR(2), LIPAR-1, X, NTHS, DWORK(Z), + $ NSMP, Y, LDY, DWORK(JW), LDWORK-JW+1, INFO ) +C + RETURN +C +C *** Last line of NF01AD *** + END diff --git a/mex/sources/libslicot/NF01AY.f b/mex/sources/libslicot/NF01AY.f new file mode 100644 index 000000000..cc9782a86 --- /dev/null +++ b/mex/sources/libslicot/NF01AY.f @@ -0,0 +1,353 @@ + SUBROUTINE NF01AY( NSMP, NZ, L, IPAR, LIPAR, WB, LWB, Z, LDZ, + $ Y, LDY, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate the output of a set of neural networks with the +C structure +C +C - tanh(w1'*z+b1) - +C / : \ +C z --- : --- sum(ws(i)*...)+ b(n+1) --- y, +C \ : / +C - tanh(wn'*z+bn) - +C +C given the input z and the parameter vectors wi, ws, and b, +C where z, w1, ..., wn are vectors of length NZ, ws is a vector +C of length n, b(1), ..., b(n+1) are scalars, and n is called the +C number of neurons in the hidden layer, or just number of neurons. +C Such a network is used for each L output variables. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NSMP (input) INTEGER +C The number of training samples. NSMP >= 0. +C +C NZ (input) INTEGER +C The length of each input sample. NZ >= 0. +C +C L (input) INTEGER +C The length of each output sample. L >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters needed. +C IPAR(1) must contain the number of neurons, n, per output +C variable, denoted NN in the sequel. NN >= 0. +C +C LIPAR (input) INTEGER +C The length of the vector IPAR. LIPAR >= 1. +C +C WB (input) DOUBLE PRECISION array, dimension (LWB) +C The leading (NN*(NZ+2)+1)*L part of this array must +C contain the weights and biases of the network. This vector +C is partitioned into L vectors of length NN*(NZ+2)+1, +C WB = [ wb(1), ..., wb(L) ]. Each wb(k), k = 1, ..., L, +C corresponds to one output variable, and has the structure +C wb(k) = [ w1(1), ..., w1(NZ), ..., wn(1), ..., wn(NZ), +C ws(1), ..., ws(n), b(1), ..., b(n+1) ], +C where wi(j) are the weights of the hidden layer, +C ws(i) are the weights of the linear output layer, and +C b(i) are the biases, as in the scheme above. +C +C LWB (input) INTEGER +C The length of the array WB. +C LWB >= ( NN*(NZ + 2) + 1 )*L. +C +C Z (input) DOUBLE PRECISION array, dimension (LDZ, NZ) +C The leading NSMP-by-NZ part of this array must contain the +C set of input samples, +C Z = ( Z(1,1),...,Z(1,NZ); ...; Z(NSMP,1),...,Z(NSMP,NZ) ). +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= MAX(1,NSMP). +C +C Y (output) DOUBLE PRECISION array, dimension (LDY, L) +C The leading NSMP-by-L part of this array contains the set +C of output samples, +C Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ). +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= MAX(1,NSMP). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 2*NN. +C For better performance, LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C BLAS routines are used to compute the matrix-vector products. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Oct. 2000, during a stay at University of Twente, NL. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Input output description, neural network, nonlinear system, +C simulation, system response. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, L, LDWORK, LDY, LDZ, LIPAR, LWB, NSMP, NZ +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), WB(*), Y(LDY,*), Z(LDZ,*) + INTEGER IPAR(*) +C .. Local Scalars .. + LOGICAL LAST + INTEGER I, IB, J, K, LDWB, LJ, LK, M, MF, NN, NV, WS + DOUBLE PRECISION BIGNUM, DF, SMLNUM, TMP +C .. External Functions .. + DOUBLE PRECISION DDOT, DLAMCH + EXTERNAL DDOT, DLAMCH +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, EXP, LOG, MAX, MIN, MOD +C .. +C .. Executable Statements .. +C + INFO = 0 + NN = IPAR(1) + LDWB = NN*( NZ + 2 ) + 1 + IF ( NSMP.LT.0 ) THEN + INFO = -1 + ELSEIF ( NZ.LT.0 ) THEN + INFO = -2 + ELSEIF ( L.LT.0 ) THEN + INFO = -3 + ELSEIF ( NN.LT.0 ) THEN + INFO = -4 + ELSEIF ( LIPAR.LT.1 ) THEN + INFO = -5 + ELSEIF ( LWB.LT.LDWB*L ) THEN + INFO = -7 + ELSEIF ( LDZ.LT.MAX( 1, NSMP ) ) THEN + INFO = -9 + ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN + INFO = -11 + ELSEIF ( LDWORK.LT.2*NN ) THEN + INFO = -13 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01AY', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( MIN( NSMP, L ).EQ.0 ) + $ RETURN +C +C Set parameters to avoid overflows and increase accuracy for +C extreme values. +C + SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = LOG( SMLNUM ) + BIGNUM = LOG( BIGNUM ) +C + WS = NZ*NN + 1 + IB = WS + NN - 1 + LK = 0 + IF ( MIN( NZ, NN ).EQ.0 ) THEN + NV = 2 + ELSE + NV = ( LDWORK - NN )/NN + END IF +C + IF ( NV.GT.2 ) THEN + MF = ( NSMP/NV )*NV + LAST = MOD( NSMP, NV ).NE.0 +C +C Some BLAS 3 calculations can be used. +C + DO 70 K = 0, L - 1 + TMP = WB(IB+NN+1+LK) +C + DO 10 J = 1, NN + DWORK(J) = TWO*WB(IB+J+LK) + 10 CONTINUE +C + DO 40 I = 1, MF, NV +C +C Compute -2*[w1 w2 ... wn]'*Z', where +C Z = [z(i)';...; z(i+NV-1)']. +C + CALL DGEMM( 'Transpose', 'Transpose', NN, NV, NZ, -TWO, + $ WB(1+LK), NZ, Z(I,1), LDZ, ZERO, DWORK(NN+1), + $ NN ) + LJ = NN +C + DO 30 M = 1, NV + DO 20 J = 1, NN +C +C Compute tanh(wj'*z(i) + bj), j = 1:n. +C + LJ = LJ + 1 + DF = DWORK(LJ) - DWORK(J) + IF ( ABS( DF ).GE.BIGNUM ) THEN + IF ( DF.GT.ZERO ) THEN + DWORK(LJ) = -ONE + ELSE + DWORK(LJ) = ONE + END IF + ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN + DWORK(LJ) = ZERO + ELSE + DWORK(LJ) = TWO/( ONE + EXP( DF ) ) - ONE + END IF + 20 CONTINUE +C + 30 CONTINUE +C + Y(I, K+1) = TMP + CALL DCOPY( NV-1, Y(I, K+1), 0, Y(I+1, K+1), 1 ) + CALL DGEMV( 'Transpose', NN, NV, ONE, DWORK(NN+1), NN, + $ WB(WS+LK), 1, ONE, Y(I, K+1), 1 ) + 40 CONTINUE +C + IF ( LAST ) THEN +C +C Process the last samples. +C + NV = NSMP - MF + I = MF + 1 +C +C Compute -2*[w1 w2 ... wn]'*Z', where +C Z = [z(i)';...; z(NSMP)']. +C + CALL DGEMM( 'Transpose', 'Transpose', NN, NV, NZ, -TWO, + $ WB(1+LK), NZ, Z(I,1), LDZ, ZERO, DWORK(NN+1), + $ NN ) + LJ = NN +C + DO 60 M = 1, NV + DO 50 J = 1, NN +C +C Compute tanh(wj'*z(i) + bj), j = 1:n. +C + LJ = LJ + 1 + DF = DWORK(LJ) - DWORK(J) + IF ( ABS( DF ).GE.BIGNUM ) THEN + IF ( DF.GT.ZERO ) THEN + DWORK(LJ) = -ONE + ELSE + DWORK(LJ) = ONE + END IF + ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN + DWORK(LJ) = ZERO + ELSE + DWORK(LJ) = TWO/( ONE + EXP( DF ) ) - ONE + END IF + 50 CONTINUE +C + 60 CONTINUE +C + Y(I, K+1) = TMP + IF ( NV.GT.1 ) + $ CALL DCOPY( NV-1, Y(I, K+1), 0, Y(I+1, K+1), 1 ) + CALL DGEMV( 'Transpose', NN, NV, ONE, DWORK(NN+1), NN, + $ WB(WS+LK), 1, ONE, Y(I, K+1), 1 ) + END IF +C + LK = LK + LDWB + 70 CONTINUE +C + ELSE +C +C BLAS 2 calculations only can be used. +C + DO 110 K = 0, L - 1 + TMP = WB(IB+NN+1+LK) +C + DO 80 J = 1, NN + DWORK(J) = TWO*WB(IB+J+LK) + 80 CONTINUE +C + DO 100 I = 1, NSMP +C +C Compute -2*[w1 w2 ... wn]'*z(i). +C + IF ( NZ.EQ.0 ) THEN + DWORK(NN+1) = ZERO + CALL DCOPY( NN, DWORK(NN+1), 0, DWORK(NN+1), 1 ) + ELSE + CALL DGEMV( 'Transpose', NZ, NN, -TWO, WB(1+LK), NZ, + $ Z(I,1), LDZ, ZERO, DWORK(NN+1), 1 ) + END IF +C + DO 90 J = NN + 1, 2*NN +C +C Compute tanh(wj'*z(i) + bj), j = 1:n. +C + DF = DWORK(J) - DWORK(J-NN) + IF ( ABS( DF ).GE.BIGNUM ) THEN + IF ( DF.GT.ZERO ) THEN + DWORK(J) = -ONE + ELSE + DWORK(J) = ONE + END IF + ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN + DWORK(J) = ZERO + ELSE + DWORK(J) = TWO/( ONE + EXP( DF ) ) - ONE + END IF + 90 CONTINUE +C + Y(I, K+1) = DDOT( NN, WB(WS+LK), 1, DWORK(NN+1), 1 ) + + $ TMP + 100 CONTINUE +C + LK = LK + LDWB + 110 CONTINUE +C + END IF + RETURN +C +C *** Last line of NF01AY *** + END diff --git a/mex/sources/libslicot/NF01BA.f b/mex/sources/libslicot/NF01BA.f new file mode 100644 index 000000000..98c344a37 --- /dev/null +++ b/mex/sources/libslicot/NF01BA.f @@ -0,0 +1,104 @@ + SUBROUTINE NF01BA( IFLAG, NSMP, N, IPAR, LIPAR, Z, LDZ, Y, LDY, X, + $ NFEVL, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C This is the FCN routine for optimizing the parameters of the +C nonlinear part of a Wiener system (initialization phase), using +C SLICOT Library routine MD03AD. See the argument FCN in the +C routine MD03AD for the description of parameters. Note that +C NF01BA is called for each output of the Wiener system. +C +C ****************************************************************** +C +C .. Parameters .. +C .. CJTE is initialized to activate the calculation of J'*e .. +C .. NOUT is the unit number for printing intermediate results .. + CHARACTER CJTE + PARAMETER ( CJTE = 'C' ) + INTEGER NOUT + PARAMETER ( NOUT = 6 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER IFLAG, INFO, LDJ, LDWORK, LDY, LDZ, LIPAR, N, + $ NFEVL, NSMP +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), JTE(*), X(*), + $ Y(LDY,*), Z(LDZ,*) +C .. Local Scalars .. + DOUBLE PRECISION ERR +C .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +C .. External Subroutines .. + EXTERNAL DAXPY, NF01AY, NF01BY +C +C .. Executable Statements .. +C + INFO = 0 + IF ( IFLAG.EQ.1 ) THEN +C +C Call NF01AY to compute the output y of the Wiener system (in E) +C and then the error functions (also in E). The array Z must +C contain the output of the linear part of the Wiener system, and +C Y must contain the original output Y of the Wiener system. +C IPAR(2) must contain the number of outputs. +C Workspace: need: 2*NN, NN = IPAR(3) (number of neurons); +C prefer: larger. +C + CALL NF01AY( NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, LDZ, + $ E, NSMP, DWORK, LDWORK, INFO ) + CALL DAXPY( NSMP, -ONE, Y, 1, E, 1 ) + DWORK(1) = 2*IPAR(3) +C + ELSE IF ( IFLAG.EQ.2 ) THEN +C +C Call NF01BY to compute the Jacobian in a compressed form. +C IPAR(2), IPAR(3) must have the same content as for IFLAG = 1. +C Workspace: need: 0. +C + CALL NF01BY( CJTE, NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, + $ LDZ, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) + NFEVL = 0 + DWORK(1) = ZERO +C + ELSE IF ( IFLAG.EQ.3 ) THEN +C +C Set the parameter LDJ, the length of the array J, and the sizes +C of the workspace for FCN (IFLAG = 1 or 2), and JPJ. +C + LDJ = NSMP + IPAR(1) = NSMP*N + IPAR(2) = 2*IPAR(3) + IPAR(3) = 0 + IPAR(4) = NSMP +C + ELSE IF ( IFLAG.EQ.0 ) THEN +C +C Special call for printing intermediate results. +C + ERR = DNRM2( NSMP, E, 1 ) + WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR + END IF + RETURN +C +C *** Last line of NF01BA *** + END diff --git a/mex/sources/libslicot/NF01BB.f b/mex/sources/libslicot/NF01BB.f new file mode 100644 index 000000000..ec39f9b38 --- /dev/null +++ b/mex/sources/libslicot/NF01BB.f @@ -0,0 +1,138 @@ + SUBROUTINE NF01BB( IFLAG, NFUN, LX, IPAR, LIPAR, U, LDU, Y, LDY, + $ X, NFEVL, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C This is the FCN routine for optimizing all parameters of a Wiener +C system using SLICOT Library routine MD03AD. See the argument FCN +C in the routine MD03AD for the description of parameters. +C +C ****************************************************************** +C +C .. Parameters .. +C .. CJTE is initialized to activate the calculation of J'*e .. +C .. NOUT is the unit number for printing intermediate results .. + CHARACTER CJTE + PARAMETER ( CJTE = 'C' ) + INTEGER NOUT + PARAMETER ( NOUT = 6 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER IFLAG, INFO, LDJ, LDU, LDWORK, LDY, LIPAR, LX, + $ NFEVL, NFUN +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), JTE(*), U(LDU,*), + $ X(*), Y(LDY,*) +C .. Local Scalars .. + INTEGER BSN, I, JWORK, L, M, N, NN, NSMP, ST + DOUBLE PRECISION ERR +C .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +C .. External Subroutines .. + EXTERNAL DAXPY, NF01AD, NF01BD +C +C .. Executable Statements .. +C + L = IPAR(2) + M = IPAR(5) + N = IPAR(6) + IF ( L.EQ.0 ) THEN + NSMP = NFUN + ELSE + NSMP = NFUN/L + END IF +C + INFO = 0 + IF ( IFLAG.EQ.1 ) THEN +C +C Call NF01AD to compute the output y of the Wiener system (in E) +C and then the error functions (also in E). The array U must +C contain the input to the linear part of the Wiener system, and +C Y must contain the original output Y of the Wiener system. +C IPAR(6) must contain the number of states of the linear part, n. +C Workspace: need: NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + +C MAX( N*(N + L), N + M + L ) ), +C if M>0, +C NFUN + MAX( 2*NN, (N + L)*N + 2*N + +C MAX( N*(N + L), L ) ), if M=0, +C where NN = IPAR(7) (number of neurons); +C prefer: larger. +C + CALL NF01AD( NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, LDU, E, + $ NSMP, DWORK, LDWORK, INFO ) +C + DO 10 I = 1, L + CALL DAXPY( NSMP, -ONE, Y(1,I), 1, E((I-1)*NSMP+1), 1 ) + 10 CONTINUE +C + DWORK(1) = NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + + $ MAX( N*(N + L), N + M + L ) ) +C + ELSE IF ( IFLAG.EQ.2 ) THEN +C +C Call NF01BD to compute the Jacobian in a compressed form. +C Workspace: need: 2*NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + +C MAX( N*(N + L), N + M + L )), +C if M > 0, +C 2*NFUN + MAX( 2*NN, (N + L)*N + 2*N + +C MAX( N*(N + L), L ) ), +C if M = 0; +C prefer: larger. +C + CALL NF01BD( CJTE, NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, + $ LDU, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) + NFEVL = IPAR(6)*( M + L + 1 ) + L*M + DWORK(1) = 2*NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + + $ MAX( N*(N + L), N + M + L ) ) +C + ELSE IF ( IFLAG.EQ.3 ) THEN +C +C Set the parameter LDJ, the length of the array J, and the sizes +C of the workspace for FCN (IFLAG = 1 or 2), and JTJ. +C + ST = IPAR(1) + BSN = IPAR(4) + NN = IPAR(7) +C + LDJ = NFUN + IPAR(1) = NFUN*( BSN + ST ) + IF ( M.GT.0 ) THEN + JWORK = MAX( N*( N + L ), N + M + L ) + ELSE + JWORK = MAX( N*( N + L ), L ) + END IF + IPAR(2) = LDJ + MAX( ( N + L )*( N + M ) + 2*N + JWORK, 2*NN ) + IPAR(3) = LDJ + IPAR(2) + IPAR(4) = 0 + IPAR(5) = NFUN +C + ELSE IF ( IFLAG.EQ.0 ) THEN +C +C Special call for printing intermediate results. +C + ERR = DNRM2( NFUN, E, 1 ) + WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR + END IF + RETURN +C +C *** Last line of NF01BB *** + END diff --git a/mex/sources/libslicot/NF01BD.f b/mex/sources/libslicot/NF01BD.f new file mode 100644 index 000000000..3f15bc2a6 --- /dev/null +++ b/mex/sources/libslicot/NF01BD.f @@ -0,0 +1,381 @@ + SUBROUTINE NF01BD( CJTE, NSMP, M, L, IPAR, LIPAR, X, LX, U, LDU, + $ E, J, LDJ, JTE, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate the Jacobian dy/dX of the Wiener system +C +C x(t+1) = A*x(t) + B*u(t) +C z(t) = C*x(t) + D*u(t), +C +C y(t,i) = sum( ws(k, i)*f(w(k, i)*z(t) + b(k,i)) ) + b(k+1,i), +C +C where t = 1, 2, ..., NSMP, +C i = 1, 2, ..., L, +C k = 1, 2, ..., NN. +C +C NN is arbitrary eligible and has to be provided in IPAR(2), and +C X = ( wb(1), ..., wb(L), theta ) is described below. +C +C Denoting y(j) = y(1:NSMP,j), the Jacobian J has the block form +C +C dy(1)/dwb(1) 0 ..... 0 dy(1)/dtheta +C 0 dy(2)/dwb(2) ..... 0 dy(2)/dtheta +C ..... ..... ..... ..... ..... +C 0 ..... 0 dy(L)/dwb(L) dy(L)/dtheta +C +C but it will be returned without the zero blocks, in the form +C +C dy(1)/dwb(1) dy(1)/dtheta +C ... +C dy(L)/dwb(L) dy(L)/dtheta. +C +C dy(i)/dwb(i) depends on f and is calculated by the routine NF01BY; +C dy(i)/dtheta is computed by a forward-difference approximation. +C +C ARGUMENTS +C +C Mode Parameters +C +C CJTE CHARACTER*1 +C Specifies whether the matrix-vector product J'*e should be +C computed or not, as follows: +C = 'C' : compute J'*e; +C = 'N' : do not compute J'*e. +C +C Input/Output Parameters +C +C NSMP (input) INTEGER +C The number of training samples. NSMP >= 0. +C +C M (input) INTEGER +C The length of each input sample. M >= 0. +C +C L (input) INTEGER +C The length of each output sample. L >= 0. +C +C IPAR (input/output) INTEGER array, dimension (LIPAR) +C On entry, the first entries of this array must contain +C the integer parameters needed; specifically, +C IPAR(1) must contain the order of the linear part, N; +C actually, N = abs(IPAR(1)), since setting +C IPAR(1) < 0 has a special meaning (see below); +C IPAR(2) must contain the number of neurons for the +C nonlinear part, NN, NN >= 0. +C On exit, if IPAR(1) < 0 on entry, then no computations are +C performed, except the needed tests on input parameters, +C but the following values are returned: +C IPAR(1) contains the length of the array J, LJ; +C LDJ contains the leading dimension of array J. +C Otherwise, IPAR(1) and LDJ are unchanged on exit. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 2. +C +C X (input) DOUBLE PRECISION array, dimension (LX) +C The leading LPAR entries of this array must contain the +C set of system parameters, where +C LPAR = (NN*(L + 2) + 1)*L + N*(M + L + 1) + L*M. +C X has the form (wb(1), ..., wb(L), theta), where the +C vectors wb(i) have the structure +C (w(1,1), ..., w(1,L), ..., w(NN,1), ..., w(NN,L), +C ws(1), ..., ws(NN), b(1), ..., b(NN+1) ), +C and the vector theta represents the matrices A, B, C, D +C and x(1), and it can be retrieved from these matrices +C by SLICOT Library routine TB01VD and retranslated by +C TB01VY. +C +C LX (input) INTEGER +C The length of X. +C LX >= (NN*(L + 2) + 1)*L + N*(M + L + 1) + L*M. +C +C U (input) DOUBLE PRECISION array, dimension (LDU, M) +C The leading NSMP-by-M part of this array must contain the +C set of input samples, +C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,NSMP). +C +C E (input) DOUBLE PRECISION array, dimension (NSMP*L) +C If CJTE = 'C', this array must contain a vector e, which +C will be premultiplied with J', e = vec( Y - y ), where +C Y is set of output samples, and vec denotes the +C concatenation of the columns of a matrix. +C If CJTE = 'N', this array is not referenced. +C +C J (output) DOUBLE PRECISION array, dimension (LDJ, *) +C The leading NSMP*L-by-NCOLJ part of this array contains +C the Jacobian of the error function stored in a compressed +C form, as described above, where +C NCOLJ = NN*(L + 2) + 1 + N*(M + L + 1) + L*M. +C +C LDJ INTEGER +C The leading dimension of array J. LDJ >= MAX(1,NSMP*L). +C Note that LDJ is an input parameter, except for +C IPAR(1) < 0 on entry, when it is an output parameter. +C +C JTE (output) DOUBLE PRECISION array, dimension (LPAR) +C If CJTE = 'C', this array contains the matrix-vector +C product J'*e. +C If CJTE = 'N', this array is not referenced. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 2*NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + +C MAX( N*(N + L), N + M + L ) ) +C if M > 0; +C LDWORK >= 2*NSMP*L + MAX( 2*NN, (N + L)*N + 2*N + +C MAX( N*(N + L), L ) ), if M = 0. +C A larger value of LDWORK could improve the efficiency. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C BLAS routines are used for the matrix-vector multiplications, and +C the SLICOT Library routine TB01VY is called for the conversion of +C the output normal form parameters to an LTI-system; the routine +C NF01AD is then used for the simulation of the system with given +C parameters, and the routine NF01BY is called for the (analytically +C performed) calculation of the parts referring to the parameters +C of the static nonlinearity. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Mar. 2001, during a stay at University of Twente, NL. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, +C Dec. 2001. +C +C KEYWORDS +C +C Jacobian matrix, nonlinear system, output normal form, simulation, +C state-space representation, Wiener system. +C +C ****************************************************************** +C +C .. Parameters .. +C .. EPSFCN is related to the error in computing the functions .. +C .. For EPSFCN = 0.0D0, the square root of the machine precision +C .. is used for finite difference approximation of the derivatives. + DOUBLE PRECISION ZERO, ONE, EPSFCN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, EPSFCN = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER CJTE + INTEGER INFO, L, LDJ, LDU, LDWORK, LX, LIPAR, M, NSMP +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DWORK(*), E(*), J(LDJ, *), JTE(*), U(LDU,*), + $ X(*) +C .. Local Scalars .. + LOGICAL WJTE + DOUBLE PRECISION EPS, H, PARSAV + INTEGER AC, BD, BSN, I, IX, IY, JW, K, KCOL, LDAC, LPAR, + $ LTHS, N, NN, NSML, NTHS, Z +C .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, NF01AD, NF01AY, NF01BY, TB01VY, + $ TF01MX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C + N = IPAR(1) + NN = IPAR(2) + BSN = NN*( L + 2 ) + 1 + NSML = NSMP*L + NTHS = BSN*L + LTHS = N*( M + L + 1 ) + L*M + LPAR = NTHS + LTHS + WJTE = LSAME( CJTE, 'C' ) +C +C Check the scalar input parameters. +C + INFO = 0 + IF( .NOT.( WJTE .OR. LSAME( CJTE, 'N' ) ) ) THEN + INFO = -1 + ELSEIF ( NSMP.LT.0 ) THEN + INFO = -2 + ELSEIF ( M.LT.0 ) THEN + INFO = -3 + ELSEIF ( L.LT.0 ) THEN + INFO = -4 + ELSEIF ( NN.LT.0 ) THEN + INFO = -5 + ELSEIF ( LIPAR.LT.2 ) THEN + INFO = -6 + ELSEIF ( IPAR(1).LT.0 ) THEN + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BD', -INFO ) + ELSE + IPAR(1) = NSML*( ABS( N )*( M + L + 1 ) + L*M + BSN ) + LDJ = MAX( 1, NSML ) + ENDIF + RETURN + ELSEIF ( LX.LT.LPAR ) THEN + INFO = -8 + ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN + INFO = -10 + ELSEIF ( LDJ.LT.MAX( 1, NSML ) ) THEN + INFO = -13 + ELSE + LDAC = N + L + IF ( M.GT.0 ) THEN + JW = MAX( N*LDAC, N + M + L ) + ELSE + JW = MAX( N*LDAC, L ) + END IF + IF ( LDWORK.LT.2*NSML + MAX( 2*NN, LDAC*( N + M ) + 2*N + JW )) + $ INFO = -16 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BD', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( MIN( NSMP, L ).EQ.0 ) THEN + IF ( WJTE .AND. LPAR.GE.1 ) THEN + JTE(1) = ZERO + CALL DCOPY( LPAR, JTE(1), 0, JTE(1), 1 ) + END IF + RETURN + END IF +C +C Compute the output of the linear part. +C Workspace: need 2*NSMP*L + (N + L)*(N + M) + N + N*(N + L + 1). +C (2*NSMP*L locations are reserved for computing two times the +C output of the linear part.) +C + IY = 1 + Z = IY + NSML + AC = Z + NSML + BD = AC + LDAC*N + IX = BD + LDAC*M + JW = IX + N +C + CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), LDAC, + $ DWORK(BD), LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), + $ LDAC, DWORK(IX), DWORK(JW), LDWORK-JW+1, INFO ) +C +C Workspace: need 2*NSMP*L + (N + L)*(N + M) + 3*N + M + L, +C if M > 0; +C 2*NSMP*L + (N + L)*N + 2*N + L, if M = 0; +C prefer larger. +C + CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, DWORK(IX), + $ DWORK(Z), NSMP, DWORK(JW), LDWORK-JW+1, INFO ) +C +C Fill the blocks dy(i)/dwb(i) and the corresponding parts of JTE, +C if needed. +C + JW = AC + IF ( WJTE ) THEN +C + DO 10 I = 0, L - 1 + CALL NF01BY( CJTE, NSMP, L, 1, IPAR(2), LIPAR-1, X(I*BSN+1), + $ BSN, DWORK(Z), NSMP, E(I*NSMP+1), + $ J(I*NSMP+1,1), LDJ, JTE(I*BSN+1), DWORK(JW), + $ LDWORK-JW+1, INFO ) + 10 CONTINUE +C + ELSE +C + DO 20 I = 0, L - 1 + CALL NF01BY( CJTE, NSMP, L, 1, IPAR(2), LIPAR-1, X(I*BSN+1), + $ BSN, DWORK(Z), NSMP, DWORK, J(I*NSMP+1,1), LDJ, + $ DWORK, DWORK(JW), LDWORK-JW+1, INFO ) + 20 CONTINUE +C + END IF +C +C Compute the output of the system with unchanged parameters. +C Workspace: need 2*NSMP*L + 2*NN; +C prefer larger. +C + CALL NF01AY( NSMP, L, L, IPAR(2), LIPAR-1, X, NTHS, DWORK(Z), + $ NSMP, DWORK(IY), NSMP, DWORK(JW), LDWORK-JW+1, + $ INFO ) +C +C Compute dy/dtheta numerically by forward-difference approximation. +C Workspace: need 2*NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + +C MAX( N*(N + L), N + M + L ) ), +C if M > 0; +C 2*NSMP*L + MAX( 2*NN, (N + L)*N + 2*N + +C MAX( N*(N + L), L ) ), if M = 0; +C prefer larger. +C + JW = Z + EPS = SQRT( MAX( EPSFCN, DLAMCH( 'Epsilon' ) ) ) +C + DO 40 K = NTHS + 1, LPAR + KCOL = K - NTHS + BSN + PARSAV = X(K) + IF ( PARSAV.EQ.ZERO ) THEN + H = EPS + ELSE + H = EPS*ABS( PARSAV ) + END IF + X(K) = X(K) + H + CALL NF01AD( NSMP, M, L, IPAR, LIPAR, X, LPAR, U, LDU, + $ J(1,KCOL), NSMP, DWORK(JW), LDWORK-JW+1, + $ INFO ) + X(K) = PARSAV +C + DO 30 I = 1, NSML + J(I,KCOL) = ( J(I,KCOL) - DWORK(I) ) / H + 30 CONTINUE +C + 40 CONTINUE +C + IF ( WJTE ) THEN +C +C Compute the last part of J'e in JTE. +C + CALL DGEMV( 'Transpose', NSML, LTHS, ONE, J(1,BSN+1), LDJ, E, + $ 1, ZERO, JTE(NTHS+1), 1 ) + END IF +C + RETURN +C +C *** Last line of NF01BD *** + END diff --git a/mex/sources/libslicot/NF01BE.f b/mex/sources/libslicot/NF01BE.f new file mode 100644 index 000000000..a9ad1dde5 --- /dev/null +++ b/mex/sources/libslicot/NF01BE.f @@ -0,0 +1,105 @@ + SUBROUTINE NF01BE( IFLAG, NSMP, N, IPAR, LIPAR, Z, LDZ, Y, LDY, X, + $ NFEVL, E, J, LDJ, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C This is the FCN routine for optimizing the parameters of the +C nonlinear part of a Wiener system (initialization phase), using +C SLICOT Library routine MD03BD. See the argument FCN in the +C routine MD03BD for the description of parameters. Note that +C NF01BE is called for each output of the Wiener system. +C +C ****************************************************************** +C +C .. Parameters .. +C .. CJTE is initialized to avoid the calculation of J'*e .. +C .. NOUT is the unit number for printing intermediate results .. + CHARACTER CJTE + PARAMETER ( CJTE = 'N' ) + INTEGER NOUT + PARAMETER ( NOUT = 6 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER IFLAG, INFO, LDJ, LDWORK, LDY, LDZ, LIPAR, N, + $ NFEVL, NSMP +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), X(*), Y(LDY,*), + $ Z(LDZ,*) +C .. Local Scalars .. + DOUBLE PRECISION ERR +C .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +C .. External Subroutines .. + EXTERNAL DAXPY, NF01AY, NF01BY +C +C .. Executable Statements .. +C + INFO = 0 + IF ( IFLAG.EQ.1 ) THEN +C +C Call NF01AY to compute the output y of the Wiener system (in E) +C and then the error functions (also in E). The array Z must +C contain the output of the linear part of the Wiener system, and +C Y must contain the original output Y of the Wiener system. +C IPAR(2) must contain the number of outputs. +C Workspace: need: 2*NN, NN = IPAR(3) (number of neurons); +C prefer: larger. +C + CALL NF01AY( NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, LDZ, + $ E, NSMP, DWORK, LDWORK, INFO ) + CALL DAXPY( NSMP, -ONE, Y, 1, E, 1 ) + DWORK(1) = 2*IPAR(3) +C + ELSE IF ( IFLAG.EQ.2 ) THEN +C +C Call NF01BY to compute the Jacobian in a compressed form. +C IPAR(2), IPAR(3) must have the same content as for IFLAG = 1. +C Workspace: need: 0. +C + CALL NF01BY( CJTE, NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, + $ LDZ, E, J, LDJ, DWORK, DWORK, LDWORK, INFO ) + NFEVL = 0 + DWORK(1) = ZERO +C + ELSE IF ( IFLAG.EQ.3 ) THEN +C +C Set the parameter LDJ, the length of the array J, and the sizes +C of the workspace for FCN (IFLAG = 1 or 2), QRFACT and LMPARM. +C + LDJ = NSMP + IPAR(1) = NSMP*N + IPAR(2) = 2*IPAR(3) + IPAR(3) = 0 + IPAR(4) = 4*N + 1 + IPAR(5) = 4*N +C + ELSE IF ( IFLAG.EQ.0 ) THEN +C +C Special call for printing intermediate results. +C + ERR = DNRM2( NSMP, E, 1 ) + WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR + END IF + RETURN +C +C *** Last line of NF01BE *** + END diff --git a/mex/sources/libslicot/NF01BF.f b/mex/sources/libslicot/NF01BF.f new file mode 100644 index 000000000..d47b288dc --- /dev/null +++ b/mex/sources/libslicot/NF01BF.f @@ -0,0 +1,157 @@ + SUBROUTINE NF01BF( IFLAG, NFUN, LX, IPAR, LIPAR, U, LDU, Y, LDY, + $ X, NFEVL, E, J, LDJ, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C This is the FCN routine for optimizing all parameters of a Wiener +C system using SLICOT Library routine MD03BD. See the argument FCN +C in the routine MD03BD for the description of parameters. +C +C ****************************************************************** +C +C .. Parameters .. +C .. CJTE is initialized to avoid the calculation of J'*e .. +C .. NOUT is the unit number for printing intermediate results .. + CHARACTER CJTE + PARAMETER ( CJTE = 'N' ) + INTEGER NOUT + PARAMETER ( NOUT = 6 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER IFLAG, INFO, LDJ, LDU, LDWORK, LDY, LIPAR, LX, + $ NFEVL, NFUN +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), U(LDU,*), X(*), + $ Y(LDY,*) +C .. Local Scalars .. + LOGICAL FULL + INTEGER BSN, I, JWORK, L, M, N, NN, NSMP, ST + DOUBLE PRECISION ERR +C .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +C .. External Subroutines .. + EXTERNAL DAXPY, NF01AD, NF01BD +C +C .. Executable Statements .. +C + L = IPAR(2) + M = IPAR(5) + N = IPAR(6) + IF ( L.EQ.0 ) THEN + NSMP = NFUN + ELSE + NSMP = NFUN/L + END IF +C + INFO = 0 + IF ( IFLAG.EQ.1 ) THEN +C +C Call NF01AD to compute the output y of the Wiener system (in E) +C and then the error functions (also in E). The array U must +C contain the input to the linear part of the Wiener system, and +C Y must contain the original output Y of the Wiener system. +C IPAR(6) must contain the number of states of the linear part, n. +C Workspace: need: NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + +C MAX( N*(N + L), N + M + L ) ), +C if M>0, +C NFUN + MAX( 2*NN, (N + L)*N + 2*N + +C MAX( N*(N + L), L ) ), if M=0, +C where NN = IPAR(7) (number of neurons); +C prefer: larger. +C + CALL NF01AD( NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, LDU, E, + $ NSMP, DWORK, LDWORK, INFO ) +C + DO 10 I = 1, L + CALL DAXPY( NSMP, -ONE, Y(1,I), 1, E((I-1)*NSMP+1), 1 ) + 10 CONTINUE +C + DWORK(1) = NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + + $ MAX( N*(N + L), N + M + L ) ) +C + ELSE IF ( IFLAG.EQ.2 ) THEN +C +C Call NF01BD to compute the Jacobian in a compressed form. +C Workspace: need: 2*NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + +C MAX( N*(N + L), N + M + L )), +C if M > 0, +C 2*NFUN + MAX( 2*NN, (N + L)*N + 2*N + +C MAX( N*(N + L), L ) ), +C if M > 0; +C prefer: larger. +C + CALL NF01BD( CJTE, NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, + $ LDU, E, J, LDJ, DWORK, DWORK, LDWORK, INFO ) + NFEVL = IPAR(6)*( M + L + 1 ) + L*M + DWORK(1) = 2*NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + + $ MAX( N*(N + L), N + M + L ) ) +C + ELSE IF ( IFLAG.EQ.3 ) THEN +C +C Set the parameter LDJ, the length of the array J, and the sizes +C of the workspace for FCN (IFLAG = 1 or 2), QRFACT and LMPARM. +C Condition estimation (COND = 'E') is assumed in these routines. +C + ST = IPAR(1) + BSN = IPAR(4) + NN = IPAR(7) + FULL = L.LE.1 .OR. BSN.EQ.0 +C + LDJ = NFUN + IPAR(1) = LDJ*( BSN + ST ) + IF ( M.GT.0 ) THEN + JWORK = MAX( N*( N + L ), N + M + L ) + ELSE + JWORK = MAX( N*( N + L ), L ) + END IF + IPAR(2) = LDJ + MAX( (N + L)*(N + M) + 2*N + JWORK, 2*NN ) + IPAR(3) = LDJ + IPAR(2) + JWORK = 1 + IF ( FULL ) THEN + JWORK = 4*LX + 1 + ELSEIF ( BSN.GT.0 ) THEN + JWORK = BSN + MAX( 3*BSN + 1, ST ) + IF ( NSMP.GT.BSN ) THEN + JWORK = MAX( JWORK, 4*ST + 1 ) + IF ( NSMP.LT.2*BSN ) + $ JWORK = MAX( JWORK, ( NSMP - BSN )*( L - 1 ) ) + END IF + END IF + IPAR(4) = JWORK + IF ( FULL ) THEN + JWORK = 4*LX + ELSE + JWORK = ST*( LX - ST ) + 2*LX + 2*MAX( BSN, ST ) + END IF + IPAR(5) = JWORK +C + ELSE IF ( IFLAG.EQ.0 ) THEN +C +C Special call for printing intermediate results. +C + ERR = DNRM2( NFUN, E, 1 ) + WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR + END IF + RETURN +C +C *** Last line of NF01BF *** + END diff --git a/mex/sources/libslicot/NF01BP.f b/mex/sources/libslicot/NF01BP.f new file mode 100644 index 000000000..e15e17f4e --- /dev/null +++ b/mex/sources/libslicot/NF01BP.f @@ -0,0 +1,666 @@ + SUBROUTINE NF01BP( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB, + $ DELTA, PAR, RANKS, X, RX, TOL, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine a value for the Levenberg-Marquardt parameter PAR +C such that if x solves the system +C +C J*x = b , sqrt(PAR)*D*x = 0 , +C +C in the least squares sense, where J is an m-by-n matrix, D is an +C n-by-n nonsingular diagonal matrix, and b is an m-vector, and if +C DELTA is a positive number, DXNORM is the Euclidean norm of D*x, +C then either PAR is zero and +C +C ( DXNORM - DELTA ) .LE. 0.1*DELTA , +C +C or PAR is positive and +C +C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . +C +C The matrix J is the current Jacobian matrix of a nonlinear least +C squares problem, provided in a compressed form by SLICOT Library +C routine NF01BD. It is assumed that a block QR factorization, with +C column pivoting, of J is available, that is, J*P = Q*R, where P is +C a permutation matrix, Q has orthogonal columns, and R is an upper +C triangular matrix with diagonal elements of nonincreasing +C magnitude for each block, as returned by SLICOT Library +C routine NF01BS. The routine NF01BP needs the upper triangle of R +C in compressed form, the permutation matrix P, and the first +C n components of Q'*b (' denotes the transpose). On output, +C NF01BP also provides a compressed representation of an upper +C triangular matrix S, such that +C +C P'*(J'*J + PAR*D*D)*P = S'*S . +C +C Matrix S is used in the solution process. The matrix R has the +C following structure +C +C / R_1 0 .. 0 | L_1 \ +C | 0 R_2 .. 0 | L_2 | +C | : : .. : | : | , +C | 0 0 .. R_l | L_l | +C \ 0 0 .. 0 | R_l+1 / +C +C where the submatrices R_k, k = 1:l, have the same order BSN, +C and R_k, k = 1:l+1, are square and upper triangular. This matrix +C is stored in the compressed form +C +C / R_1 | L_1 \ +C | R_2 | L_2 | +C Rc = | : | : | , +C | R_l | L_l | +C \ X | R_l+1 / +C +C where the submatrix X is irrelevant. The matrix S has the same +C structure as R, and its diagonal blocks are denoted by S_k, +C k = 1:l+1. +C +C If l <= 1, then the full upper triangle of the matrix R is stored. +C +C ARGUMENTS +C +C Mode Parameters +C +C COND CHARACTER*1 +C Specifies whether the condition of the diagonal blocks R_k +C and S_k of the matrices R and S should be estimated, +C as follows: +C = 'E' : use incremental condition estimation for each +C diagonal block of R_k and S_k to find its +C numerical rank; +C = 'N' : do not use condition estimation, but check the +C diagonal entries of R_k and S_k for zero values; +C = 'U' : use the ranks already stored in RANKS (for R). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix R. N = BN*BSN + ST >= 0. +C (See parameter description below.) +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix R, as follows: +C IPAR(1) must contain ST, the number of columns of the +C submatrices L_k and the order of R_l+1. ST >= 0. +C IPAR(2) must contain BN, the number of blocks, l, in the +C block diagonal part of R. BN >= 0. +C IPAR(3) must contain BSM, the number of rows of the blocks +C R_k, k = 1:l. BSM >= 0. +C IPAR(4) must contain BSN, the number of columns of the +C blocks R_k, k = 1:l. BSN >= 0. +C BSM is not used by this routine, but assumed equal to BSN. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 4. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR, NC) +C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. +C On entry, the leading N-by-NC part of this array must +C contain the (compressed) representation (Rc) of the upper +C triangular matrix R. If BN > 1, the submatrix X in Rc is +C not referenced. The zero strict lower triangles of R_k, +C k = 1:l+1, need not be set. If BN <= 1 or BSN = 0, then +C the full upper triangle of R must be stored. +C On exit, the full upper triangles of R_k, k = 1:l+1, and +C L_k, k = 1:l, are unaltered, and the strict lower +C triangles of R_k, k = 1:l+1, contain the corresponding +C strict upper triangles (transposed) of the upper +C triangular matrix S. +C If BN <= 1 or BSN = 0, then the transpose of the strict +C upper triangle of S is stored in the strict lower triangle +C of R. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C IPVT (input) INTEGER array, dimension (N) +C This array must define the permutation matrix P such that +C J*P = Q*R. Column j of P is column IPVT(j) of the identity +C matrix. +C +C DIAG (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the diagonal elements of the +C matrix D. DIAG(I) <> 0, I = 1,...,N. +C +C QTB (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the first n elements of the +C vector Q'*b. +C +C DELTA (input) DOUBLE PRECISION +C An upper bound on the Euclidean norm of D*x. DELTA > 0. +C +C PAR (input/output) DOUBLE PRECISION +C On entry, PAR must contain an initial estimate of the +C Levenberg-Marquardt parameter. PAR >= 0. +C On exit, it contains the final estimate of this parameter. +C +C RANKS (input or output) INTEGER array, dimension (r), where +C r = BN + 1, if ST > 0, BSN > 0, and BN > 1; +C r = BN, if ST = 0 and BSN > 0; +C r = 1, if ST > 0 and ( BSN = 0 or BN <= 1 ); +C r = 0, if ST = 0 and BSN = 0. +C On entry, if COND = 'U' and N > 0, this array must contain +C the numerical ranks of the submatrices R_k, k = 1:l(+1). +C On exit, if N > 0, this array contains the numerical ranks +C of the submatrices S_k, k = 1:l(+1). +C +C X (output) DOUBLE PRECISION array, dimension (N) +C This array contains the least squares solution of the +C system J*x = b, sqrt(PAR)*D*x = 0. +C +C RX (output) DOUBLE PRECISION array, dimension (N) +C This array contains the matrix-vector product -R*P'*x. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If COND = 'E', the tolerance to be used for finding the +C ranks of the submatrices R_k and S_k. If the user sets +C TOL > 0, then the given value of TOL is used as a lower +C bound for the reciprocal condition number; a (sub)matrix +C whose estimated condition number is less than 1/TOL is +C considered to be of full rank. If the user sets TOL <= 0, +C then an implicitly computed, default tolerance, defined by +C TOLDEF = N*EPS, is used instead, where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C This parameter is not relevant if COND = 'U' or 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, the first N elements of this array contain the +C diagonal elements of the upper triangular matrix S. +C If BN > 1 and BSN > 0, the elements N+1 : N+ST*(N-ST) +C contain the submatrix (S(1:N-ST,N-ST+1:N))' of the +C matrix S. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 2*N, if BN <= 1 or BSN = 0 and +C COND <> 'E'; +C LDWORK >= 4*N, if BN <= 1 or BSN = 0 and +C COND = 'E'; +C LDWORK >= ST*(N-ST) + 2*N, if BN > 1 and BSN > 0 and +C COND <> 'E'; +C LDWORK >= ST*(N-ST) + 2*N + 2*MAX(BSN,ST), +C if BN > 1 and BSN > 0 and +C COND = 'E'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The algorithm computes the Gauss-Newton direction. An approximate +C basic least squares solution is found if the Jacobian is rank +C deficient. The computations exploit the special structure and +C storage scheme of the matrix R. If one or more of the submatrices +C R_k or S_k, k = 1:l+1, is singular, then the computed result is +C not the basic least squares solution for the whole problem, but a +C concatenation of (least squares) solutions of the individual +C subproblems involving R_k or S_k, k = 1:l+1 (with adapted right +C hand sides). +C +C If the Gauss-Newton direction is not acceptable, then an iterative +C algorithm obtains improved lower and upper bounds for the +C Levenberg-Marquardt parameter PAR. Only a few iterations are +C generally needed for convergence of the algorithm. If, however, +C the limit of ITMAX = 10 iterations is reached, then the output PAR +C will contain the best value obtained so far. If the Gauss-Newton +C step is acceptable, it is stored in x, and PAR is set to zero, +C hence S = R. +C +C REFERENCES +C +C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. +C User's Guide for MINPACK-1. +C Applied Math. Division, Argonne National Laboratory, Argonne, +C Illinois, Report ANL-80-74, 1980. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0(N*(BSN+ST)) operations and is backward +C stable, if R is nonsingular. +C +C FURTHER COMMENTS +C +C This routine is a structure-exploiting, LAPACK-based modification +C of LMPAR from the MINPACK package [1], and with optional condition +C estimation. The option COND = 'U' is useful when dealing with +C several right-hand side vectors, but RANKS array should be reset. +C If COND = 'E', but the matrix S is guaranteed to be nonsingular +C and well conditioned relative to TOL, i.e., rank(R) = N, and +C min(DIAG) > 0, then its condition is not estimated. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C V. Sima, Feb. 2004. +C +C KEYWORDS +C +C Linear system of equations, matrix operations, plane rotations. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER ITMAX + PARAMETER ( ITMAX = 10 ) + DOUBLE PRECISION P1, P001, ZERO, ONE + PARAMETER ( P1 = 1.0D-1, P001 = 1.0D-3, ZERO = 0.0D0, + $ ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER COND + INTEGER INFO, LDR, LDWORK, LIPAR, N + DOUBLE PRECISION DELTA, PAR, TOL +C .. Array Arguments .. + INTEGER IPAR(*), IPVT(*), RANKS(*) + DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*) +C .. Local Scalars .. + INTEGER BN, BSM, BSN, I, IBSN, ITER, J, JW, K, L, LDS, + $ N2, NTHS, RANK, ST + DOUBLE PRECISION DMINO, DWARF, DXNORM, FP, GNORM, PARC, PARL, + $ PARU, SUM, TEMP, TOLDEF + LOGICAL BADRK, ECOND, NCOND, SING, UCOND + CHARACTER CONDL +C .. External Functions .. + DOUBLE PRECISION DDOT, DLAMCH, DNRM2 + LOGICAL LSAME + EXTERNAL DDOT, DLAMCH, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DTRMV, MD03BY, NF01BQ, NF01BR, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + ECOND = LSAME( COND, 'E' ) + NCOND = LSAME( COND, 'N' ) + UCOND = LSAME( COND, 'U' ) + INFO = 0 + N2 = 2*N + IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN + INFO = -1 + ELSEIF( N.LT.0 ) THEN + INFO = -2 + ELSEIF( LIPAR.LT.4 ) THEN + INFO = -4 + ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSEIF( DELTA.LE.ZERO ) THEN + INFO = -10 + ELSEIF( PAR.LT.ZERO ) THEN + INFO = -11 + ELSE + ST = IPAR(1) + BN = IPAR(2) + BSM = IPAR(3) + BSN = IPAR(4) + NTHS = BN*BSN + IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN + INFO = -3 + ELSEIF ( N.NE.NTHS + ST ) THEN + INFO = -2 + ELSE + IF ( N.GT.0 ) + $ DMINO = DIAG(1) + SING = .FALSE. +C + DO 10 J = 1, N + IF ( DIAG(J).LT.DMINO ) + $ DMINO = DIAG(J) + SING = SING .OR. DIAG(J).EQ.ZERO + 10 CONTINUE +C + IF ( SING ) THEN + INFO = -8 + ELSEIF ( UCOND ) THEN + BADRK = .FALSE. + IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN + IF ( N.GT.0 ) + $ BADRK = RANKS(1).LT.0 .OR. RANKS(1).GT.N + ELSE + RANK = 0 +C + DO 20 K = 1, BN + BADRK = BADRK .OR. RANKS(K).LT.0 + $ .OR. RANKS(K).GT.BSN + RANK = RANK + RANKS(K) + 20 CONTINUE +C + IF ( ST.GT.0 ) THEN + BADRK = BADRK .OR. RANKS(BN+1).LT.0 .OR. + $ RANKS(BN+1).GT.ST + RANK = RANK + RANKS(BN+1) + END IF + END IF + IF ( BADRK ) + $ INFO = -12 + ELSE + JW = N2 + IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN + IF ( ECOND ) + $ JW = 4*N + ELSE + JW = ST*NTHS + JW + IF ( ECOND ) + $ JW = 2*MAX( BSN, ST ) + JW + END IF + IF ( LDWORK.LT.JW ) + $ INFO = -17 + ENDIF + ENDIF + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BP', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + PAR = ZERO + RETURN + END IF +C + IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN +C +C Special case: R is just an upper triangular matrix. +C Workspace: 4*N, if COND = 'E'; +C 2*N, if COND <> 'E'. +C + CALL MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, + $ RANKS(1), X, RX, TOL, DWORK, LDWORK, INFO ) + RETURN + END IF +C +C General case: l > 1 and BSN > 0. +C DWARF is the smallest positive magnitude. +C + DWARF = DLAMCH( 'Underflow' ) +C +C Compute and store in x the Gauss-Newton direction. If the +C Jacobian is rank-deficient, obtain a least squares solution. +C The array RX is used as workspace. +C Workspace: 2*MAX(BSN,ST), if COND = 'E'; +C 0, if COND <> 'E'. +C + CALL DCOPY( N, QTB, 1, RX, 1 ) + CALL NF01BR( COND, 'Upper', 'No transpose', N, IPAR, LIPAR, R, + $ LDR, DWORK, DWORK, 1, RX, RANKS, TOL, DWORK, LDWORK, + $ INFO ) +C + DO 30 J = 1, N + L = IPVT(J) + X(L) = RX(J) + 30 CONTINUE +C +C Initialize the iteration counter. +C Evaluate the function at the origin, and test +C for acceptance of the Gauss-Newton direction. +C + ITER = 0 +C + DO 40 J = 1, N + DWORK(J) = DIAG(J)*X(J) + 40 CONTINUE +C + DXNORM = DNRM2( N, DWORK, 1 ) + FP = DXNORM - DELTA + IF ( FP.GT.P1*DELTA ) THEN +C +C Set an appropriate option for estimating the condition of +C the matrix S. +C + LDS = MAX( 1, ST ) + JW = N2 + ST*NTHS + IF ( UCOND ) THEN + IF ( LDWORK.GE.JW + 2*MAX( BSN, ST ) ) THEN + CONDL = 'E' + TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) + ELSE + CONDL = 'N' + TOLDEF = TOL + END IF + ELSE + RANK = 0 +C + DO 50 K = 1, BN + RANK = RANK + RANKS(K) + 50 CONTINUE +C + IF ( ST.GT.0 ) + $ RANK = RANK + RANKS(BN+1) + CONDL = COND + TOLDEF = TOL + END IF +C +C If the Jacobian is not rank deficient, the Newton +C step provides a lower bound, PARL, for the zero of +C the function. Otherwise set this bound to zero. +C + IF ( RANK.EQ.N ) THEN +C + DO 60 J = 1, N + L = IPVT(J) + RX(J) = DIAG(L)*( DWORK(L)/DXNORM ) + 60 CONTINUE +C + CALL NF01BR( 'Use ranks', 'Upper', 'Transpose', N, IPAR, + $ LIPAR, R, LDR, DWORK, DWORK, 1, RX, RANKS, TOL, + $ DWORK, LDWORK, INFO ) + TEMP = DNRM2( N, RX, 1 ) + PARL = ( ( FP/DELTA )/TEMP )/TEMP +C +C For efficiency, use CONDL = 'U', if possible. +C + IF ( .NOT.LSAME( CONDL, 'U' ) .AND. DMINO.GT.ZERO ) + $ CONDL = 'U' + ELSE + PARL = ZERO + END IF +C + IBSN = 0 + K = 1 +C +C Calculate an upper bound, PARU, for the zero of the function. +C + DO 70 J = 1, N + IBSN = IBSN + 1 + IF ( J.LT.NTHS ) THEN + SUM = DDOT( IBSN, R(K,IBSN), 1, QTB(K), 1 ) + IF ( IBSN.EQ.BSN ) THEN + IBSN = 0 + K = K + BSN + END IF + ELSE IF ( J.EQ.NTHS ) THEN + SUM = DDOT( IBSN, R(K,IBSN), 1, QTB(K), 1 ) + ELSE + SUM = DDOT( J, R(1,IBSN), 1, QTB, 1 ) + END IF + L = IPVT(J) + RX(J) = SUM/DIAG(L) + 70 CONTINUE +C + GNORM = DNRM2( N, RX, 1 ) + PARU = GNORM/DELTA + IF ( PARU.EQ.ZERO ) + $ PARU = DWARF/MIN( DELTA, P1 )/P001 +C +C If the input PAR lies outside of the interval (PARL,PARU), +C set PAR to the closer endpoint. +C + PAR = MAX( PAR, PARL ) + PAR = MIN( PAR, PARU ) + IF ( PAR.EQ.ZERO ) + $ PAR = GNORM/DXNORM +C +C Beginning of an iteration. +C + 80 CONTINUE + ITER = ITER + 1 +C +C Evaluate the function at the current value of PAR. +C + IF ( PAR.EQ.ZERO ) + $ PAR = MAX( DWARF, P001*PARU ) + TEMP = SQRT( PAR ) +C + DO 90 J = 1, N + RX(J) = TEMP*DIAG(J) + 90 CONTINUE +C +C Solve the system J*x = b , sqrt(PAR)*D*x = 0 , in a least +C square sense. +C The first N elements of DWORK contain the diagonal elements +C of the upper triangular matrix S, and the next N elements +C contain the the vector z, so that x = P*z (see NF01BQ). +C The vector z is not preserved, to reduce the workspace. +C The elements 2*N+1 : 2*N+ST*(N-ST) contain the +C submatrix (S(1:N-ST,N-ST+1:N))' of the matrix S. +C Workspace: ST*(N-ST) + 2*N, if CONDL <> 'E'; +C ST*(N-ST) + 2*N + 2*MAX(BSN,ST), if CONDL = 'E'. +C + CALL NF01BQ( CONDL, N, IPAR, LIPAR, R, LDR, IPVT, RX, QTB, + $ RANKS, X, TOLDEF, DWORK, LDWORK, INFO ) +C + DO 100 J = 1, N + DWORK(N+J) = DIAG(J)*X(J) + 100 CONTINUE +C + DXNORM = DNRM2( N, DWORK(N+1), 1 ) + TEMP = FP + FP = DXNORM - DELTA +C +C If the function is small enough, accept the current value +C of PAR. Also test for the exceptional cases where PARL +C is zero or the number of iterations has reached ITMAX. +C + IF ( ABS( FP ).GT.P1*DELTA .AND. + $ ( PARL.NE.ZERO .OR. FP.GT.TEMP .OR. TEMP.GE.ZERO ) .AND. + $ ITER.LT.ITMAX ) THEN +C +C Compute the Newton correction. +C + DO 110 J = 1, N + L = IPVT(J) + RX(J) = DIAG(L)*( DWORK(N+L)/DXNORM ) + 110 CONTINUE +C + CALL NF01BR( 'Use ranks', 'Lower', 'Transpose', N, IPAR, + $ LIPAR, R, LDR, DWORK, DWORK(N2+1), LDS, RX, + $ RANKS, TOL, DWORK(JW), LDWORK-JW, INFO ) + TEMP = DNRM2( N, RX, 1 ) + PARC = ( ( FP/DELTA )/TEMP )/TEMP +C +C Depending on the sign of the function, update PARL +C or PARU. +C + IF ( FP.GT.ZERO ) THEN + PARL = MAX( PARL, PAR ) + ELSE IF ( FP.LT.ZERO ) THEN + PARU = MIN( PARU, PAR ) + END IF +C +C Compute an improved estimate for PAR. +C + PAR = MAX( PARL, PAR + PARC ) +C +C End of an iteration. +C + GO TO 80 + END IF + END IF +C +C Compute -R*P'*x = -R*z. +C + DO 120 J = 1, N + L = IPVT(J) + RX(J) = -X(L) + 120 CONTINUE +C + DO 130 I = 1, NTHS, BSN + CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', BSN, R(I,1), + $ LDR, RX(I), 1 ) + 130 CONTINUE +C + IF ( ST.GT.0 ) THEN + CALL DGEMV( 'NoTranspose', NTHS, ST, ONE, R(1,BSN+1), LDR, + $ RX(NTHS+1), 1, ONE, RX, 1 ) + CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', ST, + $ R(NTHS+1,BSN+1), LDR, RX(NTHS+1), 1 ) + END IF +C +C Termination. If PAR = 0, set S. +C + IF ( ITER.EQ.0 ) THEN + PAR = ZERO + I = 1 +C + DO 150 K = 1, BN +C + DO 140 J = 1, BSN + DWORK(I) = R(I,J) + CALL DCOPY( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + 140 CONTINUE +C + 150 CONTINUE +C + IF ( ST.GT.0 ) THEN +C + DO 160 J = BSN + 1, BSN + ST + CALL DCOPY( NTHS, R(1,J), 1, DWORK(N+J-BSN), ST ) + DWORK(I) = R(I,J) + CALL DCOPY( BSN+ST-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + 160 CONTINUE +C + END IF + ELSE +C + DO 170 K = N + 1, N + ST*NTHS + DWORK(K) = DWORK(K+N) + 170 CONTINUE +C + END IF +C + RETURN +C +C *** Last line of NF01BP *** + END diff --git a/mex/sources/libslicot/NF01BQ.f b/mex/sources/libslicot/NF01BQ.f new file mode 100644 index 000000000..e07faaa28 --- /dev/null +++ b/mex/sources/libslicot/NF01BQ.f @@ -0,0 +1,477 @@ + SUBROUTINE NF01BQ( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB, + $ RANKS, X, TOL, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine a vector x which solves the system of linear +C equations +C +C J*x = b , D*x = 0 , +C +C in the least squares sense, where J is an m-by-n matrix, +C D is an n-by-n diagonal matrix, and b is an m-vector. The matrix J +C is the current Jacobian of a nonlinear least squares problem, +C provided in a compressed form by SLICOT Library routine NF01BD. +C It is assumed that a block QR factorization, with column pivoting, +C of J is available, that is, J*P = Q*R, where P is a permutation +C matrix, Q has orthogonal columns, and R is an upper triangular +C matrix with diagonal elements of nonincreasing magnitude for each +C block, as returned by SLICOT Library routine NF01BS. The routine +C NF01BQ needs the upper triangle of R in compressed form, the +C permutation matrix P, and the first n components of Q'*b +C (' denotes the transpose). The system J*x = b, D*x = 0, is then +C equivalent to +C +C R*z = Q'*b , P'*D*P*z = 0 , (1) +C +C where x = P*z. If this system does not have full rank, then an +C approximate least squares solution is obtained (see METHOD). +C On output, NF01BQ also provides an upper triangular matrix S +C such that +C +C P'*(J'*J + D*D)*P = S'*S . +C +C The system (1) is equivalent to S*z = c , where c contains the +C first n components of the vector obtained by applying to +C [ (Q'*b)' 0 ]' the transformations which triangularized +C [ R' P'*D*P ]', getting S. +C +C The matrix R has the following structure +C +C / R_1 0 .. 0 | L_1 \ +C | 0 R_2 .. 0 | L_2 | +C | : : .. : | : | , +C | 0 0 .. R_l | L_l | +C \ 0 0 .. 0 | R_l+1 / +C +C where the submatrices R_k, k = 1:l, have the same order BSN, +C and R_k, k = 1:l+1, are square and upper triangular. This matrix +C is stored in the compressed form +C +C / R_1 | L_1 \ +C | R_2 | L_2 | +C Rc = | : | : | , +C | R_l | L_l | +C \ X | R_l+1 / +C +C where the submatrix X is irrelevant. The matrix S has the same +C structure as R, and its diagonal blocks are denoted by S_k, +C k = 1:l+1. +C +C If l <= 1, then the full upper triangle of the matrix R is stored. +C +C ARGUMENTS +C +C Mode Parameters +C +C COND CHARACTER*1 +C Specifies whether the condition of the matrices S_k should +C be estimated, as follows: +C = 'E' : use incremental condition estimation and store +C the numerical rank of S_k in the array entry +C RANKS(k), for k = 1:l+1; +C = 'N' : do not use condition estimation, but check the +C diagonal entries of S_k for zero values; +C = 'U' : use the ranks already stored in RANKS(1:l+1). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix R. N = BN*BSN + ST >= 0. +C (See parameter description below.) +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix R, as follows: +C IPAR(1) must contain ST, the number of columns of the +C submatrices L_k and the order of R_l+1. ST >= 0. +C IPAR(2) must contain BN, the number of blocks, l, in the +C block diagonal part of R. BN >= 0. +C IPAR(3) must contain BSM, the number of rows of the blocks +C R_k, k = 1:l. BSM >= 0. +C IPAR(4) must contain BSN, the number of columns of the +C blocks R_k, k = 1:l. BSN >= 0. +C BSM is not used by this routine, but assumed equal to BSN. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 4. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR, NC) +C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. +C On entry, the leading N-by-NC part of this array must +C contain the (compressed) representation (Rc) of the upper +C triangular matrix R. If BN > 1, the submatrix X in Rc is +C not referenced. The zero strict lower triangles of R_k, +C k = 1:l+1, need not be set. If BN <= 1 or BSN = 0, then +C the full upper triangle of R must be stored. +C On exit, the full upper triangles of R_k, k = 1:l+1, and +C L_k, k = 1:l, are unaltered, and the strict lower +C triangles of R_k, k = 1:l+1, contain the corresponding +C strict upper triangles (transposed) of the upper +C triangular matrix S. +C If BN <= 1 or BSN = 0, then the transpose of the strict +C upper triangle of S is stored in the strict lower triangle +C of R. +C +C LDR INTEGER +C The leading dimension of the array R. LDR >= MAX(1,N). +C +C IPVT (input) INTEGER array, dimension (N) +C This array must define the permutation matrix P such that +C J*P = Q*R. Column j of P is column IPVT(j) of the identity +C matrix. +C +C DIAG (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the diagonal elements of the +C matrix D. +C +C QTB (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the first n elements of the +C vector Q'*b. +C +C RANKS (input or output) INTEGER array, dimension (r), where +C r = BN + 1, if ST > 0, BSN > 0, and BN > 1; +C r = BN, if ST = 0 and BSN > 0; +C r = 1, if ST > 0 and ( BSN = 0 or BN <= 1 ); +C r = 0, if ST = 0 and BSN = 0. +C On entry, if COND = 'U' and N > 0, this array must contain +C the numerical ranks of the submatrices S_k, k = 1:l(+1). +C On exit, if COND = 'E' or 'N' and N > 0, this array +C contains the numerical ranks of the submatrices S_k, +C k = 1:l(+1), estimated according to the value of COND. +C +C X (output) DOUBLE PRECISION array, dimension (N) +C This array contains the least squares solution of the +C system J*x = b, D*x = 0. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If COND = 'E', the tolerance to be used for finding the +C ranks of the submatrices S_k. If the user sets TOL > 0, +C then the given value of TOL is used as a lower bound for +C the reciprocal condition number; a (sub)matrix whose +C estimated condition number is less than 1/TOL is +C considered to be of full rank. If the user sets TOL <= 0, +C then an implicitly computed, default tolerance, defined by +C TOLDEF = N*EPS, is used instead, where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C This parameter is not relevant if COND = 'U' or 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, the first N elements of this array contain the +C diagonal elements of the upper triangular matrix S, and +C the next N elements contain the solution z. +C If BN > 1 and BSN > 0, the elements 2*N+1 : 2*N+ST*(N-ST) +C contain the submatrix (S(1:N-ST,N-ST+1:N))' of the +C matrix S. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 2*N, if BN <= 1 or BSN = 0 and +C COND <> 'E'; +C LDWORK >= 4*N, if BN <= 1 or BSN = 0 and +C COND = 'E'; +C LDWORK >= ST*(N-ST) + 2*N, if BN > 1 and BSN > 0 and +C COND <> 'E'; +C LDWORK >= ST*(N-ST) + 2*N + 2*MAX(BSN,ST), +C if BN > 1 and BSN > 0 and +C COND = 'E'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Standard plane rotations are used to annihilate the elements of +C the diagonal matrix D, updating the upper triangular matrix R +C and the first n elements of the vector Q'*b. A basic least squares +C solution is computed. The computations exploit the special +C structure and storage scheme of the matrix R. If one or more of +C the submatrices S_k, k = 1:l+1, is singular, then the computed +C result is not the basic least squares solution for the whole +C problem, but a concatenation of (least squares) solutions of the +C individual subproblems involving R_k, k = 1:l+1 (with adapted +C right hand sides). +C +C REFERENCES +C +C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. +C User's Guide for MINPACK-1. +C Applied Math. Division, Argonne National Laboratory, Argonne, +C Illinois, Report ANL-80-74, 1980. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0(N*(BSN+ST)) operations and is backward +C stable, if R is nonsingular. +C +C FURTHER COMMENTS +C +C This routine is a structure-exploiting, LAPACK-based modification +C of QRSOLV from the MINPACK package [1], and with optional +C condition estimation. +C The option COND = 'U' is useful when dealing with several +C right-hand side vectors. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Linear system of equations, matrix operations, plane rotations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER COND + INTEGER INFO, LDR, LDWORK, LIPAR, N + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IPAR(*), IPVT(*), RANKS(*) + DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), X(*) +C .. Local Scalars .. + DOUBLE PRECISION QTBPJ + INTEGER BN, BSM, BSN, I, IB, IBSN, IS, ITC, ITR, J, + $ JW, K, KF, L, NC, NTHS, ST + LOGICAL ECOND +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DSWAP, MB02YD, MB04OW, NF01BR, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + ECOND = LSAME( COND, 'E' ) + INFO = 0 + IF( .NOT.( ECOND .OR. LSAME( COND, 'N' ) .OR. + $ LSAME( COND, 'U' ) ) ) THEN + INFO = -1 + ELSEIF( N.LT.0 ) THEN + INFO = -2 + ELSEIF( LIPAR.LT.4 ) THEN + INFO = -4 + ELSE + ST = IPAR(1) + BN = IPAR(2) + BSM = IPAR(3) + BSN = IPAR(4) + NTHS = BN*BSN + IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN + INFO = -3 + ELSEIF ( N.NE.NTHS + ST ) THEN + INFO = -2 + ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE + JW = 2*N + IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN + IF ( ECOND ) + $ JW = 4*N + ELSE + JW = ST*NTHS + JW + IF ( ECOND ) + $ JW = 2*MAX( BSN, ST ) + JW + END IF + IF ( LDWORK.LT.JW ) + $ INFO = -14 + ENDIF + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BQ', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN +C +C Special case: R is an upper triangular matrix. +C Workspace: 4*N, if COND = 'E'; +C 2*N, if COND <> 'E'. +C + CALL MB02YD( COND, N, R, LDR, IPVT, DIAG, QTB, RANKS(1), X, + $ TOL, DWORK, LDWORK, INFO ) + RETURN + END IF +C +C General case: BN > 1 and BSN > 0. +C Copy R and Q'*b to preserve input and initialize S. +C In particular, save the diagonal elements of R in X. +C + IB = N + 1 + IS = IB + N + JW = IS + ST*NTHS + I = 1 + L = IS + NC = BSN + ST + KF = NC +C + DO 20 K = 1, BN +C + DO 10 J = 1, BSN + X(I) = R(I,J) + CALL DCOPY( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + 10 CONTINUE +C + 20 CONTINUE +C +C DWORK(IS) contains a copy of [ L_1' ... L_l' ]. +C Workspace: ST*(N-ST)+2*N; +C + DO 30 J = BSN + 1, NC + CALL DCOPY( NTHS, R(1,J), 1, DWORK(L), ST ) + X(I) = R(I,J) + CALL DCOPY( NC-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + L = L + 1 + 30 CONTINUE +C + CALL DCOPY( N, QTB, 1, DWORK(IB), 1 ) + IF ( ST.GT.0 ) THEN + ITR = NTHS + 1 + ITC = BSN + 1 + ELSE + ITR = 1 + ITC = 1 + END IF + IBSN = 0 +C +C Eliminate the diagonal matrix D using Givens rotations. +C + DO 50 J = 1, N + IBSN = IBSN + 1 + I = IBSN +C +C Prepare the row of D to be eliminated, locating the +C diagonal element using P from the QR factorization. +C + L = IPVT(J) + IF ( DIAG(L).NE.ZERO ) THEN + QTBPJ = ZERO + DWORK(J) = DIAG(L) +C + DO 40 K = J + 1, MIN( J + KF - 1, N ) + DWORK(K) = ZERO + 40 CONTINUE +C +C The transformations to eliminate the row of D modify only +C a single element of Q'*b beyond the first n, which is +C initially zero. +C + IF ( J.LT.NTHS ) THEN + CALL MB04OW( BSN-IBSN+1, ST, 1, R(J,IBSN), LDR, + $ R(ITR,ITC), LDR, DWORK(J), 1, DWORK(IB+J-1), + $ BSN, DWORK(IB+NTHS), ST, QTBPJ, 1 ) + IF ( IBSN.EQ.BSN ) + $ IBSN = 0 + ELSE IF ( J.EQ.NTHS ) THEN + CALL MB04OW( 1, ST, 1, R(J,IBSN), LDR, R(ITR,ITC), LDR, + $ DWORK(J), 1, DWORK(IB+J-1), BSN, + $ DWORK(IB+NTHS), ST, QTBPJ, 1 ) + KF = ST + ELSE + CALL MB04OW( 0, N-J+1, 1, R(J,IBSN), LDR, R(J,IBSN), LDR, + $ DWORK(J), 1, DWORK(IB+J-1), 1, + $ DWORK(IB+J-1), ST, QTBPJ, 1 ) + END IF + ELSE + IF ( J.LT.NTHS ) THEN + IF ( IBSN.EQ.BSN ) + $ IBSN = 0 + ELSE IF ( J.EQ.NTHS ) THEN + KF = ST + END IF + END IF +C +C Store the diagonal element of S. +C + DWORK(J) = R(J,I) + 50 CONTINUE +C +C Solve the triangular system for z. If the system is singular, +C then obtain an approximate least squares solution. +C Additional workspace: 2*MAX(BSN,ST), if COND = 'E'; +C 0, if COND <> 'E'. +C + CALL NF01BR( COND, 'Upper', 'NoTranspose', N, IPAR, LIPAR, R, LDR, + $ DWORK, DWORK(IS), 1, DWORK(IB), RANKS, TOL, + $ DWORK(JW), LDWORK-JW+1, INFO ) + I = 1 +C +C Restore the diagonal elements of R from X and interchange +C the upper and lower triangular parts of R. +C + DO 70 K = 1, BN +C + DO 60 J = 1, BSN + R(I,J) = X(I) + CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + 60 CONTINUE +C + 70 CONTINUE +C + DO 80 J = BSN + 1, NC + CALL DSWAP( NTHS, R(1,J), 1, DWORK(IS), ST ) + R(I,J) = X(I) + CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + IS = IS + 1 + 80 CONTINUE +C +C Permute the components of z back to components of x. +C + DO 90 J = 1, N + L = IPVT(J) + X(L) = DWORK(N+J) + 90 CONTINUE +C + RETURN +C +C *** Last line of NF01BQ *** + END diff --git a/mex/sources/libslicot/NF01BR.f b/mex/sources/libslicot/NF01BR.f new file mode 100644 index 000000000..4a68dab2b --- /dev/null +++ b/mex/sources/libslicot/NF01BR.f @@ -0,0 +1,711 @@ + SUBROUTINE NF01BR( COND, UPLO, TRANS, N, IPAR, LIPAR, R, LDR, + $ SDIAG, S, LDS, B, RANKS, TOL, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve one of the systems of linear equations +C +C R*x = b , or R'*x = b , +C +C in the least squares sense, where R is an n-by-n block upper +C triangular matrix, with the structure +C +C / R_1 0 .. 0 | L_1 \ +C | 0 R_2 .. 0 | L_2 | +C | : : .. : | : | , +C | 0 0 .. R_l | L_l | +C \ 0 0 .. 0 | R_l+1 / +C +C with the upper triangular submatrices R_k, k = 1:l+1, square, and +C the first l of the same order, BSN. The diagonal elements of each +C block R_k have nonincreasing magnitude. The matrix R is stored in +C the compressed form, as returned by SLICOT Library routine NF01BS, +C +C / R_1 | L_1 \ +C | R_2 | L_2 | +C Rc = | : | : | , +C | R_l | L_l | +C \ X | R_l+1 / +C +C where the submatrix X is irrelevant. If the matrix R does not have +C full rank, then a least squares solution is obtained. If l <= 1, +C then R is an upper triangular matrix and its full upper triangle +C is stored. +C +C Optionally, the transpose of the matrix R can be stored in the +C strict lower triangles of the submatrices R_k, k = 1:l+1, and in +C the arrays SDIAG and S, as described at the parameter UPLO below. +C +C ARGUMENTS +C +C Mode Parameters +C +C COND CHARACTER*1 +C Specifies whether the condition of submatrices R_k should +C be estimated, as follows: +C = 'E' : use incremental condition estimation and store +C the numerical rank of R_k in the array entry +C RANKS(k), for k = 1:l+1; +C = 'N' : do not use condition estimation, but check the +C diagonal entries of R_k for zero values; +C = 'U' : use the ranks already stored in RANKS(1:l+1). +C +C UPLO CHARACTER*1 +C Specifies the storage scheme for the matrix R, as follows: +C = 'U' : the upper triangular part is stored as in Rc; +C = 'L' : the lower triangular part is stored, namely, +C - the transpose of the strict upper triangle of +C R_k is stored in the strict lower triangle of +C R_k, for k = 1:l+1; +C - the diagonal elements of R_k, k = 1:l+1, are +C stored in the array SDIAG; +C - the transpose of the last block column in R +C (without R_l+1) is stored in the array S. +C +C TRANS CHARACTER*1 +C Specifies the form of the system of equations, as follows: +C = 'N': R*x = b (No transpose); +C = 'T': R'*x = b (Transpose); +C = 'C': R'*x = b (Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix R. N = BN*BSN + ST >= 0. +C (See parameter description below.) +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix R, as follows: +C IPAR(1) must contain ST, the number of columns of the +C submatrices L_k and the order of R_l+1. ST >= 0. +C IPAR(2) must contain BN, the number of blocks, l, in the +C block diagonal part of R. BN >= 0. +C IPAR(3) must contain BSM, the number of rows of the blocks +C R_k, k = 1:l. BSM >= 0. +C IPAR(4) must contain BSN, the number of columns of the +C blocks R_k, k = 1:l. BSN >= 0. +C BSM is not used by this routine, but assumed equal to BSN. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 4. +C +C R (input) DOUBLE PRECISION array, dimension (LDR, NC) +C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. +C If UPLO = 'U', the leading N-by-NC part of this array must +C contain the (compressed) representation (Rc) of the upper +C triangular matrix R. The submatrix X in Rc and the strict +C lower triangular parts of the diagonal blocks R_k, +C k = 1:l+1, are not referenced. If BN <= 1 or BSN = 0, then +C the full upper triangle of R must be stored. +C If UPLO = 'L', BN > 1 and BSN > 0, the leading +C (N-ST)-by-BSN part of this array must contain the +C transposes of the strict upper triangles of R_k, k = 1:l, +C stored in the strict lower triangles of R_k, and the +C strict lower triangle of R_l+1 must contain the transpose +C of the strict upper triangle of R_l+1. The submatrix X +C in Rc is not referenced. The diagonal elements of R_k, +C and, if COND = 'E', the upper triangular parts of R_k, +C k = 1:l+1, are modified internally, but are restored +C on exit. +C If UPLO = 'L' and BN <= 1 or BSN = 0, the leading N-by-N +C strict lower triangular part of this array must contain +C the transpose of the strict upper triangular part of R. +C The diagonal elements and, if COND = 'E', the upper +C triangular elements are modified internally, but are +C restored on exit. +C +C LDR INTEGER +C The leading dimension of the array R. LDR >= MAX(1,N). +C +C SDIAG (input) DOUBLE PRECISION array, dimension (N) +C If UPLO = 'L', this array must contain the diagonal +C entries of R_k, k = 1:l+1. This array is modified +C internally, but is restored on exit. +C This parameter is not referenced if UPLO = 'U'. +C +C S (input) DOUBLE PRECISION array, dimension (LDS,N-ST) +C If UPLO = 'L', BN > 1, and BSN > 0, the leading +C ST-by-(N-ST) part of this array must contain the transpose +C of the rectangular part of the last block column in R, +C that is [ L_1' L_2' ... L_l' ] . If COND = 'E', S is +C modified internally, but is restored on exit. +C This parameter is not referenced if UPLO = 'U', or +C BN <= 1, or BSN = 0. +C +C LDS INTEGER +C The leading dimension of the array S. +C LDS >= 1, if UPLO = 'U', or BN <= 1, or BSN = 0; +C LDS >= MAX(1,ST), if UPLO = 'L', BN > 1, and BSN > 0. +C +C B (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the right hand side +C vector b. +C On exit, this array contains the (least squares) solution +C of the system R*x = b or R'*x = b. +C +C RANKS (input or output) INTEGER array, dimension (r), where +C r = BN + 1, if ST > 0, BSN > 0, and BN > 1; +C r = BN, if ST = 0 and BSN > 0; +C r = 1, if ST > 0 and ( BSN = 0 or BN <= 1 ); +C r = 0, if ST = 0 and BSN = 0. +C On entry, if COND = 'U' and N > 0, this array must contain +C the numerical ranks of the submatrices R_k, k = 1:l(+1). +C On exit, if COND = 'E' or 'N' and N > 0, this array +C contains the numerical ranks of the submatrices R_k, +C k = 1:l(+1), estimated according to the value of COND. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If COND = 'E', the tolerance to be used for finding the +C ranks of the submatrices R_k. If the user sets TOL > 0, +C then the given value of TOL is used as a lower bound for +C the reciprocal condition number; a (sub)matrix whose +C estimated condition number is less than 1/TOL is +C considered to be of full rank. If the user sets TOL <= 0, +C then an implicitly computed, default tolerance, defined by +C TOLDEF = N*EPS, is used instead, where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C This parameter is not relevant if COND = 'U' or 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C Denote Full = ( BN <= 1 or BSN = 0 ); +C Comp = ( BN > 1 and BSN > 0 ). +C LDWORK >= 2*N, if Full and COND = 'E'; +C LDWORK >= 2*MAX(BSN,ST), if Comp and COND = 'E'; +C LDWORK >= 0, in the remaining cases. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Block back or forward substitution is used (depending on TRANS +C and UPLO), exploiting the special structure and storage scheme of +C the matrix R. If a submatrix R_k, k = 1:l+1, is singular, a local +C basic least squares solution is computed. Therefore, the returned +C result is not the basic least squares solution for the whole +C problem, but a concatenation of (least squares) solutions of the +C individual subproblems involving R_k, k = 1:l+1 (with adapted +C right hand sides). +C +C NUMERICAL ASPECTS +C 2 2 +C The algorithm requires 0(BN*BSN + ST + N*ST) operations and is +C backward stable, if R is nonsingular. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. +C +C KEYWORDS +C +C Linear system of equations, matrix operations, plane rotations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, SVLMAX + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, SVLMAX = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER COND, TRANS, UPLO + INTEGER INFO, LDR, LDS, LDWORK, LIPAR, N + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IPAR(*), RANKS(*) + DOUBLE PRECISION B(*), DWORK(*), R(LDR,*), S(LDS,*), SDIAG(*) +C .. Local Scalars .. + DOUBLE PRECISION TOLDEF + INTEGER BN, BSM, BSN, I, I1, J, K, L, NC, NTHS, RANK, ST + CHARACTER TRANSL, UPLOL + LOGICAL ECOND, FULL, LOWER, NCOND, TRANR +C .. Local Arrays .. + DOUBLE PRECISION DUM(3) +C .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DSWAP, DTRSV, MB03OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + ECOND = LSAME( COND, 'E' ) + NCOND = LSAME( COND, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + TRANR = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + INFO = 0 + IF( .NOT.( ECOND .OR. NCOND .OR. LSAME( COND, 'U' ) ) ) THEN + INFO = -1 + ELSEIF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSEIF( .NOT.( TRANR .OR. LSAME( TRANS, 'N' ) ) ) THEN + INFO = -3 + ELSEIF( N.LT.0 ) THEN + INFO = -4 + ELSEIF( LIPAR.LT.4 ) THEN + INFO = -6 + ELSE + ST = IPAR(1) + BN = IPAR(2) + BSM = IPAR(3) + BSN = IPAR(4) + NTHS = BN*BSN + FULL = BN.LE.1 .OR. BSN.EQ.0 + IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN + INFO = -5 + ELSEIF ( N.NE.NTHS + ST ) THEN + INFO = -4 + ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSEIF ( LDS.LT.1 .OR. ( LOWER .AND. .NOT.FULL .AND. + $ LDS.LT.ST ) ) THEN + INFO = -11 + ELSE + IF ( ECOND ) THEN + IF ( FULL ) THEN + L = 2*N + ELSE + L = 2*MAX( BSN, ST ) + END IF + ELSE + L = 0 + END IF + IF ( LDWORK.LT.L ) + $ INFO = -16 + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BR', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + IF ( ECOND ) THEN + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance in rank determination. +C + TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) + END IF + END IF +C + NC = BSN + ST + IF ( FULL ) THEN +C +C Special case: l <= 1 or BSN = 0; R is just an upper triangular +C matrix. +C + IF ( LOWER ) THEN +C +C Swap the diagonal elements of R and the elements of SDIAG +C and, if COND = 'E', swap the upper and lower triangular +C parts of R, in order to find the numerical rank. +C + CALL DSWAP( N, R, LDR+1, SDIAG, 1 ) + IF ( ECOND ) THEN + UPLOL = 'U' + TRANSL = TRANS +C + DO 10 J = 1, N + CALL DSWAP( N-J+1, R(J,J), LDR, R(J,J), 1 ) + 10 CONTINUE +C + ELSE + UPLOL = UPLO + IF ( TRANR ) THEN + TRANSL = 'N' + ELSE + TRANSL = 'T' + END IF + END IF + ELSE + UPLOL = UPLO + TRANSL = TRANS + END IF +C + IF ( ECOND ) THEN +C +C Estimate the reciprocal condition number and set the rank. +C Workspace: 2*N. +C + CALL MB03OD( 'No QR', N, N, R, LDR, IPAR, TOLDEF, SVLMAX, + $ DWORK, RANK, DUM, DWORK, LDWORK, INFO ) + RANKS(1) = RANK +C + ELSEIF ( NCOND ) THEN +C +C Determine rank(R) by checking zero diagonal entries. +C + RANK = N +C + DO 20 J = 1, N + IF ( R(J,J).EQ.ZERO .AND. RANK.EQ.N ) + $ RANK = J - 1 + 20 CONTINUE +C + RANKS(1) = RANK +C + ELSE +C +C Use the stored rank. +C + RANK = RANKS(1) + END IF +C +C Solve R*x = b, or R'*x = b using back or forward substitution. +C + DUM(1) = ZERO + IF ( RANK.LT.N ) + $ CALL DCOPY( N-RANK, DUM, 0, B(RANK+1), 1 ) + CALL DTRSV( UPLOL, TRANSL, 'NonUnit', RANK, R, LDR, B, 1 ) +C + IF ( LOWER ) THEN +C +C Swap the diagonal elements of R and the elements of SDIAG +C and, if COND = 'E', swap back the upper and lower triangular +C parts of R. +C + CALL DSWAP( N, R, LDR+1, SDIAG, 1 ) + IF ( ECOND ) THEN +C + DO 30 J = 1, N + CALL DSWAP( N-J+1, R(J,J), LDR, R(J,J), 1 ) + 30 CONTINUE +C + END IF +C + END IF + RETURN + END IF +C +C General case: l > 1 and BSN > 0. +C + I = 1 + L = BN + IF ( ECOND ) THEN +C +C Estimate the reciprocal condition numbers and set the ranks. +C + IF ( LOWER ) THEN +C +C Swap the diagonal elements of R and the elements of SDIAG +C and swap the upper and lower triangular parts of R, in order +C to find the numerical rank. Swap S and the transpose of the +C rectangular part of the last block column of R. +C + DO 50 K = 1, BN + CALL DSWAP( BSN, R(I,1), LDR+1, SDIAG(I), 1 ) +C + DO 40 J = 1, BSN + CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + 40 CONTINUE +C + 50 CONTINUE +C + IF ( ST.GT.0 ) THEN + CALL DSWAP( ST, R(I,BSN+1), LDR+1, SDIAG(I), 1 ) +C + DO 60 J = BSN + 1, NC + CALL DSWAP( NTHS, R(1,J), 1, S(J-BSN,1), LDS ) + CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + 60 CONTINUE +C + END IF +C + END IF +C + I1 = 1 +C +C Determine rank(R_k) using incremental condition estimation. +C Workspace 2*MAX(BSN,ST). +C + DO 70 K = 1, BN + CALL MB03OD( 'No QR', BSN, BSN, R(I1,1), LDR, IPAR, TOLDEF, + $ SVLMAX, DWORK, RANKS(K), DUM, DWORK, LDWORK, + $ INFO ) + I1 = I1 + BSN + 70 CONTINUE +C + IF ( ST.GT.0 ) THEN + L = L + 1 + CALL MB03OD( 'No QR', ST, ST, R(I1,BSN+1), LDR, IPAR, + $ TOLDEF, SVLMAX, DWORK, RANKS(L), DUM, DWORK, + $ LDWORK, INFO ) + END IF +C + ELSEIF ( NCOND ) THEN +C +C Determine rank(R_k) by checking zero diagonal entries. +C + IF ( LOWER ) THEN +C + DO 90 K = 1, BN + RANK = BSN +C + DO 80 J = 1, BSN + IF ( SDIAG(I).EQ.ZERO .AND. RANK.EQ.BSN ) + $ RANK = J - 1 + I = I + 1 + 80 CONTINUE +C + RANKS(K) = RANK + 90 CONTINUE +C + IF ( ST.GT.0 ) THEN + L = L + 1 + RANK = ST +C + DO 100 J = 1, ST + IF ( SDIAG(I).EQ.ZERO .AND. RANK.EQ.ST ) + $ RANK = J - 1 + I = I + 1 + 100 CONTINUE +C + RANKS(L) = RANK + END IF +C + ELSE +C + DO 120 K = 1, BN + RANK = BSN +C + DO 110 J = 1, BSN + IF ( R(I,J).EQ.ZERO .AND. RANK.EQ.BSN ) + $ RANK = J - 1 + I = I + 1 + 110 CONTINUE +C + RANKS(K) = RANK + 120 CONTINUE +C + IF ( ST.GT.0 ) THEN + L = L + 1 + RANK = ST +C + DO 130 J = BSN + 1, NC + IF ( R(I,J).EQ.ZERO .AND. RANK.EQ.ST ) + $ RANK = J - BSN - 1 + I = I + 1 + 130 CONTINUE +C + RANKS(L) = RANK + END IF + END IF +C + ELSE +C +C Set the number of elements of RANKS. Then use the stored ranks. +C + IF ( ST.GT.0 ) + $ L = L + 1 + END IF +C +C Solve the triangular system for x. If the system is singular, +C then obtain a basic least squares solution. +C + DUM(1) = ZERO + IF ( LOWER .AND. .NOT.ECOND ) THEN +C + IF ( .NOT.TRANR ) THEN +C +C Solve R*x = b using back substitution, with R' stored in +C the arrays R, SDIAG and S. Swap diag(R) and SDIAG. +C + I1 = NTHS + 1 + IF ( ST.GT.0 ) THEN + RANK = RANKS(L) + IF ( RANK.LT.ST ) + $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) + CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) + CALL DTRSV( 'Lower', 'Transpose', 'NonUnit', RANK, + $ R(I1,BSN+1), LDR, B(I1), 1 ) + CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) + CALL DGEMV( 'Transpose', ST, NTHS, -ONE, S, LDS, + $ B(NTHS+1), 1, ONE, B, 1 ) + END IF +C + DO 140 K = BN, 1, -1 + I1 = I1 - BSN + RANK = RANKS(K) + IF ( RANK.LT.BSN ) + $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) + CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) + CALL DTRSV( 'Lower', 'Transpose', 'NonUnit', RANK, + $ R(I1,1), LDR, B(I1), 1 ) + CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) + 140 CONTINUE +C + ELSE +C +C Solve R'*x = b using forward substitution, with R' stored in +C the arrays R, SDIAG and S. Swap diag(R) and SDIAG. +C + I1 = 1 + IF ( TRANR ) THEN + TRANSL = 'N' + ELSE + TRANSL = 'T' + END IF +C + DO 150 K = 1, BN + RANK = RANKS(K) + IF ( RANK.LT.BSN ) + $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) + CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) + CALL DTRSV( 'Lower', TRANSL, 'NonUnit', RANK, R(I1,1), + $ LDR, B(I1), 1 ) + CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) + I1 = I1 + BSN + 150 CONTINUE +C + IF ( ST.GT.0 ) THEN + RANK = RANKS(L) + IF ( RANK.LT.ST ) + $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) + CALL DGEMV( 'NoTranspose', ST, NTHS, -ONE, S, LDS, B, 1, + $ ONE, B(I1), 1 ) + CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) + CALL DTRSV( 'Lower', TRANSL, 'NonUnit', RANK, + $ R(I1,BSN+1), LDR, B(I1), 1 ) + CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) + END IF +C + END IF +C + ELSE +C + IF ( .NOT.TRANR ) THEN +C +C Solve R*x = b using back substitution. +C + I1 = NTHS + 1 + IF ( ST.GT.0 ) THEN + RANK = RANKS(L) + IF ( RANK.LT.ST ) + $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) + CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,BSN+1), + $ LDR, B(I1), 1 ) + CALL DGEMV( TRANS, NTHS, ST, -ONE, R(1,BSN+1), LDR, + $ B(NTHS+1), 1, ONE, B, 1 ) + END IF +C + DO 160 K = BN, 1, -1 + I1 = I1 - BSN + RANK = RANKS(K) + IF ( RANK.LT.BSN ) + $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) + CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,1), + $ LDR, B(I1), 1 ) + 160 CONTINUE +C + ELSE +C +C Solve R'*x = b using forward substitution. +C + I1 = 1 +C + DO 170 K = 1, BN + RANK = RANKS(K) + IF ( RANK.LT.BSN ) + $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) + CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,1), + $ LDR, B(I1), 1 ) + I1 = I1 + BSN + 170 CONTINUE +C + IF ( ST.GT.0 ) THEN + RANK = RANKS(L) + IF ( RANK.LT.ST ) + $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) + CALL DGEMV( TRANS, NTHS, ST, -ONE, R(1,BSN+1), LDR, B, 1, + $ ONE, B(I1), 1 ) + CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,BSN+1), + $ LDR, B(I1), 1 ) + END IF +C + END IF + END IF +C + IF ( ECOND .AND. LOWER ) THEN + I = 1 +C +C If COND = 'E' and UPLO = 'L', swap the diagonal elements of R +C and the elements of SDIAG and swap back the upper and lower +C triangular parts of R, including the part corresponding to S. +C + DO 190 K = 1, BN + CALL DSWAP( BSN, R(I,1), LDR+1, SDIAG(I), 1 ) +C + DO 180 J = 1, BSN + CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + 180 CONTINUE +C + 190 CONTINUE +C + IF ( ST.GT.0 ) THEN + CALL DSWAP( ST, R(I,BSN+1), LDR+1, SDIAG(I), 1 ) +C + DO 200 J = BSN + 1, NC + CALL DSWAP( NTHS, R(1,J), 1, S(J-BSN,1), LDS ) + CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + 200 CONTINUE +C + END IF +C + END IF +C + RETURN +C +C *** Last line of NF01BR *** + END diff --git a/mex/sources/libslicot/NF01BS.f b/mex/sources/libslicot/NF01BS.f new file mode 100644 index 000000000..3d7d6e5c9 --- /dev/null +++ b/mex/sources/libslicot/NF01BS.f @@ -0,0 +1,610 @@ + SUBROUTINE NF01BS( N, IPAR, LIPAR, FNORM, J, LDJ, E, JNORMS, + $ GNORM, IPVT, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the QR factorization of the Jacobian matrix J, as +C received in compressed form from SLICOT Library routine NF01BD, +C +C / dy(1)/dwb(1) | dy(1)/ dtheta \ +C Jc = | : | : | , +C \ dy(L)/dwb(L) | dy(L)/ dtheta / +C +C and to apply the transformation Q on the error vector e (in-situ). +C The factorization is J*P = Q*R, where Q is a matrix with +C orthogonal columns, P a permutation matrix, and R an upper +C trapezoidal matrix with diagonal elements of nonincreasing +C magnitude for each block column (see below). The 1-norm of the +C scaled gradient is also returned. +C +C Actually, the Jacobian J has the block form +C +C dy(1)/dwb(1) 0 ..... 0 dy(1)/dtheta +C 0 dy(2)/dwb(2) ..... 0 dy(2)/dtheta +C ..... ..... ..... ..... ..... +C 0 ..... 0 dy(L)/dwb(L) dy(L)/dtheta +C +C but the zero blocks are omitted. The diagonal blocks have the +C same size and correspond to the nonlinear part. The last block +C column corresponds to the linear part. It is assumed that the +C Jacobian matrix has at least as many rows as columns. The linear +C or nonlinear parts can be empty. If L <= 1, the Jacobian is +C represented as a full matrix. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of columns of the Jacobian matrix J. +C N = BN*BSN + ST >= 0. (See parameter description below.) +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix J, as follows: +C IPAR(1) must contain ST, the number of parameters +C corresponding to the linear part. ST >= 0. +C IPAR(2) must contain BN, the number of blocks, BN = L, +C for the parameters corresponding to the nonlinear +C part. BN >= 0. +C IPAR(3) must contain BSM, the number of rows of the blocks +C J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the +C number of rows of the matrix J, if BN <= 1. +C BN*BSM >= N, if BN > 0; +C BSM >= N, if BN = 0. +C IPAR(4) must contain BSN, the number of columns of the +C blocks J_k, k = 1:BN. BSN >= 0. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 4. +C +C FNORM (input) DOUBLE PRECISION +C The Euclidean norm of the vector e. FNORM >= 0. +C +C J (input/output) DOUBLE PRECISION array, dimension (LDJ, NC) +C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. +C On entry, the leading NR-by-NC part of this array must +C contain the (compressed) representation (Jc) of the +C Jacobian matrix J, where NR = BSM if BN <= 1, and +C NR = BN*BSM, if BN > 1. +C On exit, the leading N-by-NC part of this array contains +C a (compressed) representation of the upper triangular +C factor R of the Jacobian matrix. The matrix R has the same +C structure as the Jacobian matrix J, but with an additional +C diagonal block. Note that for efficiency of the later +C calculations, the matrix R is delivered with the leading +C dimension MAX(1,N), possibly much smaller than the value +C of LDJ on entry. +C +C LDJ (input/output) INTEGER +C The leading dimension of array J. +C On entry, LDJ >= MAX(1,NR). +C On exit, LDJ >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (NR) +C On entry, this array contains the vector e, +C e = vec( Y - y ), where Y is set of output samples, and +C vec denotes the concatenation of the columns of a matrix. +C On exit, this array contains the updated vector Z*Q'*e, +C where Z is the block row permutation matrix used in the +C QR factorization of J (see METHOD). +C +C JNORMS (output) DOUBLE PRECISION array, dimension (N) +C This array contains the Euclidean norms of the columns +C of the Jacobian matrix, considered in the initial order. +C +C GNORM (output) DOUBLE PRECISION +C If FNORM > 0, the 1-norm of the scaled vector J'*e/FNORM, +C with each element i further divided by JNORMS(i) (if +C JNORMS(i) is nonzero). +C If FNORM = 0, the returned value of GNORM is 0. +C +C IPVT (output) INTEGER array, dimension (N) +C This array defines the permutation matrix P such that +C J*P = Q*R. Column j of P is column IPVT(j) of the identity +C matrix. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 1, if N = 0 or BN <= 1 and BSM = N = 1; +C otherwise, +C LDWORK >= 4*N+1, if BN <= 1 or BSN = 0; +C LDWORK >= JWORK, if BN > 1 and BSN > 0, where JWORK is +C given by the following procedure: +C JWORK = BSN + MAX(3*BSN+1,ST); +C JWORK = MAX(JWORK,4*ST+1), if BSM > BSN; +C JWORK = MAX(JWORK,(BSM-BSN)*(BN-1)), +C if BSN < BSM < 2*BSN. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C A QR factorization with column pivoting of the matrix J is +C computed, J*P = Q*R. +C +C If l = L > 1, the R factor of the QR factorization has the same +C structure as the Jacobian, but with an additional diagonal block. +C Denote +C +C / J_1 0 .. 0 | L_1 \ +C | 0 J_2 .. 0 | L_2 | +C J = | : : .. : | : | . +C | : : .. : | : | +C \ 0 0 .. J_l | L_l / +C +C The algorithm consists in two phases. In the first phase, the +C algorithm uses QR factorizations with column pivoting for each +C block J_k, k = 1:l, and applies the orthogonal matrix Q'_k to the +C corresponding part of the last block column and of e. After all +C block rows have been processed, the block rows are interchanged +C so that the zeroed submatrices in the first l block columns are +C moved to the bottom part. The same block row permutation Z is +C also applied to the vector e. At the end of the first phase, +C the structure of the processed matrix J is +C +C / R_1 0 .. 0 | L^1_1 \ +C | 0 R_2 .. 0 | L^1_2 | +C | : : .. : | : | . +C | : : .. : | : | +C | 0 0 .. R_l | L^1_l | +C | 0 0 .. 0 | L^2_1 | +C | : : .. : | : | +C \ 0 0 .. 0 | L^2_l / +C +C In the second phase, the submatrix L^2_1:l is triangularized +C using an additional QR factorization with pivoting. (The columns +C of L^1_1:l are also permuted accordingly.) Therefore, the column +C pivoting is restricted to each such local block column. +C +C If l <= 1, the matrix J is triangularized in one phase, by one +C QR factorization with pivoting. In this case, the column +C pivoting is global. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C Feb. 22, 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Jacobian matrix, matrix algebra, +C matrix operations, Wiener system. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDJ, LDWORK, LIPAR, N + DOUBLE PRECISION FNORM, GNORM +C .. Array Arguments .. + INTEGER IPAR(*), IPVT(*) + DOUBLE PRECISION DWORK(*), E(*), J(*), JNORMS(*) +C .. Local Scalars .. + INTEGER BN, BSM, BSN, I, IBSM, IBSN, IBSNI, ITAU, JL, + $ JLM, JWORK, K, L, M, MMN, NTHS, ST, WRKOPT + DOUBLE PRECISION SUM +C .. External Functions .. + DOUBLE PRECISION DDOT, DNRM2 + EXTERNAL DDOT, DNRM2 +C .. External Subroutines .. + EXTERNAL DCOPY, DGEQP3, DLACPY, DLAPMT, DORMQR, DSWAP, + $ MD03BX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX, MIN +C .. +C .. Executable Statements .. +C + INFO = 0 + IF ( N.LT.0 ) THEN + INFO = -1 + ELSEIF( LIPAR.LT.4 ) THEN + INFO = -3 + ELSEIF ( FNORM.LT.ZERO ) THEN + INFO = -4 + ELSEIF ( LDJ.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE + ST = IPAR(1) + BN = IPAR(2) + BSM = IPAR(3) + BSN = IPAR(4) + NTHS = BN*BSN + MMN = BSM - BSN + IF ( BN.GT.0 ) THEN + M = BN*BSM + ELSE + M = N + END IF + IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN + INFO = -2 + ELSEIF ( N.NE.NTHS + ST ) THEN + INFO = -1 + ELSEIF ( M.LT.N ) THEN + INFO = -2 + ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE + IF ( N.EQ.0 ) THEN + JWORK = 1 + ELSEIF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN + IF ( BN.LE.1 .AND. BSM.EQ.1 .AND. N.EQ.1 ) THEN + JWORK = 1 + ELSE + JWORK = 4*N + 1 + END IF + ELSE + JWORK = BSN + MAX( 3*BSN + 1, ST ) + IF ( BSM.GT.BSN ) THEN + JWORK = MAX( JWORK, 4*ST + 1 ) + IF ( BSM.LT.2*BSN ) + $ JWORK = MAX( JWORK, MMN*( BN - 1 ) ) + END IF + END IF + IF ( LDWORK.LT.JWORK ) + $ INFO = -12 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'NF01BS', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + GNORM = ZERO + IF ( N.EQ.0 ) THEN + LDJ = 1 + DWORK(1) = ONE + RETURN + END IF +C + IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN +C +C Special case, l <= 1 or BSN = 0: the Jacobian is represented +C as a full matrix. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C +C Workspace: need: 4*N + 1; +C prefer: 3*N + ( N+1 )*NB. +C + CALL MD03BX( M, N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT, + $ DWORK, LDWORK, INFO ) + RETURN + END IF +C +C General case: l > 1 and BSN > 0. +C Initialize the column pivoting indices. +C + DO 10 I = 1, N + IPVT(I) = 0 + 10 CONTINUE +C +C Compute the QR factorization with pivoting of J. +C Pivoting is done separately on each block column of J. +C + WRKOPT = 1 + IBSN = 1 + JL = LDJ*BSN + 1 + JWORK = BSN + 1 +C + DO 30 IBSM = 1, M, BSM +C +C Compute the QR factorization with pivoting of J_k, and apply Q' +C to the corresponding part of the last block-column and of e. +C Workspace: need: 4*BSN + 1; +C prefer: 3*BSN + ( BSN+1 )*NB. +C + CALL DGEQP3( BSM, BSN, J(IBSM), LDJ, IPVT(IBSN), DWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF ( IBSM.GT.1 ) THEN +C +C Adjust the column pivoting indices. +C + DO 20 I = IBSN, IBSN + BSN - 1 + IPVT(I) = IPVT(I) + IBSN - 1 + 20 CONTINUE +C + END IF +C + IF ( ST.GT.0 ) THEN +C +C Workspace: need: BSN + ST; +C prefer: BSN + ST*NB. +C + CALL DORMQR( 'Left', 'Transpose', BSM, ST, BSN, J(IBSM), + $ LDJ, DWORK, J(JL), LDJ, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + END IF +C +C Workspace: need: BSN + 1; +C prefer: BSN + NB. +C + CALL DORMQR( 'Left', 'Transpose', BSM, 1, BSN, J(IBSM), LDJ, + $ DWORK, E(IBSM), BSM, DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) + JL = JL + BSM + IBSN = IBSN + BSN + 30 CONTINUE +C + IF ( MMN.GT.0 ) THEN +C +C Case BSM > BSN. +C Compute the original column norms for the first block column +C of Jc. +C Permute the rows of the first block column to move the zeroed +C submatrices to the bottom. In the same loops, reshape the +C first block column of R to have the leading dimension N. +C + L = IPVT(1) + JNORMS(L) = ABS( J(1) ) + IBSM = BSM + 1 + IBSN = BSN + 1 +C + DO 40 K = 1, BN - 1 + J(IBSN) = J(IBSM) + L = IPVT(IBSN) + JNORMS(L) = ABS( J(IBSN) ) + IBSM = IBSM + BSM + IBSN = IBSN + BSN + 40 CONTINUE +C + IBSN = IBSN + ST +C + DO 60 I = 2, BSN + IBSM = ( I - 1 )*LDJ + 1 + JL = I +C + DO 50 K = 1, BN +C + DO 45 L = 0, I - 1 + J(IBSN+L) = J(IBSM+L) + 45 CONTINUE +C + L = IPVT(JL) + JNORMS(L) = DNRM2( I, J(IBSN), 1 ) + IBSM = IBSM + BSM + IBSN = IBSN + BSN + JL = JL + BSN + 50 CONTINUE +C + IBSN = IBSN + ST + 60 CONTINUE +C +C Permute the rows of the second block column of Jc and of +C the vector e. +C + JL = LDJ*BSN + IF ( BSM.GE.2*BSN ) THEN +C +C A swap operation can be used. +C + DO 80 I = 1, ST + IBSN = BSN + 1 +C + DO 70 IBSM = BSM + 1, M, BSM + CALL DSWAP( MMN, J(JL+IBSM), 1, J(JL+IBSN), 1 ) + IBSN = IBSN + BSN + 70 CONTINUE +C + JL = JL + LDJ + 80 CONTINUE +C +C Permute the rows of e. +C + IBSN = BSN + 1 +C + DO 90 IBSM = BSM + 1, M, BSM + CALL DSWAP( MMN, E(IBSM), 1, E(IBSN), 1 ) + IBSN = IBSN + BSN + 90 CONTINUE +C + ELSE +C +C A swap operation cannot be used. +C Workspace: need: ( BSM-BSN )*( BN-1 ). +C + DO 110 I = 1, ST + IBSN = BSN + 1 + JLM = JL + IBSN + JWORK = 1 +C + DO 100 IBSM = BSM + 1, M, BSM + CALL DCOPY( MMN, J(JLM), 1, DWORK(JWORK), 1 ) +C + DO 105 K = JL, JL + BSN - 1 + J(IBSN+K) = J(IBSM+K) + 105 CONTINUE +C + JLM = JLM + BSM + IBSN = IBSN + BSN + JWORK = JWORK + MMN + 100 CONTINUE +C + CALL DCOPY( MMN*( BN-1 ), DWORK, 1, J(JL+IBSN), 1 ) + JL = JL + LDJ + 110 CONTINUE +C +C Permute the rows of e. +C + IBSN = BSN + 1 + JLM = IBSN + JWORK = 1 +C + DO 120 IBSM = BSM + 1, M, BSM + CALL DCOPY( MMN, E(JLM), 1, DWORK(JWORK), 1 ) +C + DO 115 K = 0, BSN - 1 + E(IBSN+K) = E(IBSM+K) + 115 CONTINUE +C + JLM = JLM + BSM + IBSN = IBSN + BSN + JWORK = JWORK + MMN + 120 CONTINUE +C + CALL DCOPY( MMN*( BN-1 ), DWORK, 1, E(IBSN), 1 ) + END IF +C + IF ( ST.GT.0 ) THEN +C +C Compute the QR factorization with pivoting of the submatrix +C L^2_1:l, and apply Q' to the corresponding part of e. +C +C Workspace: need: 4*ST + 1; +C prefer: 3*ST + ( ST+1 )*NB. +C + JL = ( LDJ + BN )*BSN + 1 + ITAU = 1 + JWORK = ITAU + ST + CALL DGEQP3( MMN*BN, ST, J(JL), LDJ, IPVT(NTHS+1), + $ DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Permute columns of the upper part of the second block +C column of Jc. +C + CALL DLAPMT( .TRUE., NTHS, ST, J(JL-NTHS), LDJ, + $ IPVT(NTHS+1) ) +C +C Adjust the column pivoting indices. +C + DO 130 I = NTHS + 1, N + IPVT(I) = IPVT(I) + NTHS + 130 CONTINUE +C +C Workspace: need: ST + 1; +C prefer: ST + NB. +C + CALL DORMQR( 'Left', 'Transpose', MMN*BN, 1, ST, J(JL), LDJ, + $ DWORK(ITAU), E(IBSN), LDJ, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Reshape the second block column of R to have the leading +C dimension N. +C + IBSN = N*BSN + 1 + CALL DLACPY( 'Full', N, ST, J(LDJ*BSN+1), LDJ, J(IBSN), N ) +C +C Compute the original column norms for the second block +C column. +C + DO 140 I = NTHS + 1, N + L = IPVT(I) + JNORMS(L) = DNRM2( I, J(IBSN), 1 ) + IBSN = IBSN + N + 140 CONTINUE +C + END IF +C + ELSE +C +C Case BSM = BSN. +C Compute the original column norms for the first block column +C of Jc. +C + IBSN = 1 +C + DO 160 I = 1, BSN + JL = I +C + DO 150 K = 1, BN + L = IPVT(JL) + JNORMS(L) = DNRM2( I, J(IBSN), 1 ) + IBSN = IBSN + BSN + JL = JL + BSN + 150 CONTINUE +C + IBSN = IBSN + ST + 160 CONTINUE +C + DO 170 I = NTHS + 1, N + IPVT(I) = I + 170 CONTINUE +C + END IF +C +C Compute the norm of the scaled gradient. +C + IF ( FNORM.NE.ZERO ) THEN +C + DO 190 IBSN = 1, NTHS, BSN + IBSNI = IBSN +C + DO 180 I = 1, BSN + L = IPVT(IBSN+I-1) + IF ( JNORMS(L).NE.ZERO ) THEN + SUM = DDOT( I, J(IBSNI), 1, E(IBSN), 1 )/FNORM + GNORM = MAX( GNORM, ABS( SUM/JNORMS(L) ) ) + END IF + IBSNI = IBSNI + N + 180 CONTINUE +C + 190 CONTINUE +C + IBSNI = N*BSN + 1 +C + DO 200 I = NTHS + 1, N + L = IPVT(I) + IF ( JNORMS(L).NE.ZERO ) THEN + SUM = DDOT( I, J(IBSNI), 1, E, 1 )/FNORM + GNORM = MAX( GNORM, ABS( SUM/JNORMS(L) ) ) + END IF + IBSNI = IBSNI + N + 200 CONTINUE +C + END IF +C + LDJ = N + DWORK(1) = WRKOPT + RETURN +C +C *** Last line of NF01BS *** + END diff --git a/mex/sources/libslicot/NF01BU.f b/mex/sources/libslicot/NF01BU.f new file mode 100644 index 000000000..502959cdd --- /dev/null +++ b/mex/sources/libslicot/NF01BU.f @@ -0,0 +1,398 @@ + SUBROUTINE NF01BU( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, J, + $ LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix J'*J + c*I, for the Jacobian J as received +C from SLICOT Library routine NF01BD: +C +C / dy(1)/dwb(1) | dy(1)/dtheta \ +C Jc = | : | : | . +C \ dy(L)/dwb(L) | dy(L)/dtheta / +C +C This is a compressed representation of the actual structure +C +C / J_1 0 .. 0 | L_1 \ +C | 0 J_2 .. 0 | L_2 | +C J = | : : .. : | : | . +C | : : .. : | : | +C \ 0 0 .. J_L | L_L / +C +C ARGUMENTS +C +C Mode Parameters +C +C STOR CHARACTER*1 +C Specifies the storage scheme for the symmetric +C matrix J'*J + c*I, as follows: +C = 'F' : full storage is used; +C = 'P' : packed storage is used. +C +C UPLO CHARACTER*1 +C Specifies which part of the matrix J'*J + c*I is stored, +C as follows: +C = 'U' : the upper triagular part is stored; +C = 'L' : the lower triagular part is stored. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix J'*J + c*I. +C N = BN*BSN + ST >= 0. (See parameter description below.) +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix J, as follows: +C IPAR(1) must contain ST, the number of parameters +C corresponding to the linear part. ST >= 0. +C IPAR(2) must contain BN, the number of blocks, BN = L, +C for the parameters corresponding to the nonlinear +C part. BN >= 0. +C IPAR(3) must contain BSM, the number of rows of the blocks +C J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the +C number of rows of the matrix J, if BN <= 1. +C IPAR(4) must contain BSN, the number of columns of the +C blocks J_k, k = 1:BN. BSN >= 0. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 4. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C The real parameters needed for solving the problem. +C The entry DPAR(1) must contain the real scalar c. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 1. +C +C J (input) DOUBLE PRECISION array, dimension (LDJ, NC) +C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. +C The leading NR-by-NC part of this array must contain +C the (compressed) representation (Jc) of the Jacobian +C matrix J, where NR = BSM if BN <= 1, and NR = BN*BSM, +C if BN > 1. +C +C LDJ (input) INTEGER +C The leading dimension of array J. LDJ >= MAX(1,NR). +C +C JTJ (output) DOUBLE PRECISION array, +C dimension (LDJTJ,N), if STOR = 'F', +C dimension (N*(N+1)/2), if STOR = 'P'. +C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if +C STOR = 'P') part of this array contains the upper or +C lower triangle of the matrix J'*J + c*I, depending on +C UPLO = 'U', or UPLO = 'L', respectively, stored either as +C a two-dimensional, or one-dimensional array, depending +C on STOR. +C +C LDJTJ INTEGER +C The leading dimension of the array JTJ. +C LDJTJ >= MAX(1,N), if STOR = 'F'. +C LDJTJ >= 1, if STOR = 'P'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C Currently, this array is not used. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 0. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix product is computed columnn-wise, exploiting the +C symmetry. BLAS 3 routines DGEMM and DSYRK are used if STOR = 'F', +C and BLAS 2 routine DGEMV is used if STOR = 'P'. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001. +C +C REVISIONS +C +C V. Sima, Dec. 2001, Mar. 2002. +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations, +C Wiener system. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER STOR, UPLO + INTEGER INFO, LDJ, LDJTJ, LDPAR, LDWORK, LIPAR, N +C .. Array Arguments .. + DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), JTJ(*) + INTEGER IPAR(*) +C .. Local Scalars .. + LOGICAL FULL, UPPER + INTEGER BN, BSM, BSN, I1, IBSM, IBSN, II, JL, K, M, + $ NBSN, NTHS, ST + DOUBLE PRECISION C +C .. Local Arrays .. + DOUBLE PRECISION TMP(1) + INTEGER ITMP(1) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, DSYRK, NF01BV, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C + INFO = 0 +C + FULL = LSAME( STOR, 'F' ) + UPPER = LSAME( UPLO, 'U' ) +C + IF( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN + INFO = -1 + ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -2 + ELSEIF ( N.LT.0 ) THEN + INFO = -3 + ELSEIF ( LIPAR.LT.4 ) THEN + INFO = -5 + ELSEIF ( LDPAR.LT.1 ) THEN + INFO = -7 + ELSEIF ( LDJTJ.LT.1 .OR. ( FULL .AND. LDJTJ.LT.N ) ) THEN + INFO = -11 + ELSEIF ( LDWORK.LT.0 ) THEN + INFO = -13 + ELSE + ST = IPAR(1) + BN = IPAR(2) + BSM = IPAR(3) + BSN = IPAR(4) + NTHS = BN*BSN + IF ( BN.GT.1 ) THEN + M = BN*BSM + ELSE + M = BSM + END IF + IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN + INFO = -4 + ELSEIF ( N.NE.NTHS + ST ) THEN + INFO = -3 + ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN + INFO = -9 + END IF + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BU', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + C = DPAR(1) +C + IF ( BN.LE.1 .OR. BSN.EQ.0 .OR. BSM.EQ.0 ) THEN +C +C Special case, l <= 1 or BSN = 0 or BSM = 0: the Jacobian is +C represented as a full matrix. +C + ITMP(1) = M + CALL NF01BV( STOR, UPLO, N, ITMP, 1, DPAR, 1, J, LDJ, JTJ, + $ LDJTJ, DWORK, LDWORK, INFO ) + RETURN + END IF +C +C General case: l > 1, BSN > 0, BSM > 0. +C + JL = BSN + 1 +C + IF ( FULL ) THEN +C + NBSN = N*BSN +C + IF ( UPPER ) THEN +C +C Compute the leading upper triangular part (full storage). +C + CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ, LDJTJ ) + CALL DSYRK( UPLO, 'Transpose', BSN, BSM, ONE, J, LDJ, ONE, + $ JTJ, LDJTJ ) + IBSN = BSN + I1 = NBSN + 1 +C + DO 10 IBSM = BSM + 1, M, BSM + II = I1 + IBSN + CALL DLASET( 'Full', IBSN, BSN, ZERO, ZERO, JTJ(I1), + $ LDJTJ ) + I1 = I1 + NBSN + CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ(II), LDJTJ ) + CALL DSYRK( UPLO, 'Transpose', BSN, BSM, ONE, J(IBSM,1), + $ LDJ, ONE, JTJ(II), LDJTJ ) + IBSN = IBSN + BSN + 10 CONTINUE +C + IF ( ST.GT.0 ) THEN +C +C Compute the last block column. +C + DO 20 IBSM = 1, M, BSM + CALL DGEMM( 'Transpose', 'NoTranspose', BSN, ST, BSM, + $ ONE, J(IBSM,1), LDJ, J(IBSM,JL), LDJ, + $ ZERO, JTJ(I1), LDJTJ ) + I1 = I1 + BSN + 20 CONTINUE +C + CALL DLASET( UPLO, ST, ST, ZERO, C, JTJ(I1), LDJTJ ) + CALL DSYRK( UPLO, 'Transpose', ST, M, ONE, J(1,JL), + $ LDJ, ONE, JTJ(I1), LDJTJ ) + END IF +C + ELSE +C +C Compute the leading lower triangular part (full storage). +C + IBSN = NTHS + II = 1 +C + DO 30 IBSM = 1, M, BSM + I1 = II + BSN + CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ(II), LDJTJ ) + CALL DSYRK( UPLO, 'Transpose', BSN, BSM, ONE, J(IBSM,1), + $ LDJ, ONE, JTJ(II), LDJTJ ) + IBSN = IBSN - BSN + CALL DLASET( 'Full', IBSN, BSN, ZERO, ZERO, JTJ(I1), + $ LDJTJ ) + II = I1 + NBSN + IF ( ST.GT.0 ) + $ CALL DGEMM( 'Transpose', 'NoTranspose', ST, BSN, BSM, + $ ONE, J(IBSM,JL), LDJ, J(IBSM,1), LDJ, + $ ZERO, JTJ(I1+IBSN), LDJTJ ) + 30 CONTINUE +C + IF ( ST.GT.0 ) THEN +C +C Compute the last diagonal block. +C + CALL DLASET( UPLO, ST, ST, ZERO, C, JTJ(II), LDJTJ ) + CALL DSYRK( UPLO, 'Transpose', ST, M, ONE, J(1,JL), + $ LDJ, ONE, JTJ(II), LDJTJ ) + END IF +C + END IF +C + ELSE +C + TMP(1) = ZERO +C + IF ( UPPER ) THEN +C +C Compute the leading upper triangular part (packed storage). +C + IBSN = 0 + I1 = 1 +C + DO 50 IBSM = 1, M, BSM +C + DO 40 K = 1, BSN + II = I1 + IBSN + CALL DCOPY( IBSN, TMP, 0, JTJ(I1), 1 ) + CALL DGEMV( 'Transpose', BSM, K, ONE, J(IBSM,1), LDJ, + $ J(IBSM,K), 1, ZERO, JTJ(II), 1 ) + I1 = II + K + JTJ(I1-1) = JTJ(I1-1) + C + 40 CONTINUE +C + IBSN = IBSN + BSN + 50 CONTINUE +C +C Compute the last block column. +C + DO 70 K = 1, ST +C + DO 60 IBSM = 1, M, BSM + CALL DGEMV( 'Transpose', BSM, BSN, ONE, J(IBSM,1), + $ LDJ, J(IBSM,BSN+K), 1, ZERO, JTJ(I1), 1 ) + I1 = I1 + BSN + 60 CONTINUE +C + CALL DGEMV( 'Transpose', M, K, ONE, J(1,JL), LDJ, + $ J(1,BSN+K), 1, ZERO, JTJ(I1), 1 ) + I1 = I1 + K + JTJ(I1-1) = JTJ(I1-1) + C + 70 CONTINUE +C + ELSE +C +C Compute the leading lower triangular part (packed storage). +C + IBSN = NTHS + II = 1 +C + DO 90 IBSM = 1, M, BSM + IBSN = IBSN - BSN +C + DO 80 K = 1, BSN + I1 = II + BSN - K + 1 + CALL DCOPY( IBSN, TMP, 0, JTJ(I1), 1 ) + CALL DGEMV( 'Transpose', BSM, BSN-K+1, ONE, J(IBSM,K), + $ LDJ, J(IBSM,K), 1, ZERO, JTJ(II), 1 ) + JTJ(II) = JTJ(II) + C + I1 = I1 + IBSN + II = I1 + ST + IF ( ST.GT.0 ) + $ CALL DGEMV( 'Transpose', BSM, ST, ONE, J(IBSM,JL), + $ LDJ, J(IBSM,K), 1, ZERO, JTJ(I1), 1 ) + 80 CONTINUE +C + 90 CONTINUE +C +C Compute the last diagonal block. +C + DO 100 K = 1, ST + CALL DGEMV( 'Transpose', M, ST-K+1, ONE, J(1,BSN+K), LDJ, + $ J(1,BSN+K), 1, ZERO, JTJ(II), 1 ) + JTJ(II) = JTJ(II) + C + II = II + ST - K + 1 + 100 CONTINUE +C + END IF +C + END IF +C + RETURN +C +C *** Last line of NF01BU *** + END diff --git a/mex/sources/libslicot/NF01BV.f b/mex/sources/libslicot/NF01BV.f new file mode 100644 index 000000000..d596ec50a --- /dev/null +++ b/mex/sources/libslicot/NF01BV.f @@ -0,0 +1,249 @@ + SUBROUTINE NF01BV( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, J, + $ LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix J'*J + c*I, for the Jacobian J as received +C from SLICOT Library routine NF01BY, for one output variable. +C +C NOTE: this routine must have the same arguments as SLICOT Library +C routine NF01BU. +C +C ARGUMENTS +C +C Mode Parameters +C +C STOR CHARACTER*1 +C Specifies the storage scheme for the symmetric +C matrix J'*J + c*I, as follows: +C = 'F' : full storage is used; +C = 'P' : packed storage is used. +C +C UPLO CHARACTER*1 +C Specifies which part of the matrix J'*J + c*I is stored, +C as follows: +C = 'U' : the upper triagular part is stored; +C = 'L' : the lower triagular part is stored. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of columns of the Jacobian matrix J. N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix J, as follows: +C IPAR(1) must contain the number of rows M of the Jacobian +C matrix J. M >= 0. +C IPAR is provided for compatibility with SLICOT Library +C routine MD03AD. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 1. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C The real parameters needed for solving the problem. +C The entry DPAR(1) must contain the real scalar c. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 1. +C +C J (input) DOUBLE PRECISION array, dimension (LDJ,N) +C The leading M-by-N part of this array must contain the +C Jacobian matrix J. +C +C LDJ INTEGER +C The leading dimension of the array J. LDJ >= MAX(1,M). +C +C JTJ (output) DOUBLE PRECISION array, +C dimension (LDJTJ,N), if STOR = 'F', +C dimension (N*(N+1)/2), if STOR = 'P'. +C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if +C STOR = 'P') part of this array contains the upper or +C lower triangle of the matrix J'*J + c*I, depending on +C UPLO = 'U', or UPLO = 'L', respectively, stored either as +C a two-dimensional, or one-dimensional array, depending +C on STOR. +C +C LDJTJ INTEGER +C The leading dimension of the array JTJ. +C LDJTJ >= MAX(1,N), if STOR = 'F'. +C LDJTJ >= 1, if STOR = 'P'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C Currently, this array is not used. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 0. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix product is computed columnn-wise, exploiting the +C symmetry. BLAS 3 routine DSYRK is used if STOR = 'F', and BLAS 2 +C routine DGEMV is used if STOR = 'P'. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001. +C +C REVISIONS +C +C V. Sima, March 2002. +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations, +C Wiener system. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER STOR, UPLO + INTEGER INFO, LDJ, LDJTJ, LDPAR, LDWORK, LIPAR, N +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), JTJ(*) +C .. Local Scalars .. + LOGICAL FULL, UPPER + INTEGER I, II, M + DOUBLE PRECISION C +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DLASET, DSYRK, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C + INFO = 0 + FULL = LSAME( STOR, 'F' ) + UPPER = LSAME( UPLO, 'U' ) +C + IF( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN + INFO = -1 + ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -2 + ELSEIF ( N.LT.0 ) THEN + INFO = -3 + ELSEIF ( LIPAR.LT.1 ) THEN + INFO = -5 + ELSEIF ( LDPAR.LT.1 ) THEN + INFO = -7 + ELSEIF ( LDJTJ.LT.1 .OR. ( FULL .AND. LDJTJ.LT.N ) ) THEN + INFO = -11 + ELSEIF ( LDWORK.LT.0 ) THEN + INFO = -13 + ELSE + M = IPAR(1) + IF ( M.LT.0 ) THEN + INFO = -4 + ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN + INFO = -9 + ENDIF + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BV', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + C = DPAR(1) + IF ( N.EQ.0 ) THEN + RETURN + ELSE IF ( M.EQ.0 ) THEN + IF ( FULL ) THEN + CALL DLASET( UPLO, N, N, ZERO, C, JTJ, LDJTJ ) + ELSE + DUM(1) = ZERO + CALL DCOPY( ( N*( N + 1 ) )/2, DUM, 0, JTJ, 1 ) + IF ( UPPER ) THEN + II = 0 +C + DO 10 I = 1, N + II = II + I + JTJ(II) = C + 10 CONTINUE +C + ELSE + II = 1 +C + DO 20 I = N, 1, -1 + JTJ(II) = C + II = II + I + 20 CONTINUE +C + ENDIF + ENDIF + RETURN + ENDIF +C +C Build a triangle of the matrix J'*J + c*I. +C + IF ( FULL ) THEN + CALL DLASET( UPLO, N, N, ZERO, C, JTJ, LDJTJ ) + CALL DSYRK( UPLO, 'Transpose', N, M, ONE, J, LDJ, ONE, JTJ, + $ LDJTJ ) + ELSEIF ( UPPER ) THEN + II = 0 +C + DO 30 I = 1, N + CALL DGEMV( 'Transpose', M, I, ONE, J, LDJ, J(1,I), 1, ZERO, + $ JTJ(II+1), 1 ) + II = II + I + JTJ(II) = JTJ(II) + C + 30 CONTINUE +C + ELSE + II = 1 +C + DO 40 I = N, 1, -1 + CALL DGEMV( 'Transpose', M, I, ONE, J(1,N-I+1), LDJ, + $ J(1,N-I+1), 1, ZERO, JTJ(II), 1 ) + JTJ(II) = JTJ(II) + C + II = II + I + 40 CONTINUE +C + ENDIF +C + RETURN +C +C *** Last line of NF01BV *** + END diff --git a/mex/sources/libslicot/NF01BW.f b/mex/sources/libslicot/NF01BW.f new file mode 100644 index 000000000..1fdac4fd9 --- /dev/null +++ b/mex/sources/libslicot/NF01BW.f @@ -0,0 +1,242 @@ + SUBROUTINE NF01BW( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, INCX, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix-vector product x <-- (J'*J + c*I)*x, for the +C Jacobian J as received from SLICOT Library routine NF01BD: +C +C / dy(1)/dwb(1) | dy(1)/dtheta \ +C Jc = | : | : | . +C \ dy(L)/dwb(L) | dy(L)/dtheta / +C +C This is a compressed representation of the actual structure +C +C / J_1 0 .. 0 | L_1 \ +C | 0 J_2 .. 0 | L_2 | +C J = | : : .. : | : | . +C | : : .. : | : | +C \ 0 0 .. J_L | L_L / +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the vector x. +C N = BN*BSN + ST >= 0. (See parameter description below.) +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix J, as follows: +C IPAR(1) must contain ST, the number of parameters +C corresponding to the linear part. ST >= 0. +C IPAR(2) must contain BN, the number of blocks, BN = L, +C for the parameters corresponding to the nonlinear +C part. BN >= 0. +C IPAR(3) must contain BSM, the number of rows of the blocks +C J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the +C number of rows of the matrix J, if BN <= 1. +C IPAR(4) must contain BSN, the number of columns of the +C blocks J_k, k = 1:BN. BSN >= 0. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 4. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C The real parameters needed for solving the problem. +C The entry DPAR(1) must contain the real scalar c. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 1. +C +C J (input) DOUBLE PRECISION array, dimension (LDJ, NC) +C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. +C The leading NR-by-NC part of this array must contain +C the (compressed) representation (Jc) of the Jacobian +C matrix J, where NR = BSM if BN <= 1, and NR = BN*BSM, +C if BN > 1. +C +C LDJ (input) INTEGER +C The leading dimension of array J. LDJ >= MAX(1,NR). +C +C X (input/output) DOUBLE PRECISION array, dimension +C (1+(N-1)*INCX) +C On entry, this incremented array must contain the +C vector x. +C On exit, this incremented array contains the value of the +C matrix-vector product (J'*J + c*I)*x. +C +C INCX (input) INTEGER +C The increment for the elements of X. INCX >= 1. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= NR. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The associativity of matrix multiplications is used; the result +C is obtained as: x_out = J'*( J*x ) + c*x. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Mar. 2001, during a stay at University of Twente, NL. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001, +C Mar. 2002. +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations, +C Wiener system. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INCX, INFO, LDJ, LDPAR, LDWORK, LIPAR, N +C .. Array Arguments .. + DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), X(*) + INTEGER IPAR(*) +C .. Local Scalars .. + INTEGER BN, BSM, BSN, IBSM, IBSN, IX, JL, M, NTHS, ST, + $ XL + DOUBLE PRECISION C +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C + INFO = 0 +C + IF ( N.LT.0 ) THEN + INFO = -1 + ELSEIF ( LIPAR.LT.4 ) THEN + INFO = -3 + ELSEIF ( LDPAR.LT.1 ) THEN + INFO = -5 + ELSEIF ( INCX.LT.1 ) THEN + INFO = -9 + ELSE + ST = IPAR(1) + BN = IPAR(2) + BSM = IPAR(3) + BSN = IPAR(4) + NTHS = BN*BSN + IF ( BN.GT.1 ) THEN + M = BN*BSM + ELSE + M = BSM + END IF + IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN + INFO = -2 + ELSEIF ( N.NE.NTHS + ST ) THEN + INFO = -1 + ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN + INFO = -7 + ELSEIF ( LDWORK.LT.M ) THEN + INFO = -11 + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BW', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + C = DPAR(1) +C + IF ( M.EQ.0 ) THEN +C +C Special case, void Jacobian: x <-- c*x. +C + CALL DSCAL( N, C, X, INCX ) + RETURN + END IF +C + IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN +C +C Special case, l <= 1 or BSN = 0: the Jacobian is represented +C as a full matrix. Adapted code from NF01BX is included in-line. +C + CALL DGEMV( 'NoTranspose', M, N, ONE, J, LDJ, X, INCX, ZERO, + $ DWORK, 1 ) + CALL DGEMV( 'Transpose', M, N, ONE, J, LDJ, DWORK, 1, C, X, + $ INCX ) + RETURN + END IF +C +C General case: l > 1, BSN > 0, BSM > 0. +C + JL = BSN + 1 + IX = BSN*INCX + XL = BN*IX + 1 +C + IF ( ST.GT.0 ) THEN + CALL DGEMV( 'NoTranspose', M, ST, ONE, J(1,JL), LDJ, X(XL), + $ INCX, ZERO, DWORK, 1 ) + ELSE + DWORK(1) = ZERO + CALL DCOPY( M, DWORK(1), 0, DWORK, 1 ) + END IF + IBSN = 1 +C + DO 10 IBSM = 1, M, BSM + CALL DGEMV( 'NoTranspose', BSM, BSN, ONE, J(IBSM,1), LDJ, + $ X(IBSN), INCX, ONE, DWORK(IBSM), 1 ) + CALL DGEMV( 'Transpose', BSM, BSN, ONE, J(IBSM,1), LDJ, + $ DWORK(IBSM), 1, C, X(IBSN), INCX ) + IBSN = IBSN + IX + 10 CONTINUE +C + IF ( ST.GT.0 ) + $ CALL DGEMV( 'Transpose', M, ST, ONE, J(1,JL), LDJ, DWORK, 1, C, + $ X(XL), INCX ) +C + RETURN +C +C *** Last line of NF01BW *** + END diff --git a/mex/sources/libslicot/NF01BX.f b/mex/sources/libslicot/NF01BX.f new file mode 100644 index 000000000..73cc30c61 --- /dev/null +++ b/mex/sources/libslicot/NF01BX.f @@ -0,0 +1,174 @@ + SUBROUTINE NF01BX( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, INCX, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute (J'*J + c*I)*x, where J is an m-by-n real matrix, c is +C a real scalar, I is the n-by-n identity matrix, and x is a real +C n-vector. +C +C NOTE: this routine must have the same arguments as SLICOT Library +C routine NF01BW. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of columns of the Jacobian matrix J. N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix J, as follows: +C IPAR(1) must contain the number of rows M of the Jacobian +C matrix J. M >= 0. +C IPAR is provided for compatibility with SLICOT Library +C routine MD03AD. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 1. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C The real parameters needed for solving the problem. +C The entry DPAR(1) must contain the real scalar c. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 1. +C +C J (input) DOUBLE PRECISION array, dimension (LDJ,N) +C The leading M-by-N part of this array must contain the +C Jacobian matrix J. +C +C LDJ INTEGER +C The leading dimension of the array J. LDJ >= MAX(1,M). +C +C X (input/output) DOUBLE PRECISION array, dimension +C (1+(N-1)*abs(INCX)) +C On entry, this incremented array must contain the +C vector x. +C On exit, this incremented array contains the value of the +C matrix-vector product (J'*J + c*I)*x. +C +C INCX (input) INTEGER +C The increment for the elements of X. INCX <> 0. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= M. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The associativity of matrix multiplications is used; the result +C is obtained as: x_out = J'*( J*x ) + c*x. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Oct. 2000, during a stay at University of Twente, NL. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, +C Mar. 2002, Oct. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INCX, INFO, LDJ, LDPAR, LDWORK, LIPAR, N +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), X(*) +C .. Local Scalars .. + INTEGER M + DOUBLE PRECISION C +C .. External Subroutines .. + EXTERNAL DGEMV, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C + INFO = 0 + IF ( N.LT.0 ) THEN + INFO = -1 + ELSEIF ( LIPAR.LT.1 ) THEN + INFO = -3 + ELSEIF ( LDPAR.LT.1 ) THEN + INFO = -5 + ELSEIF ( INCX.EQ.0 ) THEN + INFO = -9 + ELSE + M = IPAR(1) + IF ( M.LT.0 ) THEN + INFO = -2 + ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN + INFO = -7 + ELSEIF ( LDWORK.LT.M ) THEN + INFO = -11 + ENDIF + ENDIF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'NF01BX', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + C = DPAR(1) + IF ( M.EQ.0 ) THEN +C +C Special case, void J: x <-- c*x. +C + CALL DSCAL( N, C, X, INCX ) + RETURN + END IF +C + CALL DGEMV( 'NoTranspose', M, N, ONE, J, LDJ, X, INCX, ZERO, + $ DWORK, 1 ) + CALL DGEMV( 'Transpose', M, N, ONE, J, LDJ, DWORK, 1, C, X, INCX ) + RETURN +C +C *** Last line of NF01BX *** + END diff --git a/mex/sources/libslicot/NF01BY.f b/mex/sources/libslicot/NF01BY.f new file mode 100644 index 000000000..c9c0a8e33 --- /dev/null +++ b/mex/sources/libslicot/NF01BY.f @@ -0,0 +1,294 @@ + SUBROUTINE NF01BY( CJTE, NSMP, NZ, L, IPAR, LIPAR, WB, LWB, Z, + $ LDZ, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Jacobian of the error function for a neural network +C of the structure +C +C - tanh(w1*z+b1) - +C / : \ +C z --- : --- sum(ws(i)*...)+ b(n+1) --- y, +C \ : / +C - tanh(wn*z+bn) - +C +C for the single-output case. The Jacobian has the form +C +C d e(1) / d WB(1) ... d e(1) / d WB(NWB) +C J = : : , +C d e(NSMP) / d WB(1) ... d e(NSMP) / d WB(NWB) +C +C where e(z) is the error function, WB is the set of weights and +C biases of the network (for the considered output), and NWB is +C the number of elements of this set, NWB = IPAR(1)*(NZ+2)+1 +C (see below). +C +C In the multi-output case, this routine should be called for each +C output. +C +C NOTE: this routine must have the same arguments as SLICOT Library +C routine NF01BD. +C +C ARGUMENTS +C +C Mode Parameters +C +C CJTE CHARACTER*1 +C Specifies whether the matrix-vector product J'*e should be +C computed or not, as follows: +C = 'C' : compute J'*e; +C = 'N' : do not compute J'*e. +C +C Input/Output Parameters +C +C NSMP (input) INTEGER +C The number of training samples. NSMP >= 0. +C +C NZ (input) INTEGER +C The length of each input sample. NZ >= 0. +C +C L (input) INTEGER +C The length of each output sample. +C Currently, L must be 1. +C +C IPAR (input/output) INTEGER array, dimension (LIPAR) +C The integer parameters needed. +C On entry, the first element of this array must contain +C a value related to the number of neurons, n; specifically, +C n = abs(IPAR(1)), since setting IPAR(1) < 0 has a special +C meaning (see below). +C On exit, if IPAR(1) < 0 on entry, then no computations are +C performed, except the needed tests on input parameters, +C but the following values are returned: +C IPAR(1) contains the length of the array J, LJ; +C LDJ contains the leading dimension of array J. +C Otherwise, IPAR(1) and LDJ are unchanged on exit. +C +C LIPAR (input) INTEGER +C The length of the vector IPAR. LIPAR >= 1. +C +C WB (input) DOUBLE PRECISION array, dimension (LWB) +C The leading NWB = IPAR(1)*(NZ+2)+1 part of this array +C must contain the weights and biases of the network, +C WB = ( w(1,1), ..., w(1,NZ), ..., w(n,1), ..., w(n,NZ), +C ws(1), ..., ws(n), b(1), ..., b(n+1) ), +C where w(i,j) are the weights of the hidden layer, +C ws(i) are the weights of the linear output layer and +C b(i) are the biases. +C +C LWB (input) INTEGER +C The length of array WB. LWB >= NWB. +C +C Z (input) DOUBLE PRECISION array, dimension (LDZ, NZ) +C The leading NSMP-by-NZ part of this array must contain the +C set of input samples, +C Z = ( Z(1,1),...,Z(1,NZ); ...; Z(NSMP,1),...,Z(NSMP,NZ) ). +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= MAX(1,NSMP). +C +C E (input) DOUBLE PRECISION array, dimension (NSMP) +C If CJTE = 'C', this array must contain the error vector e. +C If CJTE = 'N', this array is not referenced. +C +C J (output) DOUBLE PRECISION array, dimension (LDJ, NWB) +C The leading NSMP-by-NWB part of this array contains the +C Jacobian of the error function. +C +C LDJ INTEGER +C The leading dimension of array J. LDJ >= MAX(1,NSMP). +C Note that LDJ is an input parameter, except for +C IPAR(1) < 0 on entry, when it is an output parameter. +C +C JTE (output) DOUBLE PRECISION array, dimension (NWB) +C If CJTE = 'C', this array contains the matrix-vector +C product J'*e. +C If CJTE = 'N', this array is not referenced. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C This argument is included for combatibility with SLICOT +C Library routine NF01BD. +C +C LDWORK INTEGER +C Normally, the length of the array DWORK. LDWORK >= 0. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The Jacobian is computed analytically. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Oct. 2000, during a stay at University of Twente, NL. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Input output description, neural network, nonlinear system, +C optimization, system response. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + CHARACTER CJTE + INTEGER INFO, L, LDJ, LDWORK, LDZ, LIPAR, LWB, NSMP, NZ +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), JTE(*), WB(*), + $ Z(LDZ,*) + INTEGER IPAR(*) +C .. Local Scalars .. + LOGICAL WJTE + INTEGER BP1, DI, I, IB, K, M, NN, NWB, WS + DOUBLE PRECISION BIGNUM, SMLNUM, TMP +C .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, EXP, LOG, MAX, MIN +C .. +C .. Executable Statements .. +C + WJTE = LSAME( CJTE, 'C' ) + INFO = 0 + NN = IPAR(1) + NWB = NN*( NZ + 2 ) + 1 + IF( .NOT.( WJTE .OR. LSAME( CJTE, 'N' ) ) ) THEN + INFO = -1 + ELSEIF ( NSMP.LT.0 ) THEN + INFO = -2 + ELSEIF ( NZ.LT.0 ) THEN + INFO = -3 + ELSEIF ( L.NE.1 ) THEN + INFO = -4 + ELSEIF ( LIPAR.LT.1 ) THEN + INFO = -6 + ELSEIF ( IPAR(1).LT.0 ) THEN + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BY', -INFO ) + ELSE + IPAR(1) = NSMP*( ABS( NN )*( NZ + 2 ) + 1 ) + LDJ = NSMP + ENDIF + RETURN + ELSEIF ( LWB.LT.NWB ) THEN + INFO = -8 + ELSEIF ( LDZ.LT.MAX( 1, NSMP ) ) THEN + INFO = -10 + ELSEIF ( LDJ.LT.MAX( 1, NSMP ) ) THEN + INFO = -13 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BY', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( MIN( NSMP, NZ ).EQ.0 ) + $ RETURN +C +C Set parameters to avoid overflows and increase accuracy for +C extreme values. +C + SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = LOG( SMLNUM ) + BIGNUM = LOG( BIGNUM ) +C + WS = NZ*NN + 1 + IB = WS + NN + BP1 = IB + NN +C + J(1, BP1) = ONE + CALL DCOPY( NSMP, J(1, BP1), 0, J(1, BP1), 1 ) +C + DO 10 I = 0, NN - 1 + CALL DCOPY( NSMP, WB(IB+I), 0, J(1, WS+I), 1 ) + 10 CONTINUE +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NSMP, NN, NZ, -TWO, Z, + $ LDZ, WB, NZ, -TWO, J(1, WS), LDJ ) + DI = 1 +C + DO 50 I = 0, NN - 1 +C + DO 20 K = 1, NSMP + TMP = J(K, WS+I) + IF ( ABS( TMP ).GE.BIGNUM ) THEN + IF ( TMP.GT.ZERO ) THEN + J(K, WS+I) = -ONE + ELSE + J(K, WS+I) = ONE + END IF + ELSE IF ( ABS( TMP ).LE.SMLNUM ) THEN + J(K, WS+I) = ZERO + ELSE + J(K, WS+I) = TWO/( ONE + EXP( TMP ) ) - ONE + END IF + J(K, IB+I) = WB(WS+I)*( ONE - J(K, WS+I)**2 ) + 20 CONTINUE +C + DO 40 K = 0, NZ - 1 +C + DO 30 M = 1, NSMP + J(M, DI+K) = J(M, IB+I)*Z(M, K+1) + 30 CONTINUE +C + 40 CONTINUE +C + DI = DI + NZ + 50 CONTINUE +C + IF ( WJTE ) THEN +C +C Compute J'e. +C + CALL DGEMV( 'Transpose', NSMP, NWB, ONE, J, LDJ, E, 1, ZERO, + $ JTE, 1 ) + END IF +C + RETURN +C +C *** Last line of NF01BY *** + END diff --git a/mex/sources/libslicot/SB01BD.f b/mex/sources/libslicot/SB01BD.f new file mode 100644 index 000000000..587581e34 --- /dev/null +++ b/mex/sources/libslicot/SB01BD.f @@ -0,0 +1,776 @@ + SUBROUTINE SB01BD( DICO, N, M, NP, ALPHA, A, LDA, B, LDB, WR, WI, + $ NFP, NAP, NUP, F, LDF, Z, LDZ, TOL, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine the state feedback matrix F for a given system (A,B) +C such that the closed-loop state matrix A+B*F has specified +C eigenvalues. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the state vector, i.e. the order of the +C matrix A, and also the number of rows of the matrix B and +C the number of columns of the matrix F. N >= 0. +C +C M (input) INTEGER +C The dimension of input vector, i.e. the number of columns +C of the matrix B and the number of rows of the matrix F. +C M >= 0. +C +C NP (input) INTEGER +C The number of given eigenvalues. At most N eigenvalues +C can be assigned. 0 <= NP. +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the maximum admissible value, either for real +C parts, if DICO = 'C', or for moduli, if DICO = 'D', +C of the eigenvalues of A which will not be modified by +C the eigenvalue assignment algorithm. +C ALPHA >= 0 if DICO = 'D'. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading N-by-N part of this array contains +C the matrix Z'*(A+B*F)*Z in a real Schur form. +C The leading NFP-by-NFP diagonal block of A corresponds +C to the fixed (unmodified) eigenvalues having real parts +C less than ALPHA, if DICO = 'C', or moduli less than ALPHA, +C if DICO = 'D'. The trailing NUP-by-NUP diagonal block of A +C corresponds to the uncontrollable eigenvalues detected by +C the eigenvalue assignment algorithm. The elements under +C the first subdiagonal are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C WR,WI (input/output) DOUBLE PRECISION array, dimension (NP) +C On entry, these arrays must contain the real and imaginary +C parts, respectively, of the desired eigenvalues of the +C closed-loop system state-matrix A+B*F. The eigenvalues +C can be unordered, except that complex conjugate pairs +C must appear consecutively in these arrays. +C On exit, if INFO = 0, the leading NAP elements of these +C arrays contain the real and imaginary parts, respectively, +C of the assigned eigenvalues. The trailing NP-NAP elements +C contain the unassigned eigenvalues. +C +C NFP (output) INTEGER +C The number of eigenvalues of A having real parts less than +C ALPHA, if DICO = 'C', or moduli less than ALPHA, if +C DICO = 'D'. These eigenvalues are not modified by the +C eigenvalue assignment algorithm. +C +C NAP (output) INTEGER +C The number of assigned eigenvalues. If INFO = 0 on exit, +C then NAP = N-NFP-NUP. +C +C NUP (output) INTEGER +C The number of uncontrollable eigenvalues detected by the +C eigenvalue assignment algorithm (see METHOD). +C +C F (output) DOUBLE PRECISION array, dimension (LDF,N) +C The leading M-by-N part of this array contains the state +C feedback F, which assigns NAP closed-loop eigenvalues and +C keeps unaltered N-NAP open-loop eigenvalues. +C +C LDF INTEGER +C The leading dimension of array F. LDF >= MAX(1,M). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C The leading N-by-N part of this array contains the +C orthogonal matrix Z which reduces the closed-loop +C system state matrix A + B*F to upper real Schur form. +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The absolute tolerance level below which the elements of A +C or B are considered zero (used for controllability tests). +C If the user sets TOL <= 0, then the default tolerance +C TOL = N * EPS * max(NORM(A),NORM(B)) is used, where EPS is +C the machine precision (see LAPACK Library routine DLAMCH) +C and NORM(A) denotes the 1-norm of A. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LDWORK >= MAX( 1,5*M,5*N,2*N+4*M ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = K: K violations of the numerical stability condition +C NORM(F) <= 100*NORM(A)/NORM(B) occured during the +C assignment of eigenvalues. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the ordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + B*F)*Z +C along the diagonal. +C = 3: the number of eigenvalues to be assigned is less +C than the number of possibly assignable eigenvalues; +C NAP eigenvalues have been properly assigned, +C but some assignable eigenvalues remain unmodified. +C = 4: an attempt is made to place a complex conjugate +C pair on the location of a real eigenvalue. This +C situation can only appear when N-NFP is odd, +C NP > N-NFP-NUP is even, and for the last real +C eigenvalue to be modified there exists no available +C real eigenvalue to be assigned. However, NAP +C eigenvalues have been already properly assigned. +C +C METHOD +C +C SB01BD is based on the factorization algorithm of [1]. +C Given the matrices A and B of dimensions N-by-N and N-by-M, +C respectively, this subroutine constructs an M-by-N matrix F such +C that A + BF has eigenvalues as follows. +C Let NFP eigenvalues of A have real parts less than ALPHA, if +C DICO = 'C', or moduli less then ALPHA, if DICO = 'D'. Then: +C 1) If the pair (A,B) is controllable, then A + B*F has +C NAP = MIN(NP,N-NFP) eigenvalues assigned from those specified +C by WR + j*WI and N-NAP unmodified eigenvalues; +C 2) If the pair (A,B) is uncontrollable, then the number of +C assigned eigenvalues NAP satifies generally the condition +C NAP <= MIN(NP,N-NFP). +C +C At the beginning of the algorithm, F = 0 and the matrix A is +C reduced to an ordered real Schur form by separating its spectrum +C in two parts. The leading NFP-by-NFP part of the Schur form of +C A corresponds to the eigenvalues which will not be modified. +C These eigenvalues have real parts less than ALPHA, if +C DICO = 'C', or moduli less than ALPHA, if DICO = 'D'. +C The performed orthogonal transformations are accumulated in Z. +C After this preliminary reduction, the algorithm proceeds +C recursively. +C +C Let F be the feedback matrix at the beginning of a typical step i. +C At each step of the algorithm one real eigenvalue or two complex +C conjugate eigenvalues are placed by a feedback Fi of rank 1 or +C rank 2, respectively. Since the feedback Fi affects only the +C last 1 or 2 columns of Z'*(A+B*F)*Z, the matrix Z'*(A+B*F+B*Fi)*Z +C therefore remains in real Schur form. The assigned eigenvalue(s) +C is (are) then moved to another diagonal position of the real +C Schur form using reordering techniques and a new block is +C transfered in the last diagonal position. The feedback matrix F +C is updated as F <-- F + Fi. The eigenvalue(s) to be assigned at +C each step is (are) chosen such that the norm of each Fi is +C minimized. +C +C If uncontrollable eigenvalues are encountered in the last diagonal +C position of the real Schur matrix Z'*(A+B*F)*Z, the algorithm +C deflates them at the bottom of the real Schur form and redefines +C accordingly the position of the "last" block. +C +C Note: Not all uncontrollable eigenvalues of the pair (A,B) are +C necessarily detected by the eigenvalue assignment algorithm. +C Undetected uncontrollable eigenvalues may exist if NFP > 0 and/or +C NP < N-NFP. +C +C REFERENCES +C +C [1] Varga A. +C A Schur method for pole assignment. +C IEEE Trans. Autom. Control, Vol. AC-26, pp. 517-519, 1981. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires no more than 14N floating point +C operations. Although no proof of numerical stability is known, +C the algorithm has always been observed to yield reliable +C numerical results. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C February 1999. Based on the RASP routine SB01BD. +C +C REVISIONS +C +C March 30, 1999, V. Sima, Research Institute for Informatics, +C Bucharest. +C April 4, 1999. A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen. +C May 18, 2003. A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen. +C Feb. 15, 2004, V. Sima, Research Institute for Informatics, +C Bucharest. +C May 12, 2005. A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen. +C +C KEYWORDS +C +C Eigenvalues, eigenvalue assignment, feedback control, +C pole placement, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION HUNDR, ONE, TWO, ZERO + PARAMETER ( HUNDR = 1.0D2, ONE = 1.0D0, TWO = 2.0D0, + $ ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO + INTEGER INFO, IWARN, LDA, LDB, LDF, LDWORK, LDZ, M, N, + $ NAP, NFP, NP, NUP + DOUBLE PRECISION ALPHA, TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*), + $ WI(*), WR(*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL CEIG, DISCR, SIMPLB + INTEGER I, IB, IB1, IERR, IPC, J, K, KFI, KG, KW, KWI, + $ KWR, NCUR, NCUR1, NL, NLOW, NMOVES, NPC, NPR, + $ NSUP, WRKOPT + DOUBLE PRECISION ANORM, BNORM, C, P, RMAX, S, X, Y, TOLER, TOLERB +C .. Local Arrays .. + LOGICAL BWORK(1) + DOUBLE PRECISION A2(2,2) +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME, SELECT +C .. External Subroutines .. + EXTERNAL DGEES, DGEMM, DLAEXC, DLASET, DROT, DSWAP, + $ MB03QD, MB03QY, SB01BX, SB01BY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( NP.LT.0 ) THEN + INFO = -4 + ELSE IF( DISCR .AND. ( ALPHA.LT.ZERO ) ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -16 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDWORK.LT.MAX( 1, 5*M, 5*N, 2*N + 4*M ) ) THEN + INFO = -21 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'SB01BD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + NFP = 0 + NAP = 0 + NUP = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Compute the norms of A and B, and set default tolerances +C if necessary. +C + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) + BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) + IF( TOL.LE.ZERO ) THEN + X = DLAMCH( 'Epsilon' ) + TOLER = DBLE( N ) * MAX( ANORM, BNORM ) * X + TOLERB = DBLE( N ) * BNORM * X + ELSE + TOLER = TOL + TOLERB = TOL + END IF +C +C Allocate working storage. +C + KWR = 1 + KWI = KWR + N + KW = KWI + N +C +C Reduce A to real Schur form using an orthogonal similarity +C transformation A <- Z'*A*Z and accumulate the transformation in Z. +C +C Workspace: need 5*N; +C prefer larger. +C + CALL DGEES( 'Vectors', 'No ordering', SELECT, N, A, LDA, NCUR, + $ DWORK(KWR), DWORK(KWI), Z, LDZ, DWORK(KW), + $ LDWORK-KW+1, BWORK, INFO ) + WRKOPT = KW - 1 + INT( DWORK( KW ) ) + IF( INFO.NE.0 ) THEN + INFO = 1 + RETURN + END IF +C +C Reduce A to an ordered real Schur form using an orthogonal +C similarity transformation A <- Z'*A*Z and accumulate the +C transformations in Z. The separation of the spectrum of A is +C performed such that the leading NFP-by-NFP submatrix of A +C corresponds to the "good" eigenvalues which will not be +C modified. The bottom (N-NFP)-by-(N-NFP) diagonal block of A +C corresponds to the "bad" eigenvalues to be modified. +C +C Workspace needed: N. +C + CALL MB03QD( DICO, 'Stable', 'Update', N, 1, N, ALPHA, + $ A, LDA, Z, LDZ, NFP, DWORK, INFO ) + IF( INFO.NE.0 ) + $ RETURN +C +C Set F = 0. +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, F, LDF ) +C +C Return if B is negligible (uncontrollable system). +C + IF( BNORM.LE.TOLERB ) THEN + NAP = 0 + NUP = N + DWORK(1) = WRKOPT + RETURN + END IF +C +C Compute the bound for the numerical stability condition. +C + RMAX = HUNDR * ANORM / BNORM +C +C Perform eigenvalue assignment if there exist "bad" eigenvalues. +C + NAP = 0 + NUP = 0 + IF( NFP .LT. N ) THEN + KG = 1 + KFI = KG + 2*M + KW = KFI + 2*M +C +C Set the limits for the bottom diagonal block. +C + NLOW = NFP + 1 + NSUP = N +C +C Separate and count real and complex eigenvalues to be assigned. +C + NPR = 0 + DO 10 I = 1, NP + IF( WI(I) .EQ. ZERO ) THEN + NPR = NPR + 1 + K = I - NPR + IF( K .GT. 0 ) THEN + S = WR(I) + DO 5 J = NPR + K - 1, NPR, -1 + WR(J+1) = WR(J) + WI(J+1) = WI(J) + 5 CONTINUE + WR(NPR) = S + WI(NPR) = ZERO + END IF + END IF + 10 CONTINUE + NPC = NP - NPR +C +C The first NPR elements of WR and WI contain the real +C eigenvalues, the last NPC elements contain the complex +C eigenvalues. Set the pointer to complex eigenvalues. +C + IPC = NPR + 1 +C +C Main loop for assigning one or two eigenvalues. +C +C Terminate if all eigenvalues were assigned, or if there +C are no more eigenvalues to be assigned, or if a non-fatal +C error condition was set. +C +C WHILE (NLOW <= NSUP and INFO = 0) DO +C + 20 IF( NLOW.LE.NSUP .AND. INFO.EQ.0 ) THEN +C +C Determine the dimension of the last block. +C + IB = 1 + IF( NLOW.LT.NSUP ) THEN + IF( A(NSUP,NSUP-1).NE.ZERO ) IB = 2 + END IF +C +C Compute G, the current last IB rows of Z'*B. +C + NL = NSUP - IB + 1 + CALL DGEMM( 'Transpose', 'NoTranspose', IB, M, N, ONE, + $ Z(1,NL), LDZ, B, LDB, ZERO, DWORK(KG), IB ) +C +C Check the controllability for a simple block. +C + IF( DLANGE( '1', IB, M, DWORK(KG), IB, DWORK(KW) ) + $ .LE. TOLERB ) THEN +C +C Deflate the uncontrollable block and resume the +C main loop. +C + NSUP = NSUP - IB + NUP = NUP + IB + GO TO 20 + END IF +C +C Test for termination with INFO = 3. +C + IF( NAP.EQ.NP) THEN + INFO = 3 +C +C Test for compatibility. Terminate if an attempt occurs +C to place a complex conjugate pair on a 1x1 block. +C + ELSE IF( IB.EQ.1 .AND. NPR.EQ.0 .AND. NLOW.EQ.NSUP ) THEN + INFO = 4 + ELSE +C +C Set the simple block flag. +C + SIMPLB = .TRUE. +C +C Form a 2-by-2 block if necessary from two 1-by-1 blocks. +C Consider special case IB = 1, NPR = 1 and +C NPR+NPC > NSUP-NLOW+1 to avoid incompatibility. +C + IF( ( IB.EQ.1 .AND. NPR.EQ.0 ) .OR. + $ ( IB.EQ.1 .AND. NPR.EQ.1 .AND. NSUP.GT.NLOW .AND. + $ NPR+NPC.GT.NSUP-NLOW+1 ) ) THEN + IF( NSUP.GT.2 ) THEN + IF( A(NSUP-1,NSUP-2) .NE. ZERO ) THEN +C +C Interchange with the adjacent 2x2 block. +C +C Workspace needed: N. +C + CALL DLAEXC( .TRUE., N, A, LDA, Z, LDZ, NSUP-2, + $ 2, 1, DWORK(KW), INFO ) + IF( INFO .NE. 0 ) THEN + INFO = 2 + RETURN + END IF + ELSE +C +C Form a non-simple block by extending the last +C block with a 1x1 block. +C + SIMPLB = .FALSE. + END IF + ELSE + SIMPLB = .FALSE. + END IF + IB = 2 + END IF + NL = NSUP - IB + 1 +C +C Compute G, the current last IB rows of Z'*B. +C + CALL DGEMM( 'Transpose', 'NoTranspose', IB, M, N, ONE, + $ Z(1,NL), LDZ, B, LDB, ZERO, DWORK(KG), IB ) +C +C Check the controllability for the current block. +C + IF( DLANGE( '1', IB, M, DWORK(KG), IB, DWORK(KW) ) + $ .LE. TOLERB ) THEN +C +C Deflate the uncontrollable block and resume the +C main loop. +C + NSUP = NSUP - IB + NUP = NUP + IB + GO TO 20 + END IF +C + IF( NAP+IB .GT. NP ) THEN +C +C No sufficient eigenvalues to be assigned. +C + INFO = 3 + ELSE + IF( IB .EQ. 1 ) THEN +C +C A 1-by-1 block. +C +C Assign the real eigenvalue nearest to A(NSUP,NSUP). +C + X = A(NSUP,NSUP) + CALL SB01BX( .TRUE., NPR, X, X, WR, X, S, P ) + NPR = NPR - 1 + CEIG = .FALSE. + ELSE +C +C A 2-by-2 block. +C + IF( SIMPLB ) THEN +C +C Simple 2-by-2 block with complex eigenvalues. +C Compute the eigenvalues of the last block. +C + CALL MB03QY( N, NL, A, LDA, Z, LDZ, X, Y, INFO ) + IF( NPC .GT. 1 ) THEN + CALL SB01BX( .FALSE., NPC, X, Y, + $ WR(IPC), WI(IPC), S, P ) + NPC = NPC - 2 + CEIG = .TRUE. + ELSE +C +C Choose the nearest two real eigenvalues. +C + CALL SB01BX( .TRUE., NPR, X, X, WR, X, S, P ) + CALL SB01BX( .TRUE., NPR-1, X, X, WR, X, + $ Y, P ) + P = S * Y + S = S + Y + NPR = NPR - 2 + CEIG = .FALSE. + END IF + ELSE +C +C Non-simple 2x2 block with real eigenvalues. +C Choose the nearest pair of complex eigenvalues. +C + X = ( A(NL,NL) + A(NSUP,NSUP) )/TWO + CALL SB01BX( .FALSE., NPC, X, ZERO, WR(IPC), + $ WI(IPC), S, P ) + NPC = NPC - 2 + END IF + END IF +C +C Form the IBxIB matrix A2 from the current diagonal +C block. +C + A2(1,1) = A(NL,NL) + IF( IB .GT. 1 ) THEN + A2(1,2) = A(NL,NSUP) + A2(2,1) = A(NSUP,NL) + A2(2,2) = A(NSUP,NSUP) + END IF +C +C Determine the M-by-IB feedback matrix FI which +C assigns the chosen IB eigenvalues for the pair (A2,G). +C +C Workspace needed: 5*M. +C + CALL SB01BY( IB, M, S, P, A2, DWORK(KG), DWORK(KFI), + $ TOLER, DWORK(KW), IERR ) + IF( IERR .NE. 0 ) THEN + IF( IB.EQ.1 .OR. SIMPLB ) THEN +C +C The simple 1x1 block is uncontrollable. +C + NSUP = NSUP - IB + IF( CEIG ) THEN + NPC = NPC + IB + ELSE + NPR = NPR + IB + END IF + NUP = NUP + IB + ELSE +C +C The non-simple 2x2 block is uncontrollable. +C Eliminate its uncontrollable part by using +C the information in elements FI(1,1) and F(1,2). +C + C = DWORK(KFI) + S = DWORK(KFI+IB) +C +C Apply the transformation to A and accumulate it +C in Z. +C + CALL DROT( N-NL+1, A(NL,NL), LDA, + $ A(NSUP,NL), LDA, C, S ) + CALL DROT( N, A(1,NL), 1, A(1,NSUP), 1, C, S ) + CALL DROT( N, Z(1,NL), 1, Z(1,NSUP), 1, C, S ) +C +C Annihilate the subdiagonal element of the last +C block, redefine the upper limit for the bottom +C block and resume the main loop. +C + A(NSUP,NL) = ZERO + NSUP = NL + NUP = NUP + 1 + NPC = NPC + 2 + END IF + ELSE +C +C Successful assignment of IB eigenvalues. +C +C Update the feedback matrix F <-- F + [0 FI]*Z'. +C + CALL DGEMM( 'NoTranspose', 'Transpose', M, N, + $ IB, ONE, DWORK(KFI), M, Z(1,NL), + $ LDZ, ONE, F, LDF ) +C +C Check for possible numerical instability. +C + IF( DLANGE( '1', M, IB, DWORK(KFI), M, DWORK(KW) ) + $ .GT. RMAX ) IWARN = IWARN + 1 +C +C Update the state matrix A <-- A + Z'*B*[0 FI]. +C Workspace needed: 2*N+4*M. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, IB, + $ M, ONE, B, LDB, DWORK(KFI), M, ZERO, + $ DWORK(KW), N ) + CALL DGEMM( 'Transpose', 'NoTranspose', NSUP, + $ IB, N, ONE, Z, LDZ, DWORK(KW), N, + $ ONE, A(1,NL), LDA ) +C +C Try to split the 2x2 block. +C + IF( IB .EQ. 2 ) + $ CALL MB03QY( N, NL, A, LDA, Z, LDZ, X, Y, + $ INFO ) + NAP = NAP + IB + IF( NLOW+IB.LE.NSUP ) THEN +C +C Move the last block(s) to the leading +C position(s) of the bottom block. +C + NCUR1 = NSUP - IB + NMOVES = 1 + IF( IB.EQ.2 .AND. A(NSUP,NSUP-1).EQ.ZERO ) THEN + IB = 1 + NMOVES = 2 + END IF +C +C WHILE (NMOVES > 0) DO + 30 IF( NMOVES .GT. 0 ) THEN + NCUR = NCUR1 +C +C WHILE (NCUR >= NLOW) DO + 40 IF( NCUR .GE. NLOW ) THEN +C +C Loop for the last block positioning. +C + IB1 = 1 + IF( NCUR.GT.NLOW ) THEN + IF( A(NCUR,NCUR-1).NE.ZERO ) IB1 = 2 + END IF + CALL DLAEXC( .TRUE., N, A, LDA, Z, LDZ, + $ NCUR-IB1+1, IB1, IB, + $ DWORK(KW), INFO ) + IF( INFO .NE. 0 ) THEN + INFO = 2 + RETURN + END IF + NCUR = NCUR - IB1 + GO TO 40 + END IF +C +C END WHILE 40 +C + NMOVES = NMOVES - 1 + NCUR1 = NCUR1 + 1 + NLOW = NLOW + IB + GO TO 30 + END IF +C +C END WHILE 30 +C + ELSE + NLOW = NLOW + IB + END IF + END IF + END IF + END IF + IF( INFO.EQ.0 ) GO TO 20 +C +C END WHILE 20 +C + END IF +C + WRKOPT = MAX( WRKOPT, 5*M, 2*N + 4*M ) + END IF +C +C Annihilate the elements below the first subdiagonal of A. +C + IF( N .GT. 2) + $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) + IF( NAP .GT. 0 ) THEN +C +C Move the assigned eigenvalues in the first NAP positions of +C WR and WI. +C + K = IPC - NPR - 1 + IF( K .GT. 0 ) CALL DSWAP( K, WR(NPR+1), 1, WR, 1 ) + J = NAP - K + IF( J .GT. 0 ) THEN + CALL DSWAP( J, WR(IPC+NPC), 1, WR(K+1), 1 ) + CALL DSWAP( J, WI(IPC+NPC), 1, WI(K+1), 1 ) + END IF + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB01BD *** + END diff --git a/mex/sources/libslicot/SB01BX.f b/mex/sources/libslicot/SB01BX.f new file mode 100644 index 000000000..86812da08 --- /dev/null +++ b/mex/sources/libslicot/SB01BX.f @@ -0,0 +1,150 @@ + SUBROUTINE SB01BX( REIG, N, XR, XI, WR, WI, S, P ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To choose a real eigenvalue or a pair of complex conjugate +C eigenvalues at "minimal" distance to a given real or complex +C value. +C +C ARGUMENTS +C +C Mode Parameters +C +C REIG LOGICAL +C Specifies the type of eigenvalues as follows: +C = .TRUE., a real eigenvalue is to be selected; +C = .FALSE., a pair of complex eigenvalues is to be +C selected. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of eigenvalues contained in the arrays WR +C and WI. N >= 1. +C +C XR,XI (input) DOUBLE PRECISION +C If REIG = .TRUE., XR must contain the real value and XI +C is assumed zero and therefore not referenced. +C If REIG = .FALSE., XR must contain the real part and XI +C the imaginary part, respectively, of the complex value. +C +C WR,WI (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, if REIG = .TRUE., WR must contain the real +C eigenvalues from which an eigenvalue at minimal distance +C to XR is to be selected. In this case, WI is considered +C zero and therefore not referenced. +C On entry, if REIG = .FALSE., WR and WI must contain the +C real and imaginary parts, respectively, of the eigenvalues +C from which a pair of complex conjugate eigenvalues at +C minimal "distance" to XR + jXI is to be selected. +C The eigenvalues of each pair of complex conjugate +C eigenvalues must appear consecutively. +C On exit, the elements of these arrays are reordered such +C that the selected eigenvalue(s) is (are) found in the +C last element(s) of these arrays. +C +C S,P (output) DOUBLE PRECISION +C If REIG = .TRUE., S (and also P) contains the value of +C the selected real eigenvalue. +C If REIG = .FALSE., S and P contain the sum and product, +C respectively, of the selected complex conjugate pair of +C eigenvalues. +C +C FURTHER COMMENTS +C +C For efficiency reasons, |x| + |y| is used for a complex number +C x + jy, instead of its modulus. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C February 1999. Based on the RASP routine PMDIST. +C +C REVISIONS +C +C March 30, 1999, V. Sima, Research Institute for Informatics, +C Bucharest. +C Feb. 15, 2004, V. Sima, Research Institute for Informatics, +C Bucharest. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + LOGICAL REIG + INTEGER N + DOUBLE PRECISION P, S, XI ,XR +C .. Array Arguments .. + DOUBLE PRECISION WI(*), WR(*) +C .. Local Scalars .. + INTEGER I, J, K + DOUBLE PRECISION X, Y +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + J = 1 + IF( REIG ) THEN + Y = ABS( WR(1)-XR ) + DO 10 I = 2, N + X = ABS( WR(I)-XR ) + IF( X .LT. Y ) THEN + Y = X + J = I + END IF + 10 CONTINUE + S = WR(J) + K = N - J + IF( K .GT. 0 ) THEN + DO 20 I = J, J + K - 1 + WR(I) = WR(I+1) + 20 CONTINUE + WR(N) = S + END IF + P = S + ELSE + Y = ABS( WR(1)-XR ) + ABS( WI(1)-XI ) + DO 30 I = 3, N, 2 + X = ABS( WR(I)-XR ) + ABS( WI(I)-XI ) + IF( X .LT. Y ) THEN + Y = X + J = I + END IF + 30 CONTINUE + X = WR(J) + Y = WI(J) + K = N - J - 1 + IF( K .GT. 0 ) THEN + DO 40 I = J, J + K - 1 + WR(I) = WR(I+2) + WI(I) = WI(I+2) + 40 CONTINUE + WR(N-1) = X + WI(N-1) = Y + WR(N) = X + WI(N) = -Y + END IF + S = X + X + P = X * X + Y * Y + END IF +C + RETURN +C *** End of SB01BX *** + END diff --git a/mex/sources/libslicot/SB01BY.f b/mex/sources/libslicot/SB01BY.f new file mode 100644 index 000000000..58b480138 --- /dev/null +++ b/mex/sources/libslicot/SB01BY.f @@ -0,0 +1,332 @@ + SUBROUTINE SB01BY( N, M, S, P, A, B, F, TOL, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve an N-by-N pole placement problem for the simple cases +C N = 1 or N = 2: given the N-by-N matrix A and N-by-M matrix B, +C construct an M-by-N matrix F such that A + B*F has prescribed +C eigenvalues. These eigenvalues are specified by their sum S and +C product P (if N = 2). The resulting F has minimum Frobenius norm. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A and also the number of rows of +C the matrix B and the number of columns of the matrix F. +C N is either 1, if a single real eigenvalue is prescribed +C or 2, if a complex conjugate pair or a set of two real +C eigenvalues are prescribed. +C +C M (input) INTEGER +C The number of columns of the matrix B and also the number +C of rows of the matrix F. M >= 1. +C +C S (input) DOUBLE PRECISION +C The sum of the prescribed eigenvalues if N = 2 or the +C value of prescribed eigenvalue if N = 1. +C +C P (input) DOUBLE PRECISION +C The product of the prescribed eigenvalues if N = 2. +C Not referenced if N = 1. +C +C A (input/output) DOUBLE PRECISION array, dimension (N,N) +C On entry, this array must contain the N-by-N state +C dynamics matrix whose eigenvalues have to be moved to +C prescribed locations. +C On exit, this array contains no useful information. +C +C B (input/output) DOUBLE PRECISION array, dimension (N,M) +C On entry, this array must contain the N-by-M input/state +C matrix B. +C On exit, this array contains no useful information. +C +C F (output) DOUBLE PRECISION array, dimension (M,N) +C The state feedback matrix F which assigns one pole or two +C poles of the closed-loop matrix A + B*F. +C If N = 2 and the pair (A,B) is not controllable +C (INFO = 1), then F(1,1) and F(1,2) contain the elements of +C an orthogonal rotation which can be used to remove the +C uncontrollable part of the pair (A,B). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The absolute tolerance level below which the elements of A +C and B are considered zero (used for controllability test). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if uncontrollability of the pair (A,B) is detected. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine SB01BY. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C May 2003, A. Varga, German Aerospace Center. +C +C KEYWORDS +C +C Eigenvalue, eigenvalue assignment, feedback control, pole +C placement, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION FOUR, ONE, THREE, TWO, ZERO + PARAMETER ( FOUR = 4.0D0, ONE = 1.0D0, THREE = 3.0D0, + $ TWO = 2.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, M, N + DOUBLE PRECISION P, S, TOL +C .. Array Arguments .. + DOUBLE PRECISION A(N,*), B(N,*), DWORK(*), F(M,*) +C .. Local Scalars .. + INTEGER IR, J + DOUBLE PRECISION ABSR, B1, B2, B21, C, C0, C1, C11, C12, C21, + $ C22, C3, C4, CS, CU, CV, DC0, DC2, DC3, DIFFR, + $ R, RN, S12, S21, SIG, SN, SU, SV, TAU1, TAU2, + $ WI, WI1, WR, WR1, X, Y, Z +C .. External Functions .. + DOUBLE PRECISION DLAMC3, DLAMCH + EXTERNAL DLAMC3, DLAMCH +C .. External Subroutines .. + EXTERNAL DLANV2, DLARFG, DLASET, DLASV2, DLATZM, DROT +C .. Intrinsic Functions .. + INTRINSIC ABS, MIN +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked. +C + INFO = 0 + IF( N.EQ.1 ) THEN +C +C The case N = 1. +C + IF( M.GT.1 ) + $ CALL DLARFG( M, B(1,1), B(1,2), N, TAU1 ) + B1 = B(1,1) + IF( ABS( B1 ).LE.TOL ) THEN +C +C The pair (A,B) is uncontrollable. +C + INFO = 1 + RETURN + END IF +C + F(1,1) = ( S - A(1,1) )/B1 + IF( M.GT.1 ) THEN + CALL DLASET( 'Full', M-1, 1, ZERO, ZERO, F(2,1), M ) + CALL DLATZM( 'Left', M, N, B(1,2), N, TAU1, F(1,1), F(2,1), + $ M, DWORK ) + END IF + RETURN + END IF +C +C In the sequel N = 2. +C +C Compute the singular value decomposition of B in the form +C +C ( V 0 ) ( B1 0 ) +C B = U*( G1 0 )*( )*H2*H1 , G1 = ( ), +C ( 0 I ) ( 0 B2 ) +C +C ( CU SU ) ( CV SV ) +C where U = ( ) and V = ( ) are orthogonal +C (-SU CU ) (-SV CV ) +C +C rotations and H1 and H2 are elementary Householder reflectors. +C ABS(B1) and ABS(B2) are the singular values of matrix B, +C with ABS(B1) >= ABS(B2). +C +C Reduce first B to the lower bidiagonal form ( B1 0 ... 0 ). +C ( B21 B2 ... 0 ) + IF( M.EQ.1 ) THEN +C +C Initialization for the case M = 1; no reduction required. +C + B1 = B(1,1) + B21 = B(2,1) + B2 = ZERO + ELSE +C +C Postmultiply B with elementary Householder reflectors H1 +C and H2. +C + CALL DLARFG( M, B(1,1), B(1,2), N, TAU1 ) + CALL DLATZM( 'Right', N-1, M, B(1,2), N, TAU1, B(2,1), B(2,2), + $ N, DWORK ) + B1 = B(1,1) + B21 = B(2,1) + IF( M.GT.2 ) + $ CALL DLARFG( M-1, B(2,2), B(2,3), N, TAU2 ) + B2 = B(2,2) + END IF +C +C Reduce B to a diagonal form by premultiplying and postmultiplying +C it with orthogonal rotations U and V, respectively, and order the +C diagonal elements to have decreasing magnitudes. +C Note: B2 has been set to zero if M = 1. Thus in the following +C computations the case M = 1 need not to be distinguished. +C Note also that LAPACK routine DLASV2 assumes an upper triangular +C matrix, so the results should be adapted. +C + CALL DLASV2( B1, B21, B2, X, Y, SU, CU, SV, CV ) + SU = -SU + B1 = Y + B2 = X +C +C Compute A1 = U'*A*U. +C + CALL DROT( 2, A(2,1), 2, A(1,1), 2, CU, SU ) + CALL DROT( 2, A(1,2), 1, A(1,1), 1, CU, SU ) +C +C Compute the rank of B and check the controllability of the +C pair (A,B). +C + IR = 0 + IF( ABS( B2 ).GT.TOL ) IR = IR + 1 + IF( ABS( B1 ).GT.TOL ) IR = IR + 1 + IF( IR.EQ.0 .OR. ( IR.EQ.1 .AND. ABS( A(2,1) ).LE.TOL ) ) THEN + F(1,1) = CU + F(1,2) = -SU +C +C The pair (A,B) is uncontrollable. +C + INFO = 1 + RETURN + END IF +C +C Compute F1 which assigns N poles for the reduced pair (A1,G1). +C + X = DLAMC3( B1, B2 ) + IF( X.EQ.B1 ) THEN +C +C Rank one G1. +C + F(1,1) = ( S - ( A(1,1) + A(2,2) ) )/B1 + F(1,2) = -( A(2,2)*( A(2,2) - S ) + A(2,1)*A(1,2) + P )/ + $ A(2,1)/B1 + IF( M.GT.1 ) THEN + F(2,1) = ZERO + F(2,2) = ZERO + END IF + ELSE +C +C Rank two G1. +C + Z = ( S - ( A(1,1) + A(2,2) ) )/( B1*B1 + B2*B2 ) + F(1,1) = B1*Z + F(2,2) = B2*Z +C +C Compute an approximation for the minimum norm parameter +C selection. +C + X = A(1,1) + B1*F(1,1) + C = X*( S - X ) - P + IF( C.GE.ZERO ) THEN + SIG = ONE + ELSE + SIG = -ONE + END IF + S12 = B1/B2 + S21 = B2/B1 + C11 = ZERO + C12 = ONE + C21 = SIG*S12*C + C22 = A(1,2) - SIG*S12*A(2,1) + CALL DLANV2( C11, C12, C21, C22, WR, WI, WR1, WI1, CS, SN ) + IF( ABS( WR - A(1,2) ).GT.ABS( WR1 - A(1,2) ) ) THEN + R = WR1 + ELSE + R = WR + END IF +C +C Perform Newton iteration to solve the equation for minimum. +C + C0 = -C*C + C1 = C*A(2,1) + C4 = S21*S21 + C3 = -C4*A(1,2) + DC0 = C1 + DC2 = THREE*C3 + DC3 = FOUR*C4 +C + DO 10 J = 1, 10 + X = C0 + R*( C1 + R*R*( C3 + R*C4 ) ) + Y = DC0 + R*R*( DC2 + R*DC3 ) + IF( Y.EQ.ZERO ) GO TO 20 + RN = R - X/Y + ABSR = ABS( R ) + DIFFR = ABS( R - RN ) + Z = DLAMC3( ABSR, DIFFR ) + IF( Z.EQ.ABSR ) + $ GO TO 20 + R = RN + 10 CONTINUE +C + 20 CONTINUE + IF( R.EQ.ZERO ) R = DLAMCH( 'Epsilon' ) + F(1,2) = ( R - A(1,2) )/B1 + F(2,1) = ( C/R - A(2,1) )/B2 + END IF +C +C Back-transform F1. Compute first F1*U'. +C + CALL DROT( MIN( M, 2 ), F(1,1), 1, F(1,2), 1, CU, SU ) + IF( M.EQ.1 ) + $ RETURN +C +C Compute V'*F1. +C + CALL DROT( 2, F(2,1), M, F(1,1), M, CV, SV ) +C +C ( F1 ) +C Form F = ( ) . +C ( 0 ) +C + IF( M.GT.N ) + $ CALL DLASET( 'Full', M-N, N, ZERO, ZERO, F(N+1,1), M ) +C +C Compute H1*H2*F. +C + IF( M.GT.2 ) + $ CALL DLATZM( 'Left', M-1, N, B(2,3), N, TAU2, F(2,1), F(3,1), + $ M, DWORK ) + CALL DLATZM( 'Left', M, N, B(1,2), N, TAU1, F(1,1), F(2,1), M, + $ DWORK ) +C + RETURN +C *** Last line of SB01BY *** + END diff --git a/mex/sources/libslicot/SB01DD.f b/mex/sources/libslicot/SB01DD.f new file mode 100644 index 000000000..15ab1b8e9 --- /dev/null +++ b/mex/sources/libslicot/SB01DD.f @@ -0,0 +1,643 @@ + SUBROUTINE SB01DD( N, M, INDCON, A, LDA, B, LDB, NBLK, WR, WI, + $ Z, LDZ, Y, COUNT, G, LDG, TOL, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute for a controllable matrix pair ( A, B ) a matrix G +C such that the matrix A - B*G has the desired eigenstructure, +C specified by desired eigenvalues and free eigenvector elements. +C +C The pair ( A, B ) should be given in orthogonal canonical form +C as returned by the SLICOT Library routine AB01ND. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A and the number of rows of the +C matrix B. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrix B. M >= 0. +C +C INDCON (input) INTEGER +C The controllability index of the pair ( A, B ). +C 0 <= INDCON <= N. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the N-by-N matrix A in orthogonal canonical form, +C as returned by SLICOT Library routine AB01ND. +C On exit, the leading N-by-N part of this array contains +C the real Schur form of the matrix A - B*G. +C The elements below the real Schur form of A are set to +C zero. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the N-by-M matrix B in orthogonal canonical form, +C as returned by SLICOT Library routine AB01ND. +C On exit, the leading N-by-M part of this array contains +C the transformed matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C NBLK (input) INTEGER array, dimension (N) +C The leading INDCON elements of this array must contain the +C orders of the diagonal blocks in the orthogonal canonical +C form of A, as returned by SLICOT Library routine AB01ND. +C The values of these elements must satisfy the following +C conditions: +C NBLK(1) >= NBLK(2) >= ... >= NBLK(INDCON), +C NBLK(1) + NBLK(2) + ... + NBLK(INDCON) = N. +C +C WR (input) DOUBLE PRECISION array, dimension (N) +C WI (input) DOUBLE PRECISION array, dimension (N) +C These arrays must contain the real and imaginary parts, +C respectively, of the desired poles of the closed-loop +C system, i.e., the eigenvalues of A - B*G. The poles can be +C unordered, except that complex conjugate pairs of poles +C must appear consecutively. +C The elements of WI for complex eigenvalues are modified +C internally, but restored on exit. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C On entry, the leading N-by-N part of this array must +C contain the orthogonal matrix Z generated by SLICOT +C Library routine AB01ND in the reduction of ( A, B ) to +C orthogonal canonical form. +C On exit, the leading N-by-N part of this array contains +C the orthogonal transformation matrix which reduces A - B*G +C to real Schur form. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= max(1,N). +C +C Y (input) DOUBLE PRECISION array, dimension (M*N) +C Y contains elements which are used as free parameters +C in the eigenstructure design. The values of these +C parameters are often set by an external optimization +C procedure. +C +C COUNT (output) INTEGER +C The actual number of elements in Y used as free +C eigenvector and feedback matrix elements in the +C eigenstructure design. +C +C G (output) DOUBLE PRECISION array, dimension (LDG,N) +C The leading M-by-N part of this array contains the +C feedback matrix which assigns the desired eigenstructure +C of A - B*G. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= max(1,M). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determination when +C transforming (A, B). If the user sets TOL > 0, then +C the given value of TOL is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*N*EPS, is used instead, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(M*N,M*M+2*N+4*M+1). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the pair ( A, B ) is not controllable or the free +C parameters are not set appropriately. +C +C METHOD +C +C The routine implements the method proposed in [1], [2]. +C +C REFERENCES +C +C [1] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and +C Postlethwaite, I. +C Optimal pole assignment design of linear multi-input systems. +C Report 96-11, Department of Engineering, Leicester University, +C 1996. +C +C [2] Petkov, P.Hr., Christov, N.D. and Konstantinov, M.M. +C A computational algorithm for pole assignment of linear multi +C input systems. IEEE Trans. Automatic Control, vol. AC-31, +C pp. 1044-1047, 1986. +C +C NUMERICAL ASPECTS +C +C The method implemented is backward stable. +C +C FURTHER COMMENTS +C +C The eigenvalues of the real Schur form matrix As, returned in the +C array A, are very close to the desired eigenvalues WR+WI*i. +C However, the eigenvalues of the closed-loop matrix A - B*G, +C computed by the QR algorithm using the matrices A and B, given on +C entry, may be far from WR+WI*i, although the relative error +C norm( Z'*(A - B*G)*Z - As )/norm( As ) +C is close to machine accuracy. This may happen when the eigenvalue +C problem for the matrix A - B*G is ill-conditioned. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, Technical University of Sofia, Oct. 1998. +C V. Sima, Katholieke Universiteit Leuven, Jan. 1999, SLICOT Library +C version. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. +C +C KEYWORDS +C +C Closed loop spectrum, closed loop systems, eigenvalue assignment, +C orthogonal canonical form, orthogonal transformation, pole +C placement, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C +C .. Scalar Arguments .. + INTEGER COUNT, INDCON, INFO, LDA, LDB, LDG, LDWORK, + $ LDZ, M, N + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + INTEGER IWORK( * ), NBLK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), + $ G( LDG, * ), WI( * ), WR( * ), Y( * ), + $ Z( LDZ, * ) +C .. +C .. Local Scalars .. + LOGICAL COMPLX + INTEGER I, IA, INDCN1, INDCN2, INDCRT, IP, IRMX, IWRK, + $ K, KK, KMR, L, LP1, M1, MAXWRK, MI, MP1, MR, + $ MR1, NBLKCR, NC, NI, NJ, NP1, NR, NR1, RANK + DOUBLE PRECISION P, Q, R, S, SVLMAX, TOLDEF +C .. +C .. Local Arrays .. + DOUBLE PRECISION SVAL( 3 ) +C .. +C .. External Functions .. + DOUBLE PRECISION DASUM, DLAMCH, DLANGE, DLAPY2 + EXTERNAL DASUM, DLAMCH, DLANGE, DLAPY2 +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLACPY, DLARF, + $ DLARFG, DLARTG, DLASET, DROT, DSCAL, MB02QD, + $ XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input arguments. +C + INFO = 0 + NR = 0 + IWRK = MAX( M*N, M*M + 2*N + 4*M + 1 ) + DO 10 I = 1, MIN( INDCON, N ) + NR = NR + NBLK( I ) + IF( I.GT.1 ) THEN + IF( NBLK( I-1 ).LT.NBLK( I ) ) + $ INFO = -8 + END IF + 10 CONTINUE + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( INDCON.LT.0 .OR. INDCON.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( NR.NE.N ) THEN + INFO = -8 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDG.LT.MAX( 1, M ) ) THEN + INFO = -16 + ELSE IF( LDWORK.LT.IWRK ) THEN + INFO = -20 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB01DD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( M, N, INDCON ).EQ.0 ) THEN + COUNT = 0 + DWORK( 1 ) = ONE + RETURN + END IF +C + MAXWRK = IWRK + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance, based on machine precision. +C + TOLDEF = DBLE( N*N )*DLAMCH( 'EPSILON' ) + END IF +C + IRMX = 2*N + 1 + IWRK = IRMX + M*M + M1 = NBLK( 1 ) + COUNT = 1 + INDCRT = INDCON + NBLKCR = NBLK( INDCRT ) +C +C Compute the Frobenius norm of [ B A ] (used for rank estimation), +C taking into account the structure. +C + NR = M1 + NC = 1 + SVLMAX = DLANGE( 'Frobenius', M1, M, B, LDB, DWORK ) +C + DO 20 I = 1, INDCRT - 1 + NR = NR + NBLK( I+1 ) + SVLMAX = DLAPY2( SVLMAX, + $ DLANGE( 'Frobenius', NR, NBLK( I ), + $ A( 1, NC ), LDA, DWORK ) ) + NC = NC + NBLK( I ) + 20 CONTINUE +C + SVLMAX = DLAPY2( SVLMAX, + $ DLANGE( 'Frobenius', N, NBLKCR, A( 1, NC ), LDA, + $ DWORK ) ) + L = 1 + MR = NBLKCR + NR = N - MR + 1 + 30 CONTINUE +C WHILE( INDCRT.GT.1 )LOOP + IF( INDCRT.GT.1 ) THEN +C +C Assign next eigenvalue/eigenvector. +C + LP1 = L + M1 + INDCN1 = INDCRT - 1 + MR1 = NBLK( INDCN1 ) + NR1 = NR - MR1 + COMPLX = WI(L).NE.ZERO + CALL DCOPY( MR, Y( COUNT ), 1, DWORK( NR ), 1 ) + COUNT = COUNT + MR + NC = 1 + IF( COMPLX ) THEN + CALL DCOPY( MR, Y( COUNT ), 1, DWORK( N+NR ), 1 ) + COUNT = COUNT + MR + WI( L+1 ) = WI( L )*WI( L+1 ) + NC = 2 + END IF +C +C Compute and transform eiegenvector. +C + DO 50 IP = 1, INDCRT + IF( IP.NE.INDCRT ) THEN + CALL DLACPY( 'Full', MR, MR1, A( NR, NR1 ), LDA, + $ DWORK( IRMX ), M ) + IF( IP.EQ.1 ) THEN + MP1 = MR + NP1 = NR + MP1 + ELSE + MP1 = MR + 1 + NP1 = NR + MP1 + S = DASUM( MP1, DWORK( NR ), 1 ) + IF( COMPLX ) S = S + DASUM( MP1, DWORK( N+NR ), 1 ) + IF( S.NE.ZERO ) THEN +C +C Scale eigenvector elements. +C + CALL DSCAL( MP1, ONE/S, DWORK( NR ), 1 ) + IF( COMPLX ) THEN + CALL DSCAL( MP1, ONE/S, DWORK( N+NR ), 1 ) + IF( NP1.LE.N ) + $ DWORK( N+NP1 ) = DWORK( N+NP1 ) / S + END IF + END IF + END IF +C +C Compute the right-hand side of the eigenvector equations. +C + CALL DCOPY( MR, DWORK( NR ), 1, DWORK( NR1 ), 1 ) + CALL DSCAL( MR, WR( L ), DWORK( NR1 ), 1 ) + CALL DGEMV( 'No transpose', MR, MP1, -ONE, A( NR, NR ), + $ LDA, DWORK( NR ), 1, ONE, DWORK( NR1 ), 1 ) + IF( COMPLX ) THEN + CALL DAXPY( MR, WI( L+1 ), DWORK( N+NR ), 1, + $ DWORK( NR1 ), 1 ) + CALL DCOPY( MR, DWORK( NR ), 1, DWORK( N+NR1 ), 1 ) + CALL DAXPY( MR, WR( L+1 ), DWORK( N+NR ), 1, + $ DWORK( N+NR1 ), 1 ) + CALL DGEMV( 'No transpose', MR, MP1, -ONE, + $ A( NR, NR ), LDA, DWORK( N+NR ), 1, ONE, + $ DWORK( N+NR1 ), 1 ) + IF( NP1.LE.N ) + $ CALL DAXPY( MR, -DWORK( N+NP1 ), A( NR, NP1 ), 1, + $ DWORK( N+NR1 ), 1 ) + END IF +C +C Solve linear equations for eigenvector elements. +C + CALL MB02QD( 'FreeElements', 'NoPermuting', MR, MR1, NC, + $ TOLDEF, SVLMAX, DWORK( IRMX ), M, + $ DWORK( NR1 ), N, Y( COUNT ), IWORK, RANK, + $ SVAL, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 ) + IF( RANK.LT.MR ) GO TO 80 +C + COUNT = COUNT + ( MR1 - MR )*NC + NJ = NR1 + ELSE + NJ = NR + END IF + NI = NR + MR - 1 + IF( IP.EQ.1 ) THEN + KMR = MR - 1 + ELSE + KMR = MR + IF( IP.EQ.2 ) THEN + NI = NI + NBLKCR + ELSE + NI = NI + NBLK( INDCRT-IP+2 ) + 1 + IF( COMPLX ) NI = MIN( NI+1, N ) + END IF + END IF +C + DO 40 KK = 1, KMR + K = NR + MR - KK + IF( IP.EQ.1 ) K = N - KK + CALL DLARTG( DWORK( K ), DWORK( K+1 ), P, Q, R ) + DWORK( K ) = R + DWORK( K+1 ) = ZERO +C +C Transform A. +C + CALL DROT( N-NJ+1, A( K, NJ ), LDA, A( K+1, NJ ), LDA, + $ P, Q ) + CALL DROT( NI, A( 1, K ), 1, A( 1, K+1 ), 1, P, Q ) +C + IF( K.LT.LP1 ) THEN +C +C Transform B. +C + CALL DROT( M, B( K, 1 ), LDB, B( K+1, 1 ), LDB, P, Q ) + END IF +C +C Accumulate transformations. +C + CALL DROT( N, Z( 1, K ), 1, Z( 1, K+1 ), 1, P, Q ) +C + IF( COMPLX ) THEN + CALL DROT( 1, DWORK( N+K ), 1, DWORK( N+K+1 ), 1, P, + $ Q ) + K = K + 1 + IF( K.LT.N ) THEN + CALL DLARTG( DWORK( N+K ), DWORK( N+K+1 ), P, Q, + $ R ) + DWORK( N+K ) = R + DWORK( N+K+1 ) = ZERO +C +C Transform A. +C + CALL DROT( N-NJ+1, A( K, NJ ), LDA, A( K+1, NJ ), + $ LDA, P, Q ) + CALL DROT( NI, A( 1, K ), 1, A( 1, K+1 ), 1, P, Q ) +C + IF( K.LE.LP1 ) THEN +C +C Transform B. +C + CALL DROT( M, B( K, 1 ), LDB, B( K+1, 1 ), LDB, + $ P, Q ) + END IF +C +C Accumulate transformations. +C + CALL DROT( N, Z( 1, K ), 1, Z( 1, K+1 ), 1, P, Q ) +C + END IF + END IF + 40 CONTINUE +C + IF( IP.NE.INDCRT ) THEN + MR = MR1 + NR = NR1 + IF( IP.NE.INDCN1 ) THEN + INDCN2 = INDCRT - IP - 1 + MR1 = NBLK( INDCN2 ) + NR1 = NR1 - MR1 + END IF + END IF + 50 CONTINUE +C + IF( .NOT.COMPLX ) THEN +C +C Find one column of G. +C + CALL DLACPY( 'Full', M1, M, B( L+1, 1 ), LDB, DWORK( IRMX ), + $ M ) + CALL DCOPY( M1, A( L+1, L ), 1, G( 1, L ), 1 ) + ELSE +C +C Find two columns of G. +C + IF( LP1.LT.N ) THEN + LP1 = LP1 + 1 + K = L + 2 + ELSE + K = L + 1 + END IF + CALL DLACPY( 'Full', M1, M, B( K, 1 ), LDB, DWORK( IRMX ), + $ M ) + CALL DLACPY( 'Full', M1, 2, A( K, L ), LDA, G( 1, L ), LDG ) + IF( K.EQ.L+1 ) THEN + G( 1, L ) = G( 1, L ) - + $ ( DWORK( N+L+1 ) / DWORK( L ) )*WI( L+1 ) + G( 1, L+1 ) = G( 1, L+1 ) - WR(L+1) + + $ ( DWORK( N+L ) / DWORK( L ) )*WI( L+1 ) + END IF + END IF +C + CALL MB02QD( 'FreeElements', 'NoPermuting', M1, M, NC, TOLDEF, + $ SVLMAX, DWORK( IRMX ), M, G( 1, L ), LDG, + $ Y( COUNT ), IWORK, RANK, SVAL, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 ) + IF( RANK.LT.M1 ) GO TO 80 +C + COUNT = COUNT + ( M - M1 )*NC + CALL DGEMM( 'No transpose', 'No transpose', LP1, NC, M, -ONE, + $ B, LDB, G( 1, L ), LDG, ONE, A( 1, L ), LDA ) + L = L + 1 + NBLKCR = NBLKCR - 1 + IF( NBLKCR.EQ.0 ) THEN + INDCRT = INDCRT - 1 + NBLKCR = NBLK( INDCRT ) + END IF + IF( COMPLX ) THEN + WI( L ) = -WI( L-1 ) + L = L + 1 + NBLKCR = NBLKCR - 1 + IF( NBLKCR.EQ.0 ) THEN + INDCRT = INDCRT - 1 + IF( INDCRT.GT.0 ) NBLKCR = NBLK( INDCRT ) + END IF + END IF + MR = NBLKCR + NR = N - MR + 1 + GO TO 30 + END IF +C END WHILE 30 +C + IF( L.LE.N ) THEN +C +C Find the remaining columns of G. +C +C QR decomposition of the free eigenvectors. +C + DO 60 I = 1, MR - 1 + IA = L + I - 1 + MI = MR - I + 1 + CALL DCOPY( MI, Y( COUNT ), 1, DWORK( 1 ), 1 ) + COUNT = COUNT + MI + CALL DLARFG( MI, DWORK( 1 ), DWORK( 2 ), 1, R ) + DWORK( 1 ) = ONE +C +C Transform A. +C + CALL DLARF( 'Left', MI, MR, DWORK( 1 ), 1, R, A( IA, L ), + $ LDA, DWORK( N+1 ) ) + CALL DLARF( 'Right', N, MI, DWORK( 1 ), 1, R, A( 1, IA ), + $ LDA, DWORK( N+1 ) ) +C +C Transform B. +C + CALL DLARF( 'Left', MI, M, DWORK( 1 ), 1, R, B( IA, 1 ), + $ LDB, DWORK( N+1 ) ) +C +C Accumulate transformations. +C + CALL DLARF( 'Right', N, MI, DWORK( 1 ), 1, R, Z( 1, IA ), + $ LDZ, DWORK( N+1 ) ) + 60 CONTINUE +C + I = 0 +C REPEAT + 70 CONTINUE + I = I + 1 + IA = L + I - 1 + IF( WI( IA ).EQ.ZERO ) THEN + CALL DCOPY( MR, A( IA, L ), LDA, G( I, L ), LDG ) + CALL DAXPY( MR-I, -ONE, Y( COUNT ), 1, G( I, L+I ), LDG ) + COUNT = COUNT + MR - I + G( I, IA ) = G( I, IA ) - WR( IA ) + ELSE + CALL DLACPY( 'Full', 2, MR, A( IA, L ), LDA, G( I, L ), + $ LDG ) + CALL DAXPY( MR-I-1, -ONE, Y( COUNT ), 2, G( I, L+I+1 ), + $ LDG ) + CALL DAXPY( MR-I-1, -ONE, Y( COUNT+1 ), 2, + $ G( I+1, L+I+1 ), LDG ) + COUNT = COUNT + 2*( MR - I - 1 ) + G( I, IA ) = G(I, IA ) - WR( IA ) + G( I, IA+1 ) = G(I, IA+1 ) - WI( IA ) + G( I+1, IA ) = G(I+1, IA ) - WI( IA+1 ) + G( I+1, IA+1 ) = G(I+1, IA+1 ) - WR( IA+1 ) + I = I + 1 + END IF + IF( I.LT.MR ) GO TO 70 +C UNTIL I.GE.MR +C + CALL DLACPY( 'Full', MR, M, B( L, 1 ), LDB, DWORK( IRMX ), M ) + CALL MB02QD( 'FreeElements', 'NoPermuting', MR, M, MR, TOLDEF, + $ SVLMAX, DWORK( IRMX ), M, G( 1, L ), LDG, + $ Y( COUNT ), IWORK, RANK, SVAL, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 ) + IF( RANK.LT.MR ) GO TO 80 +C + COUNT = COUNT + ( M - MR )*MR + CALL DGEMM( 'No transpose', 'No transpose', N, MR, M, -ONE, B, + $ LDB, G( 1, L ), LDG, ONE, A( 1, L ), LDA ) + END IF +C +C Transform G: +C G := G * Z'. +C + CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE, G, LDG, + $ Z, LDZ, ZERO, DWORK( 1 ), M ) + CALL DLACPY( 'Full', M, N, DWORK( 1 ), M, G, LDG ) + COUNT = COUNT - 1 +C + IF( N.GT.2) THEN +C +C Set the elements of A below the Hessenberg part to zero. +C + CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A( 3, 1 ), LDA ) + END IF + DWORK( 1 ) = MAXWRK + RETURN +C +C Exit with INFO = 1 if the pair ( A, B ) is not controllable or +C the free parameters are not set appropriately. +C + 80 INFO = 1 + RETURN +C *** Last line of SB01DD *** + END diff --git a/mex/sources/libslicot/SB01FY.f b/mex/sources/libslicot/SB01FY.f new file mode 100644 index 000000000..20a716ba1 --- /dev/null +++ b/mex/sources/libslicot/SB01FY.f @@ -0,0 +1,315 @@ + SUBROUTINE SB01FY( DISCR, N, M, A, LDA, B, LDB, F, LDF, V, LDV, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the inner denominator of a right-coprime factorization +C of a system of order N, where N is either 1 or 2. Specifically, +C given the N-by-N unstable system state matrix A and the N-by-M +C system input matrix B, an M-by-N state-feedback matrix F and +C an M-by-M matrix V are constructed, such that the system +C (A + B*F, B*V, F, V) is inner. +C +C ARGUMENTS +C +C Mode Parameters +C +C DISCR LOGICAL +C Specifies the type of system as follows: +C = .FALSE.: continuous-time system; +C = .TRUE. : discrete-time system. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A and also the number of rows of +C the matrix B and the number of columns of the matrix F. +C N is either 1 or 2. +C +C M (input) INTEGER +C The number of columns of the matrices B and V, and also +C the number of rows of the matrix F. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A whose eigenvalues must have positive +C real parts if DISCR = .FALSE. or moduli greater than unity +C if DISCR = .TRUE.. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= N. +C +C F (output) DOUBLE PRECISION array, dimension (LDF,N) +C The leading M-by-N part of this array contains the state- +C feedback matrix F which assigns one eigenvalue (if N = 1) +C or two eigenvalues (if N = 2) of the matrix A + B*F in +C symmetric positions with respect to the imaginary axis +C (if DISCR = .FALSE.) or the unit circle (if +C DISCR = .TRUE.). +C +C LDF INTEGER +C The leading dimension of array F. LDF >= MAX(1,M). +C +C V (output) DOUBLE PRECISION array, dimension (LDV,M) +C The leading M-by-M upper triangular part of this array +C contains the input/output matrix V of the resulting inner +C system in upper triangular form. +C If DISCR = .FALSE., the resulting V is an identity matrix. +C +C LDV INTEGER +C The leading dimension of array V. LDF >= MAX(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if uncontrollability of the pair (A,B) is detected; +C = 2: if A is stable or at the stability limit; +C = 3: if N = 2 and A has a pair of real eigenvalues. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine RCFID2. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C Feb. 1999, A. Varga, DLR Oberpfaffenhofen. +C +C KEYWORDS +C +C Coprime factorization, eigenvalue, eigenvalue assignment, +C feedback control, pole placement, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TWO, ZERO + PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + LOGICAL DISCR + INTEGER INFO, LDA, LDB, LDF, LDV, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), F(LDF,*), V(LDV,*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION CS, R11, R12, R22, SCALE, SN, TEMP +C .. Local Arrays .. + DOUBLE PRECISION AT(2,2), DUMMY(2,2), U(2,2) +C .. External Functions .. + DOUBLE PRECISION DLAPY2, DLAPY3 + EXTERNAL DLAPY2, DLAPY3 +C .. External Subroutines .. + EXTERNAL DLARFG, DLASET, DLATZM, DROTG, DTRTRI, MA02AD, + $ MB04OX, SB03OY +C .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked. +C + INFO = 0 +C +C Compute an N-by-N upper triangular R such that R'*R = B*B' and +C find an upper triangular matrix U in the equation +C +C A'*U'*U + U'*U*A = R'*R if DISCR = .FALSE. or +C A'*U'*U*A - U'*U = R'*R if DISCR = .TRUE. . +C + CALL MA02AD( 'Full', N, M, B, LDB, F, LDF ) +C + IF( N.EQ.1 ) THEN +C +C The N = 1 case. +C + IF( M.GT.1 ) + $ CALL DLARFG( M, F(1,1), F(2,1), 1, TEMP ) + R11 = ABS( F(1,1) ) +C +C Make sure A is unstable or divergent and find U. +C + IF( DISCR ) THEN + TEMP = ABS( A(1,1) ) + IF( TEMP.LE.ONE ) THEN + INFO = 2 + RETURN + ELSE + TEMP = R11 / SQRT( ( TEMP - ONE )*( TEMP + ONE ) ) + END IF + ELSE + IF( A(1,1).LE.ZERO ) THEN + INFO = 2 + RETURN + ELSE + TEMP = R11 / SQRT( ABS( TWO*A(1,1) ) ) + END IF + END IF + U(1,1) = TEMP + SCALE = ONE + ELSE +C +C The N = 2 case. +C + IF( M.GT.1 ) THEN + CALL DLARFG( M, F(1,1), F(2,1), 1, TEMP ) + CALL DLATZM( 'Left', M, N-1, F(2,1), 1, TEMP, F(1,2), + $ F(2,2), LDF, V ) + END IF + R11 = F(1,1) + R12 = F(1,2) + IF( M.GT.2 ) + $ CALL DLARFG( M-1, F(2,2), F(3,2), 1, TEMP ) + IF( M.EQ.1 ) THEN + R22 = ZERO + ELSE + R22 = F(2,2) + END IF + AT(1,1) = A(1,1) + AT(1,2) = A(2,1) + AT(2,1) = A(1,2) + AT(2,2) = A(2,2) + U(1,1) = R11 + U(1,2) = R12 + U(2,2) = R22 + CALL SB03OY( DISCR, .FALSE., -1, AT, 2, U, 2, DUMMY, 2, + $ SCALE, INFO ) + IF( INFO.NE.0 ) THEN + IF( INFO.NE.4 ) THEN + INFO = 2 + ELSE + INFO = 3 + END IF + RETURN + END IF + END IF +C +C Check the controllability of the pair (A,B). +C +C Warning. Only an exact controllability check is performed. +C If the pair (A,B) is nearly uncontrollable, then +C the computed results may be inaccurate. +C + DO 10 I = 1, N + IF( U(I,I).EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF + 10 CONTINUE +C +C Set V = I. +C + CALL DLASET( 'Upper', M, M, ZERO, ONE, V, LDV ) +C + IF( DISCR ) THEN +C +C Compute an upper triangular matrix V such that +C -1 +C V*V' = (I+B'*inv(U'*U)*B) . +C +C First compute F = B'*inv(U) and the Cholesky factorization +C of I + F*F'. +C + DO 20 I = 1, M + F(I,1) = B(1,I)/U(1,1)*SCALE + 20 CONTINUE + IF( N.EQ.2 ) THEN + DO 30 I = 1, M + F(I,2) = ( B(2,I) - F(I,1)*U(1,2) )/U(2,2)*SCALE + 30 CONTINUE + CALL MB04OX( M, V, LDV, F(1,2), 1 ) + END IF + CALL MB04OX( M, V, LDV, F(1,1), 1 ) + CALL DTRTRI( 'Upper', 'NonUnit', M, V, LDV, INFO ) + END IF +C +C Compute the feedback matrix F as: +C +C 1) If DISCR = .FALSE. +C +C F = -B'*inv(U'*U); +C +C 2) If DISCR = .TRUE. +C -1 +C F = -B'*(U'*U+B*B') *A. +C + IF( N.EQ.1 ) THEN + IF( DISCR ) THEN + TEMP = -A(1,1) + R11 = DLAPY2( U(1,1), R11 ) + DO 40 I = 1, M + F(I,1) = ( ( B(1,I)/R11 )/R11 )*TEMP + 40 CONTINUE + ELSE + R11 = U(1,1) + DO 50 I = 1, M + F(I,1) = -( ( B(1,I)/R11 )/R11 ) + 50 CONTINUE + END IF + ELSE +C +C Set R = U if DISCR = .FALSE. or compute the Cholesky +C factorization of R'*R = U'*U+B*B' if DISCR = .TRUE.. +C + IF( DISCR ) THEN + TEMP = U(1,1) + CALL DROTG( R11, TEMP, CS, SN ) + TEMP = -SN*R12 + CS*U(1,2) + R12 = CS*R12 + SN*U(1,2) + R22 = DLAPY3( R22, TEMP, U(2,2) ) + ELSE + R11 = U(1,1) + R12 = U(1,2) + R22 = U(2,2) + END IF +C +C Compute F = -B'*inv(R'*R). +C + DO 60 I = 1, M + F(I,1) = -B(1,I)/R11 + F(I,2) = -( B(2,I) + F(I,1)*R12 )/R22 + F(I,2) = F(I,2)/R22 + F(I,1) = ( F(I,1) - F(I,2)*R12 )/R11 + 60 CONTINUE + IF( DISCR ) THEN +C +C Compute F <-- F*A. +C + DO 70 I = 1, M + TEMP = F(I,1)*A(1,1) + F(I,2)*A(2,1) + F(I,2) = F(I,1)*A(1,2) + F(I,2)*A(2,2) + F(I,1) = TEMP + 70 CONTINUE + END IF + END IF +C + RETURN +C *** Last line of SB01FY *** + END diff --git a/mex/sources/libslicot/SB01MD.f b/mex/sources/libslicot/SB01MD.f new file mode 100644 index 000000000..cc6abc4d8 --- /dev/null +++ b/mex/sources/libslicot/SB01MD.f @@ -0,0 +1,397 @@ + SUBROUTINE SB01MD( NCONT, N, A, LDA, B, WR, WI, Z, LDZ, G, DWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine the one-dimensional state feedback matrix G of the +C linear time-invariant single-input system +C +C dX/dt = A * X + B * U, +C +C where A is an NCONT-by-NCONT matrix and B is an NCONT element +C vector such that the closed-loop system +C +C dX/dt = (A - B * G) * X +C +C has desired poles. The system must be preliminarily reduced +C to orthogonal canonical form using the SLICOT Library routine +C AB01MD. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NCONT (input) INTEGER +C The order of the matrix A as produced by SLICOT Library +C routine AB01MD. NCONT >= 0. +C +C N (input) INTEGER +C The order of the matrix Z. N >= NCONT. +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA,NCONT) +C On entry, the leading NCONT-by-NCONT part of this array +C must contain the canonical form of the state dynamics +C matrix A as produced by SLICOT Library routine AB01MD. +C On exit, the leading NCONT-by-NCONT part of this array +C contains the upper quasi-triangular form S of the closed- +C loop system matrix (A - B * G), that is triangular except +C for possible 2-by-2 diagonal blocks. +C (To reconstruct the closed-loop system matrix see +C FURTHER COMMENTS below.) +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,NCONT). +C +C B (input/output) DOUBLE PRECISION array, dimension (NCONT) +C On entry, this array must contain the canonical form of +C the input/state vector B as produced by SLICOT Library +C routine AB01MD. +C On exit, this array contains the transformed vector Z * B +C of the closed-loop system. +C +C WR (input) DOUBLE PRECISION array, dimension (NCONT) +C WI (input) DOUBLE PRECISION array, dimension (NCONT) +C These arrays must contain the real and imaginary parts, +C respectively, of the desired poles of the closed-loop +C system. The poles can be unordered, except that complex +C conjugate pairs of poles must appear consecutively. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C On entry, the leading N-by-N part of this array must +C contain the orthogonal transformation matrix as produced +C by SLICOT Library routine AB01MD, which reduces the system +C to canonical form. +C On exit, the leading NCONT-by-NCONT part of this array +C contains the orthogonal matrix Z which reduces the closed- +C loop system matrix (A - B * G) to upper quasi-triangular +C form. +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= MAX(1,N). +C +C G (output) DOUBLE PRECISION array, dimension (NCONT) +C This array contains the one-dimensional state feedback +C matrix G of the original system. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (3*NCONT) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The method is based on the orthogonal reduction of the closed-loop +C system matrix (A - B * G) to upper quasi-triangular form S whose +C 1-by-1 and 2-by-2 diagonal blocks correspond to the desired poles. +C That is, S = Z'*(A - B * G)*Z, where Z is an orthogonal matrix. +C +C REFERENCES +C +C [1] Petkov, P. Hr. +C A Computational Algorithm for Pole Assignment of Linear +C Single Input Systems. +C Internal Report 81/2, Control Systems Research Group, School +C of Electronic Engineering and Computer Science, Kingston +C Polytechnic, 1981. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(NCONT ) operations and is backward +C stable. +C +C FURTHER COMMENTS +C +C If required, the closed-loop system matrix (A - B * G) can be +C formed from the matrix product Z * S * Z' (where S and Z are the +C matrices output in arrays A and Z respectively). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB01AD by Control Systems Research +C Group, Kingston Polytechnic, United Kingdom, May 1981. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Closed loop spectrum, closed loop systems, eigenvalue assignment, +C orthogonal canonical form, orthogonal transformation, pole +C placement, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDZ, N, NCONT +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(*), DWORK(*), G(*), WI(*), WR(*), + $ Z(LDZ,*) +C .. Local Scalars .. + LOGICAL COMPL + INTEGER I, IM1, K, L, LL, LP1, NCONT2, NI, NJ, NL + DOUBLE PRECISION B1, P, Q, R, S, T +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DLARTG, DLASET, DROT, + $ DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( NCONT.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.NCONT ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, NCONT ) ) THEN + INFO = -4 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return +C + CALL XERBLA( 'SB01MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( NCONT.EQ.0 .OR. N.EQ.0 ) + $ RETURN +C +C Return if the system is not complete controllable. +C + IF ( B(1).EQ.ZERO ) + $ RETURN +C + IF ( NCONT.EQ.1 ) THEN +C +C 1-by-1 case. +C + P = A(1,1) - WR(1) + A(1,1) = WR(1) + G(1) = P/B(1) + Z(1,1) = ONE + RETURN + END IF +C +C General case. Save the contents of WI in DWORK. +C + NCONT2 = 2*NCONT + CALL DCOPY( NCONT, WI, 1, DWORK(NCONT2+1), 1 ) +C + B1 = B(1) + B(1) = ONE + L = 0 + LL = 0 + 20 CONTINUE + L = L + 1 + LL = LL + 1 + COMPL = DWORK(NCONT2+L).NE.ZERO + IF ( L.NE.NCONT ) THEN + LP1 = L + 1 + NL = NCONT - L + IF ( LL.NE.2 ) THEN + IF ( COMPL ) THEN +C +C Compute complex eigenvector. +C + DWORK(NCONT) = ONE + DWORK(NCONT2) = ONE + P = WR(L) + T = DWORK(NCONT2+L) + Q = T*DWORK(NCONT2+LP1) + DWORK(NCONT2+L) = ONE + DWORK(NCONT2+LP1) = Q +C + DO 40 I = NCONT, LP1, -1 + IM1 = I - 1 + DWORK(IM1) = ( P*DWORK(I) + Q*DWORK(NCONT+I) - + $ DDOT( NCONT-IM1, A(I,I), LDA, DWORK(I), 1 ) ) + $ /A(I,IM1) + DWORK(NCONT+IM1) = ( P*DWORK(NCONT+I) + DWORK(I) - + $ DDOT( NCONT-IM1, A(I,I), LDA, DWORK(NCONT+I), 1 ) ) + $ /A(I,IM1) + 40 CONTINUE +C + ELSE +C +C Compute real eigenvector. +C + DWORK(NCONT) = ONE + P = WR(L) +C + DO 60 I = NCONT, LP1, -1 + IM1 = I - 1 + DWORK(IM1) = ( P*DWORK(I) - + $ DDOT( NCONT-IM1, A(I,I), LDA, DWORK(I), 1 ) ) + $ /A(I,IM1) + 60 CONTINUE +C + END IF + END IF +C +C Transform eigenvector. +C + DO 80 K = NCONT - 1, L, -1 + IF ( LL.NE.2 ) THEN + R = DWORK(K) + S = DWORK(K+1) + ELSE + R = DWORK(NCONT+K) + S = DWORK(NCONT+K+1) + END IF + CALL DLARTG( R, S, P, Q, T ) + DWORK(K) = T + IF ( LL.NE.2 ) THEN + NJ = MAX( K-1, L ) + ELSE + DWORK(NCONT+K) = T + NJ = L - 1 + END IF +C +C Transform A. +C + CALL DROT( NCONT-NJ+1, A(K,NJ), LDA, A(K+1,NJ), LDA, P, Q ) +C + IF ( COMPL .AND. LL.EQ.1 ) THEN + NI = NCONT + ELSE + NI = MIN( K+2, NCONT ) + END IF + CALL DROT( NI, A(1,K), 1, A(1,K+1), 1, P, Q ) +C + IF ( K.EQ.L ) THEN +C +C Transform B. +C + T = B(K) + B(K) = P*T + B(K+1) = -Q*T + END IF +C +C Accumulate transformations. +C + CALL DROT( NCONT, Z(1,K), 1, Z(1,K+1), 1, P, Q ) +C + IF ( COMPL .AND. LL.NE.2 ) THEN + T = DWORK(NCONT+K) + DWORK(NCONT+K) = P*T + Q*DWORK(NCONT+K+1) + DWORK(NCONT+K+1) = P*DWORK(NCONT+K+1) - Q*T + END IF + 80 CONTINUE +C + END IF +C + IF ( .NOT.COMPL ) THEN +C +C Find one element of G. +C + K = L + R = B(L) + IF ( L.NE.NCONT ) THEN + IF ( ABS( B(LP1) ).GT.ABS( B(L) ) ) THEN + K = LP1 + R = B(LP1) + END IF + END IF + P = A(K,L) + IF ( K.EQ.L ) P = P - WR(L) + P = P/R +C + CALL DAXPY( LP1, -P, B, 1, A(1,L), 1 ) +C + G(L) = P/B1 + IF ( L.NE.NCONT ) THEN + LL = 0 + GO TO 20 + END IF + ELSE IF ( LL.EQ.1 ) THEN + GO TO 20 + ELSE +C +C Find two elements of G. +C + K = L + R = B(L) + IF ( L.NE.NCONT ) THEN + IF ( ABS( B(LP1)).GT.ABS( B(L) ) ) THEN + K = LP1 + R = B(LP1) + END IF + END IF + P = A(K,L-1) + Q = A(K,L) + IF ( K.EQ.L ) THEN + P = P - ( DWORK(NCONT+L)/DWORK(L-1) )*DWORK(NCONT2+L) + Q = Q - WR(L) + + $ ( DWORK(NCONT+L-1)/DWORK(L-1) )*DWORK(NCONT2+L) + END IF + P = P/R + Q = Q/R +C + CALL DAXPY( LP1, -P, B, 1, A(1,L-1), 1 ) + CALL DAXPY( LP1, -Q, B, 1, A(1,L), 1 ) +C + G(L-1) = P/B1 + G(L) = Q/B1 + IF ( L.NE.NCONT ) THEN + LL = 0 + GO TO 20 + END IF + END IF +C +C Transform G. +C + CALL DGEMV( 'No transpose', NCONT, NCONT, ONE, Z, LDZ, G, 1, + $ ZERO, DWORK, 1 ) + CALL DCOPY( NCONT, DWORK, 1, G, 1 ) + CALL DSCAL( NCONT, B1, B, 1 ) +C +C Annihilate A after the first subdiagonal. +C + IF ( NCONT.GT.2 ) + $ CALL DLASET( 'Lower', NCONT-2, NCONT-2, ZERO, ZERO, A(3,1), + $ LDA ) +C + RETURN +C *** Last line of SB01MD *** + END diff --git a/mex/sources/libslicot/SB02CX.f b/mex/sources/libslicot/SB02CX.f new file mode 100644 index 000000000..d84f72178 --- /dev/null +++ b/mex/sources/libslicot/SB02CX.f @@ -0,0 +1,94 @@ + LOGICAL FUNCTION SB02CX( REIG, IEIG ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To select the purely imaginary eigenvalues in computing the +C H-infinity norm of a system. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C REIG (input) DOUBLE PRECISION +C The real part of the current eigenvalue considered. +C +C IEIG (input) DOUBLE PRECISION +C The imaginary part of the current eigenvalue considered. +C +C METHOD +C +C The function value SB02CX is set to .TRUE. for a purely imaginary +C eigenvalue and to .FALSE., otherwise. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C P. Hr. Petkov, Technical University of Sofia, May, 1999. +C +C REVISIONS +C +C P. Hr. Petkov, Technical University of Sofia, Oct. 2000. +C +C KEYWORDS +C +C H-infinity norm, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION HUNDRD + PARAMETER ( HUNDRD = 100.0D+0 ) +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION IEIG, REIG +C .. +C .. Local Scalars .. + DOUBLE PRECISION EPS, TOL +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. +C .. Executable Statements .. +C +C Get the machine precision. +C + EPS = DLAMCH( 'Epsilon' ) +C +C Set the tolerance in the determination of the purely +C imaginary eigenvalues. +C + TOL = HUNDRD*EPS + SB02CX = ABS( REIG ).LT.TOL +C + RETURN +C *** Last line of SB02CX *** + END diff --git a/mex/sources/libslicot/SB02MD.f b/mex/sources/libslicot/SB02MD.f new file mode 100644 index 000000000..4e517d346 --- /dev/null +++ b/mex/sources/libslicot/SB02MD.f @@ -0,0 +1,559 @@ + SUBROUTINE SB02MD( DICO, HINV, UPLO, SCAL, SORT, N, A, LDA, G, + $ LDG, Q, LDQ, RCOND, WR, WI, S, LDS, U, LDU, + $ IWORK, DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X either the continuous-time algebraic Riccati +C equation +C -1 +C Q + A'*X + X*A - X*B*R B'*X = 0 (1) +C +C or the discrete-time algebraic Riccati equation +C -1 +C X = A'*X*A - A'*X*B*(R + B'*X*B) B'*X*A + Q (2) +C +C where A, B, Q and R are N-by-N, N-by-M, N-by-N and M-by-M matrices +C respectively, with Q symmetric and R symmetric nonsingular; X is +C an N-by-N symmetric matrix. +C -1 +C The matrix G = B*R B' must be provided on input, instead of B and +C R, that is, for instance, the continuous-time equation +C +C Q + A'*X + X*A - X*G*X = 0 (3) +C +C is solved, where G is an N-by-N symmetric matrix. SLICOT Library +C routine SB02MT should be used to compute G, given B and R. SB02MT +C also enables to solve Riccati equations corresponding to optimal +C problems with coupling terms. +C +C The routine also returns the computed values of the closed-loop +C spectrum of the optimal system, i.e., the stable eigenvalues +C lambda(1),...,lambda(N) of the corresponding Hamiltonian or +C symplectic matrix associated to the optimal problem. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of Riccati equation to be solved as +C follows: +C = 'C': Equation (3), continuous-time case; +C = 'D': Equation (2), discrete-time case. +C +C HINV CHARACTER*1 +C If DICO = 'D', specifies which symplectic matrix is to be +C constructed, as follows: +C = 'D': The matrix H in (5) (see METHOD) is constructed; +C = 'I': The inverse of the matrix H in (5) is constructed. +C HINV is not used if DICO = 'C'. +C +C UPLO CHARACTER*1 +C Specifies which triangle of the matrices G and Q is +C stored, as follows: +C = 'U': Upper triangle is stored; +C = 'L': Lower triangle is stored. +C +C SCAL CHARACTER*1 +C Specifies whether or not a scaling strategy should be +C used, as follows: +C = 'G': General scaling should be used; +C = 'N': No scaling should be used. +C +C SORT CHARACTER*1 +C Specifies which eigenvalues should be obtained in the top +C of the Schur form, as follows: +C = 'S': Stable eigenvalues come first; +C = 'U': Unstable eigenvalues come first. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, Q, G and X. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the coefficient matrix A of the equation. +C On exit, if DICO = 'D', and INFO = 0 or INFO > 1, the +C -1 +C leading N-by-N part of this array contains the matrix A . +C Otherwise, the array A is unchanged on exit. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C G (input) DOUBLE PRECISION array, dimension (LDG,N) +C The leading N-by-N upper triangular part (if UPLO = 'U') +C or lower triangular part (if UPLO = 'L') of this array +C must contain the upper triangular part or lower triangular +C part, respectively, of the symmetric matrix G. The stricly +C lower triangular part (if UPLO = 'U') or stricly upper +C triangular part (if UPLO = 'L') is not referenced. +C +C LDG INTEGER +C The leading dimension of array G. LDG >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, the leading N-by-N upper triangular part (if +C UPLO = 'U') or lower triangular part (if UPLO = 'L') of +C this array must contain the upper triangular part or lower +C triangular part, respectively, of the symmetric matrix Q. +C The stricly lower triangular part (if UPLO = 'U') or +C stricly upper triangular part (if UPLO = 'L') is not used. +C On exit, if INFO = 0, the leading N-by-N part of this +C array contains the solution matrix X of the problem. +C +C LDQ INTEGER +C The leading dimension of array N. LDQ >= MAX(1,N). +C +C RCOND (output) DOUBLE PRECISION +C An estimate of the reciprocal of the condition number (in +C the 1-norm) of the N-th order system of algebraic +C equations from which the solution matrix X is obtained. +C +C WR (output) DOUBLE PRECISION array, dimension (2*N) +C WI (output) DOUBLE PRECISION array, dimension (2*N) +C If INFO = 0 or INFO = 5, these arrays contain the real and +C imaginary parts, respectively, of the eigenvalues of the +C 2N-by-2N matrix S, ordered as specified by SORT (except +C for the case HINV = 'D', when the order is opposite to +C that specified by SORT). The leading N elements of these +C arrays contain the closed-loop spectrum of the system +C -1 +C matrix A - B*R *B'*X, if DICO = 'C', or of the matrix +C -1 +C A - B*(R + B'*X*B) B'*X*A, if DICO = 'D'. Specifically, +C lambda(k) = WR(k) + j*WI(k), for k = 1,2,...,N. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) +C If INFO = 0 or INFO = 5, the leading 2N-by-2N part of this +C array contains the ordered real Schur form S of the +C Hamiltonian or symplectic matrix H. That is, +C +C (S S ) +C ( 11 12) +C S = ( ), +C (0 S ) +C ( 22) +C +C where S , S and S are N-by-N matrices. +C 11 12 22 +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,2*N). +C +C U (output) DOUBLE PRECISION array, dimension (LDU,2*N) +C If INFO = 0 or INFO = 5, the leading 2N-by-2N part of this +C array contains the transformation matrix U which reduces +C the Hamiltonian or symplectic matrix H to the ordered real +C Schur form S. That is, +C +C (U U ) +C ( 11 12) +C U = ( ), +C (U U ) +C ( 21 22) +C +C where U , U , U and U are N-by-N matrices. +C 11 12 21 22 +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,2*N). +C +C Workspace +C +C IWORK INTEGER array, dimension (2*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK and DWORK(2) returns the scaling factor used +C (set to 1 if SCAL = 'N'), also set if INFO = 5; +C if DICO = 'D', DWORK(3) returns the reciprocal condition +C number of the given matrix A. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(2,6*N) if DICO = 'C'; +C LDWORK >= MAX(3,6*N) if DICO = 'D'. +C For optimum performance LDWORK should be larger. +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if matrix A is (numerically) singular in discrete- +C time case; +C = 2: if the Hamiltonian or symplectic matrix H cannot be +C reduced to real Schur form; +C = 3: if the real Schur form of the Hamiltonian or +C symplectic matrix H cannot be appropriately ordered; +C = 4: if the Hamiltonian or symplectic matrix H has less +C than N stable eigenvalues; +C = 5: if the N-th order system of linear algebraic +C equations, from which the solution matrix X would +C be obtained, is singular to working precision. +C +C METHOD +C +C The method used is the Schur vector approach proposed by Laub. +C It is assumed that [A,B] is a stabilizable pair (where for (3) B +C is any matrix such that B*B' = G with rank(B) = rank(G)), and +C [E,A] is a detectable pair, where E is any matrix such that +C E*E' = Q with rank(E) = rank(Q). Under these assumptions, any of +C the algebraic Riccati equations (1)-(3) is known to have a unique +C non-negative definite solution. See [2]. +C Now consider the 2N-by-2N Hamiltonian or symplectic matrix +C +C ( A -G ) +C H = ( ), (4) +C (-Q -A'), +C +C for continuous-time equation, and +C -1 -1 +C ( A A *G ) +C H = ( -1 -1 ), (5) +C (Q*A A' + Q*A *G) +C -1 +C for discrete-time equation, respectively, where G = B*R *B'. +C The assumptions guarantee that H in (4) has no pure imaginary +C eigenvalues, and H in (5) has no eigenvalues on the unit circle. +C If Y is an N-by-N matrix then there exists an orthogonal matrix U +C such that U'*Y*U is an upper quasi-triangular matrix. Moreover, U +C can be chosen so that the 2-by-2 and 1-by-1 diagonal blocks +C (corresponding to the complex conjugate eigenvalues and real +C eigenvalues respectively) appear in any desired order. This is the +C ordered real Schur form. Thus, we can find an orthogonal +C similarity transformation U which puts (4) or (5) in ordered real +C Schur form +C +C U'*H*U = S = (S(1,1) S(1,2)) +C ( 0 S(2,2)) +C +C where S(i,j) is an N-by-N matrix and the eigenvalues of S(1,1) +C have negative real parts in case of (4), or moduli greater than +C one in case of (5). If U is conformably partitioned into four +C N-by-N blocks +C +C U = (U(1,1) U(1,2)) +C (U(2,1) U(2,2)) +C +C with respect to the assumptions we then have +C (a) U(1,1) is invertible and X = U(2,1)*inv(U(1,1)) solves (1), +C (2), or (3) with X = X' and non-negative definite; +C (b) the eigenvalues of S(1,1) (if DICO = 'C') or S(2,2) (if +C DICO = 'D') are equal to the eigenvalues of optimal system +C (the 'closed-loop' spectrum). +C +C [A,B] is stabilizable if there exists a matrix F such that (A-BF) +C is stable. [E,A] is detectable if [A',E'] is stabilizable. +C +C REFERENCES +C +C [1] Laub, A.J. +C A Schur Method for Solving Algebraic Riccati equations. +C IEEE Trans. Auto. Contr., AC-24, pp. 913-921, 1979. +C +C [2] Wonham, W.M. +C On a matrix Riccati equation of stochastic control. +C SIAM J. Contr., 6, pp. 681-697, 1968. +C +C [3] Sima, V. +C Algorithms for Linear-Quadratic Optimization. +C Pure and Applied Mathematics: A Series of Monographs and +C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C FURTHER COMMENTS +C +C To obtain a stabilizing solution of the algebraic Riccati +C equation for DICO = 'D', set SORT = 'U', if HINV = 'D', or set +C SORT = 'S', if HINV = 'I'. +C +C The routine can also compute the anti-stabilizing solutions of +C the algebraic Riccati equations, by specifying +C SORT = 'U' if DICO = 'D' and HINV = 'I', or DICO = 'C', or +C SORT = 'S' if DICO = 'D' and HINV = 'D'. +C +C Usually, the combinations HINV = 'D' and SORT = 'U', or HINV = 'I' +C and SORT = 'U', will be faster then the other combinations [3]. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB02AD by Control Systems Research +C Group, Kingston Polytechnic, United Kingdom, March 1982. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2002. +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, discrete-time system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, HINV, SCAL, SORT, UPLO + INTEGER INFO, LDA, LDG, LDQ, LDS, LDU, LDWORK, N + DOUBLE PRECISION RCOND +C .. Array Arguments .. + LOGICAL BWORK(*) + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), + $ S(LDS,*), U(LDU,*), WR(*), WI(*) +C .. Local Scalars .. + LOGICAL DISCR, LHINV, LSCAL, LSORT, LUPLO + INTEGER I, IERR, ISCL, N2, NP1, NROT + DOUBLE PRECISION GNORM, QNORM, RCONDA, UNORM, WRKOPT +C .. External Functions .. + LOGICAL LSAME, SB02MR, SB02MS, SB02MV, SB02MW + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02MR, SB02MS, + $ SB02MV, SB02MW +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGECON, DGEES, DGETRF, DGETRS, + $ DLACPY, DLASCL, DLASET, DSCAL, DSWAP, SB02MU, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + INFO = 0 + N2 = N + N + NP1 = N + 1 + DISCR = LSAME( DICO, 'D' ) + LSCAL = LSAME( SCAL, 'G' ) + LSORT = LSAME( SORT, 'S' ) + LUPLO = LSAME( UPLO, 'U' ) + IF ( DISCR ) LHINV = LSAME( HINV, 'D' ) +C +C Test the input scalar arguments. +C + IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN + INFO = -1 + ELSE IF( DISCR ) THEN + IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) ) + $ INFO = -2 + END IF + IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -3 + ELSE IF( .NOT.LSCAL .AND. .NOT.LSAME( SCAL, 'N' ) ) THEN + INFO = -4 + ELSE IF( .NOT.LSORT .AND. .NOT.LSAME( SORT, 'U' ) ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDG.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN + INFO = -17 + ELSE IF( LDU.LT.MAX( 1, N2 ) ) THEN + INFO = -19 + ELSE IF( ( .NOT.DISCR .AND. LDWORK.LT.MAX( 2, 6*N ) ) .OR. + $ ( DISCR .AND. LDWORK.LT.MAX( 3, 6*N ) ) ) THEN + INFO = -22 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB02MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + RCOND = ONE + DWORK(1) = ONE + DWORK(2) = ONE + IF ( DISCR ) DWORK(3) = ONE + RETURN + END IF +C + IF ( LSCAL ) THEN +C +C Compute the norms of the matrices Q and G. +C + QNORM = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) + GNORM = DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) + END IF +C +C Initialise the Hamiltonian or symplectic matrix associated with +C the problem. +C Workspace: need 1 if DICO = 'C'; +C max(2,4*N) if DICO = 'D'; +C prefer larger if DICO = 'D'. +C + CALL SB02MU( DICO, HINV, UPLO, N, A, LDA, G, LDG, Q, LDQ, S, LDS, + $ IWORK, DWORK, LDWORK, INFO ) + IF ( INFO.NE.0 ) THEN + INFO = 1 + RETURN + END IF +C + WRKOPT = DWORK(1) + IF ( DISCR ) RCONDA = DWORK(2) +C + ISCL = 0 + IF ( LSCAL ) THEN +C +C Scale the Hamiltonian or symplectic matrix. +C + IF( QNORM.GT.GNORM .AND. GNORM.GT.ZERO ) THEN + CALL DLASCL( 'G', 0, 0, QNORM, GNORM, N, N, S(NP1,1), N2, + $ IERR ) + CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, S(1,NP1), N2, + $ IERR ) + ISCL = 1 + END IF + END IF +C +C Find the ordered Schur factorization of S, S = U*H*U'. +C Workspace: need 6*N; +C prefer larger. +C + IF ( .NOT.DISCR ) THEN + IF ( LSORT ) THEN + CALL DGEES( 'Vectors', 'Sorted', SB02MV, N2, S, LDS, NROT, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + ELSE + CALL DGEES( 'Vectors', 'Sorted', SB02MR, N2, S, LDS, NROT, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + END IF + ELSE + IF ( LSORT ) THEN + CALL DGEES( 'Vectors', 'Sorted', SB02MW, N2, S, LDS, NROT, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + ELSE + CALL DGEES( 'Vectors', 'Sorted', SB02MS, N2, S, LDS, NROT, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + END IF + IF ( LHINV ) THEN + CALL DSWAP( N, WR, 1, WR(NP1), 1 ) + CALL DSWAP( N, WI, 1, WI(NP1), 1 ) + END IF + END IF + IF ( INFO.GT.N2 ) THEN + INFO = 3 + ELSE IF ( INFO.GT.0 ) THEN + INFO = 2 + ELSE IF ( NROT.NE.N ) THEN + INFO = 4 + END IF + IF ( INFO.NE.0 ) + $ RETURN +C + WRKOPT = MAX( WRKOPT, DWORK(1) ) +C +C Check if U(1,1) is singular. Use the (2,1) block of S as a +C workspace for factoring U(1,1). +C + UNORM = DLANGE( '1-norm', N, N, U, LDU, DWORK ) +C + CALL DLACPY( 'Full', N, N, U, LDU, S(NP1,1), LDS ) + CALL DGETRF( N, N, S(NP1,1), LDS, IWORK, INFO ) +C + IF ( INFO.GT.0 ) THEN +C +C Singular matrix. Set INFO and RCOND for error return. +C + INFO = 5 + RCOND = ZERO + GO TO 100 + END IF +C +C Estimate the reciprocal condition of U(1,1). +C Workspace: 6*N. +C + CALL DGECON( '1-norm', N, S(NP1,1), LDS, UNORM, RCOND, + $ DWORK, IWORK(NP1), INFO ) +C + IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN +C +C Nearly singular matrix. Set INFO for error return. +C + INFO = 5 + RETURN + END IF +C +C Transpose U(2,1) in Q and compute the solution. +C + DO 60 I = 1, N + CALL DCOPY( N, U(NP1,I), 1, Q(I,1), LDQ ) + 60 CONTINUE +C + CALL DGETRS( 'Transpose', N, N, S(NP1,1), LDS, IWORK, Q, LDQ, + $ INFO ) +C +C Set S(2,1) to zero. +C + CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) +C +C Make sure the solution matrix X is symmetric. +C + DO 80 I = 1, N - 1 + CALL DAXPY( N-I, ONE, Q(I,I+1), LDQ, Q(I+1,I), 1 ) + CALL DSCAL( N-I, HALF, Q(I+1,I), 1 ) + CALL DCOPY( N-I, Q(I+1,I), 1, Q(I,I+1), LDQ ) + 80 CONTINUE +C + IF( LSCAL ) THEN +C +C Undo scaling for the solution matrix. +C + IF( ISCL.EQ.1 ) + $ CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, Q, LDQ, IERR ) + END IF +C +C Set the optimal workspace, the scaling factor, and reciprocal +C condition number (if any). +C + DWORK(1) = WRKOPT + 100 CONTINUE + IF( ISCL.EQ.1 ) THEN + DWORK(2) = QNORM / GNORM + ELSE + DWORK(2) = ONE + END IF + IF ( DISCR ) DWORK(3) = RCONDA +C + RETURN +C *** Last line of SB02MD *** + END diff --git a/mex/sources/libslicot/SB02MR.f b/mex/sources/libslicot/SB02MR.f new file mode 100644 index 000000000..f306a1b93 --- /dev/null +++ b/mex/sources/libslicot/SB02MR.f @@ -0,0 +1,75 @@ + LOGICAL FUNCTION SB02MR( REIG, IEIG ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To select the unstable eigenvalues for solving the continuous-time +C algebraic Riccati equation. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C REIG (input) DOUBLE PRECISION +C The real part of the current eigenvalue considered. +C +C IEIG (input) DOUBLE PRECISION +C The imaginary part of the current eigenvalue considered. +C +C METHOD +C +C The function value SB02MR is set to .TRUE. for an unstable +C eigenvalue and to .FALSE., otherwise. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION IEIG, REIG +C .. Executable Statements .. +C + SB02MR = REIG.GE.ZERO +C + RETURN +C *** Last line of SB02MR *** + END diff --git a/mex/sources/libslicot/SB02MS.f b/mex/sources/libslicot/SB02MS.f new file mode 100644 index 000000000..1e8481eb7 --- /dev/null +++ b/mex/sources/libslicot/SB02MS.f @@ -0,0 +1,79 @@ + LOGICAL FUNCTION SB02MS( REIG, IEIG ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To select the unstable eigenvalues for solving the discrete-time +C algebraic Riccati equation. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C REIG (input) DOUBLE PRECISION +C The real part of the current eigenvalue considered. +C +C IEIG (input) DOUBLE PRECISION +C The imaginary part of the current eigenvalue considered. +C +C METHOD +C +C The function value SB02MS is set to .TRUE. for an unstable +C eigenvalue (i.e., with modulus greater than or equal to one) and +C to .FALSE., otherwise. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, discrete-time +C system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION IEIG, REIG +C .. External Functions .. + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2 +C .. Executable Statements .. +C + SB02MS = DLAPY2( REIG, IEIG ).GE.ONE +C + RETURN +C *** Last line of SB02MS *** + END diff --git a/mex/sources/libslicot/SB02MT.f b/mex/sources/libslicot/SB02MT.f new file mode 100644 index 000000000..7106bd971 --- /dev/null +++ b/mex/sources/libslicot/SB02MT.f @@ -0,0 +1,581 @@ + SUBROUTINE SB02MT( JOBG, JOBL, FACT, UPLO, N, M, A, LDA, B, LDB, + $ Q, LDQ, R, LDR, L, LDL, IPIV, OUFACT, G, LDG, + $ IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the following matrices +C +C -1 +C G = B*R *B', +C +C - -1 +C A = A - B*R *L', +C +C - -1 +C Q = Q - L*R *L', +C +C where A, B, Q, R, L, and G are N-by-N, N-by-M, N-by-N, M-by-M, +C N-by-M, and N-by-N matrices, respectively, with Q, R and G +C symmetric matrices. +C +C When R is well-conditioned with respect to inversion, standard +C algorithms for solving linear-quadratic optimization problems will +C then also solve optimization problems with coupling weighting +C matrix L. Moreover, a gain in efficiency is possible using matrix +C G in the deflating subspace algorithms (see SLICOT Library routine +C SB02OD). +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBG CHARACTER*1 +C Specifies whether or not the matrix G is to be computed, +C as follows: +C = 'G': Compute G; +C = 'N': Do not compute G. +C +C JOBL CHARACTER*1 +C Specifies whether or not the matrix L is zero, as follows: +C = 'Z': L is zero; +C = 'N': L is nonzero. +C +C FACT CHARACTER*1 +C Specifies how the matrix R is given (factored or not), as +C follows: +C = 'N': Array R contains the matrix R; +C = 'C': Array R contains the Cholesky factor of R; +C = 'U': Array R contains the symmetric indefinite UdU' or +C LdL' factorization of R. +C +C UPLO CHARACTER*1 +C Specifies which triangle of the matrices R and Q (if +C JOBL = 'N') is stored, as follows: +C = 'U': Upper triangle is stored; +C = 'L': Lower triangle is stored. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, Q, and G, and the number of +C rows of the matrices B and L. N >= 0. +C +C M (input) INTEGER +C The order of the matrix R, and the number of columns of +C the matrices B and L. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, if JOBL = 'N', the leading N-by-N part of this +C array must contain the matrix A. +C On exit, if JOBL = 'N', and INFO = 0, the leading N-by-N +C - -1 +C part of this array contains the matrix A = A - B*R L'. +C If JOBL = 'Z', this array is not referenced. +C +C LDA INTEGER +C The leading dimension of array A. +C LDA >= MAX(1,N) if JOBL = 'N'; +C LDA >= 1 if JOBL = 'Z'. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix B. +C On exit, if OUFACT = 1, and INFO = 0, the leading N-by-M +C -1 +C part of this array contains the matrix B*chol(R) . +C On exit, B is unchanged if OUFACT = 2 (hence also when +C FACT = 'U'). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, if JOBL = 'N', the leading N-by-N upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array must contain the upper +C triangular part or lower triangular part, respectively, of +C the symmetric matrix Q. The stricly lower triangular part +C (if UPLO = 'U') or stricly upper triangular part (if +C UPLO = 'L') is not referenced. +C On exit, if JOBL = 'N' and INFO = 0, the leading N-by-N +C upper triangular part (if UPLO = 'U') or lower triangular +C part (if UPLO = 'L') of this array contains the upper +C triangular part or lower triangular part, respectively, of +C - -1 +C the symmetric matrix Q = Q - L*R *L'. +C If JOBL = 'Z', this array is not referenced. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= MAX(1,N) if JOBL = 'N'; +C LDQ >= 1 if JOBL = 'Z'. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) +C On entry, if FACT = 'N', the leading M-by-M upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array must contain the upper +C triangular part or lower triangular part, respectively, +C of the symmetric input weighting matrix R. +C On entry, if FACT = 'C', the leading M-by-M upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array must contain the Cholesky +C factor of the positive definite input weighting matrix R +C (as produced by LAPACK routine DPOTRF). +C On entry, if FACT = 'U', the leading M-by-M upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array must contain the factors of +C the UdU' or LdL' factorization, respectively, of the +C symmetric indefinite input weighting matrix R (as produced +C by LAPACK routine DSYTRF). +C If FACT = 'N', the stricly lower triangular part (if UPLO +C = 'U') or stricly upper triangular part (if UPLO = 'L') of +C this array is used as workspace. +C On exit, if OUFACT = 1, and INFO = 0 (or INFO = M+1), +C the leading M-by-M upper triangular part (if UPLO = 'U') +C or lower triangular part (if UPLO = 'L') of this array +C contains the Cholesky factor of the given input weighting +C matrix. +C On exit, if OUFACT = 2, and INFO = 0 (or INFO = M+1), +C the leading M-by-M upper triangular part (if UPLO = 'U') +C or lower triangular part (if UPLO = 'L') of this array +C contains the factors of the UdU' or LdL' factorization, +C respectively, of the given input weighting matrix. +C On exit R is unchanged if FACT = 'C' or 'U'. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,M). +C +C L (input/output) DOUBLE PRECISION array, dimension (LDL,M) +C On entry, if JOBL = 'N', the leading N-by-M part of this +C array must contain the matrix L. +C On exit, if JOBL = 'N', OUFACT = 1, and INFO = 0, the +C leading N-by-M part of this array contains the matrix +C -1 +C L*chol(R) . +C On exit, L is unchanged if OUFACT = 2 (hence also when +C FACT = 'U'). +C L is not referenced if JOBL = 'Z'. +C +C LDL INTEGER +C The leading dimension of array L. +C LDL >= MAX(1,N) if JOBL = 'N'; +C LDL >= 1 if JOBL = 'Z'. +C +C IPIV (input/output) INTEGER array, dimension (M) +C On entry, if FACT = 'U', this array must contain details +C of the interchanges performed and the block structure of +C the d factor in the UdU' or LdL' factorization of matrix R +C (as produced by LAPACK routine DSYTRF). +C On exit, if OUFACT = 2, this array contains details of +C the interchanges performed and the block structure of the +C d factor in the UdU' or LdL' factorization of matrix R, +C as produced by LAPACK routine DSYTRF. +C This array is not referenced if FACT = 'C'. +C +C OUFACT (output) INTEGER +C Information about the factorization finally used. +C OUFACT = 1: Cholesky factorization of R has been used; +C OUFACT = 2: UdU' (if UPLO = 'U') or LdL' (if UPLO = 'L') +C factorization of R has been used. +C +C G (output) DOUBLE PRECISION array, dimension (LDG,N) +C If JOBG = 'G', and INFO = 0, the leading N-by-N upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array contains the upper +C triangular part (if UPLO = 'U') or lower triangular part +C -1 +C (if UPLO = 'L'), respectively, of the matrix G = B*R B'. +C If JOBG = 'N', this array is not referenced. +C +C LDG INTEGER +C The leading dimension of array G. +C LDG >= MAX(1,N) if JOBG = 'G', +C LDG >= 1 if JOBG = 'N'. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK; if FACT = 'N', DWORK(2) contains the reciprocal +C condition number of the given matrix R. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 1 if FACT = 'C'; +C LDWORK >= MAX(2,3*M,N*M) if FACT = 'N'; +C LDWORK >= MAX(1,N*M) if FACT = 'U'. +C For optimum performance LDWORK should be larger than 3*M, +C if FACT = 'N'. +C The N*M workspace is not needed for FACT = 'N', if matrix +C R is positive definite. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = i: if the i-th element (1 <= i <= M) of the d factor is +C exactly zero; the UdU' (or LdL') factorization has +C been completed, but the block diagonal matrix d is +C exactly singular; +C = M+1: if the matrix R is numerically singular. +C +C METHOD +C - - +C The matrices G, and/or A and Q are evaluated using the given or +C computed symmetric factorization of R. +C +C NUMERICAL ASPECTS +C +C The routine should not be used when R is ill-conditioned. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, discrete-time system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER FACT, JOBG, JOBL, UPLO + INTEGER INFO, LDA, LDB, LDG, LDL, LDQ, LDR, LDWORK, M, + $ N, OUFACT +C .. Array Arguments .. + INTEGER IPIV(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), G(LDG,*), + $ L(LDL,*), Q(LDQ,*), R(LDR,*) +C .. Local Scalars .. + LOGICAL LFACTA, LFACTC, LFACTU, LJOBG, LJOBL, LUPLOU + CHARACTER TRANS + INTEGER I, J, WRKOPT + DOUBLE PRECISION EPS, RCOND, RNORM +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DPOCON, DPOTRF, DSYCON, + $ DSYRK, DSYTRF, DSYTRS, DTRSM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + INFO = 0 + LJOBG = LSAME( JOBG, 'G' ) + LJOBL = LSAME( JOBL, 'N' ) + LFACTC = LSAME( FACT, 'C' ) + LFACTU = LSAME( FACT, 'U' ) + LUPLOU = LSAME( UPLO, 'U' ) + LFACTA = LFACTC.OR.LFACTU +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBG .AND. .NOT.LSAME( JOBG, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LJOBL .AND. .NOT.LSAME( JOBL, 'Z' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LFACTA .AND. .NOT.LSAME( FACT, 'N' ) ) THEN + INFO = -3 + ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( ( LDA.LT.1 ) .OR. ( LJOBL .AND. LDA.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( ( LDQ.LT.1 ) .OR. ( LJOBL .AND. LDQ.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDR.LT.MAX( 1, M ) ) THEN + INFO = -14 + ELSE IF( ( LDL.LT.1 ) .OR. ( LJOBL .AND. LDL.LT.N ) ) THEN + INFO = -16 + ELSE IF( ( LDG.LT.1 ) .OR. ( LJOBG .AND. LDG.LT.N ) ) THEN + INFO = -20 + ELSE IF( ( LFACTC .AND. LDWORK.LT.1 ) .OR. + $ ( LFACTU .AND. LDWORK.LT.MAX( 1, N*M ) ) .OR. + $ ( .NOT.LFACTA .AND. LDWORK.LT.MAX( 2, N*M, 3*M ) ) ) THEN + INFO = -23 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB02MT', -INFO ) + RETURN + END IF +C + IF ( LFACTC ) THEN + OUFACT = 1 + ELSE IF ( LFACTU ) THEN + OUFACT = 2 + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 .OR. .NOT.( LJOBL.OR.LJOBG ) ) THEN + DWORK(1) = ONE + IF ( .NOT.LFACTA ) DWORK(2) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + WRKOPT = 1 +C +C Set relative machine precision. +C + EPS = DLAMCH( 'Epsilon' ) +C + IF ( .NOT.LFACTA ) THEN +C +C Compute the norm of the matrix R, which is not factored. +C Then save the given triangle of R in the other strict triangle +C and the diagonal in the workspace, and try Cholesky +C factorization. +C Workspace: need M. +C + RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) + CALL DCOPY( M, R, LDR+1, DWORK, 1 ) + IF( LUPLOU ) THEN +C + DO 20 J = 2, M + CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) + 20 CONTINUE +C + ELSE +C + DO 40 J = 2, M + CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) + 40 CONTINUE +C + END IF + CALL DPOTRF( UPLO, M, R, LDR, INFO ) + IF( INFO.EQ.0 ) THEN +C +C Compute the reciprocal of the condition number of R. +C Workspace: need 3*M. +C + CALL DPOCON( UPLO, M, R, LDR, RNORM, RCOND, DWORK, IWORK, + $ INFO ) +C +C Return if the matrix is singular to working precision. +C + OUFACT = 1 + DWORK(2) = RCOND + IF( RCOND.LT.EPS ) THEN + INFO = M + 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, 3*M ) + ELSE +C +C Use UdU' or LdL' factorization, first restoring the saved +C triangle. +C + CALL DCOPY( M, DWORK, 1, R, LDR+1 ) + IF( LUPLOU ) THEN +C + DO 60 J = 2, M + CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) + 60 CONTINUE +C + ELSE +C + DO 80 J = 2, M + CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) + 80 CONTINUE +C + END IF +C +C Compute the UdU' or LdL' factorization. +C Workspace: need 1, +C prefer M*NB. +C + CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO ) + OUFACT = 2 + IF( INFO.GT.0 ) THEN + DWORK(2) = ONE + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Compute the reciprocal of the condition number of R. +C Workspace: need 2*M. +C + CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK, + $ IWORK, INFO ) +C +C Return if the matrix is singular to working precision. +C + DWORK(2) = RCOND + IF( RCOND.LT.EPS ) THEN + INFO = M + 1 + RETURN + END IF + END IF + END IF +C + IF (OUFACT.EQ.1 ) THEN +C +C Solve positive definite linear system(s). +C + IF ( LUPLOU ) THEN + TRANS = 'N' + ELSE + TRANS = 'T' + END IF +C +C Solve the system X*U = B, overwriting B with X. +C + CALL DTRSM( 'Right', UPLO, TRANS, 'Non-unit', N, M, + $ ONE, R, LDR, B, LDB ) +C + IF ( LJOBG ) THEN +C -1 +C Compute the matrix G = B*R *B', multiplying X*X' in G. +C + CALL DSYRK( UPLO, 'No transpose', N, M, ONE, B, LDB, ZERO, + $ G, LDG ) + END IF +C + IF( LJOBL ) THEN +C +C Update matrices A and Q. +C +C Solve the system Y*U = L, overwriting L with Y. +C + CALL DTRSM( 'Right', UPLO, TRANS, 'Non-unit', N, M, + $ ONE, R, LDR, L, LDL ) +C +C Compute A <- A - X*Y'. +C + CALL DGEMM( 'No transpose', 'Transpose', N, N, M, -ONE, B, + $ LDB, L, LDL, ONE, A, LDA ) +C +C Compute Q <- Q - Y*Y'. +C + CALL DSYRK( UPLO, 'No transpose', N, M, -ONE, L, LDL, ONE, + $ Q, LDQ ) + END IF + ELSE +C +C Solve indefinite linear system(s). +C +C Solve the system UdU'*X = B' (or LdL'*X = B'). +C Workspace: need N*M. +C + DO 100 J = 1, M + CALL DCOPY( N, B(1,J), 1, DWORK(J), M ) + 100 CONTINUE +C + CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO ) +C + IF ( LJOBG ) THEN +C -1 +C Compute a triangle of the matrix G = B*R *B' = B*X. +C + IF ( LUPLOU ) THEN + I = 1 +C + DO 120 J = 1, N + CALL DGEMV( 'No transpose', J, M, ONE, B, LDB, + $ DWORK(I), 1, ZERO, G(1,J), 1 ) + I = I + M + 120 CONTINUE +C + ELSE +C + DO 140 J = 1, N + CALL DGEMV( 'Transpose', M, J, ONE, DWORK, M, B(J,1), + $ LDB, ZERO, G(J,1), LDG ) + 140 CONTINUE +C + END IF + END IF +C + IF( LJOBL ) THEN +C +C Update matrices A and Q. +C +C Solve the system UdU'*Y = L' (or LdL'*Y = L'). +C + DO 160 J = 1, M + CALL DCOPY( N, L(1,J), 1, DWORK(J), M ) + 160 CONTINUE +C + CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO ) +C +C A <- A - B*Y. +C + CALL DGEMM( 'No transpose', 'No transpose', N, N, M, -ONE, + $ B, LDB, DWORK, M, ONE, A, LDA ) +C - -1 +C Compute a triangle of the matrix Q = Q - L*R *L' = Q - L*Y. +C + IF ( LUPLOU ) THEN + I = 1 +C + DO 180 J = 1, N + CALL DGEMV( 'No transpose', J, M, -ONE, L, LDL, + $ DWORK(I), 1, ONE, Q(1,J), 1 ) + I = I + M + 180 CONTINUE +C + ELSE +C + DO 200 J = 1, N + CALL DGEMV( 'Transpose', M, J, -ONE, DWORK, M, L(J,1), + $ LDL, ONE, Q(J,1), LDQ ) + 200 CONTINUE +C + END IF + END IF + END IF +C + DWORK(1) = WRKOPT + IF ( .NOT.LFACTA ) DWORK(2) = RCOND +C +C *** Last line of SB02MT *** + RETURN + END diff --git a/mex/sources/libslicot/SB02MU.f b/mex/sources/libslicot/SB02MU.f new file mode 100644 index 000000000..567a22476 --- /dev/null +++ b/mex/sources/libslicot/SB02MU.f @@ -0,0 +1,486 @@ + SUBROUTINE SB02MU( DICO, HINV, UPLO, N, A, LDA, G, LDG, Q, LDQ, S, + $ LDS, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the 2n-by-2n Hamiltonian or symplectic matrix S +C associated to the linear-quadratic optimization problem, used to +C solve the continuous- or discrete-time algebraic Riccati equation, +C respectively. +C +C For a continuous-time problem, S is defined by +C +C ( A -G ) +C S = ( ), (1) +C ( -Q -A') +C +C and for a discrete-time problem by +C +C -1 -1 +C ( A A *G ) +C S = ( -1 -1 ), (2) +C ( QA A' + Q*A *G ) +C +C or +C +C -T -T +C ( A + G*A *Q -G*A ) +C S = ( -T -T ), (3) +C ( -A *Q A ) +C +C where A, G, and Q are N-by-N matrices, with G and Q symmetric. +C Matrix A must be nonsingular in the discrete-time case. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system as follows: +C = 'C': Continuous-time system; +C = 'D': Discrete-time system. +C +C HINV CHARACTER*1 +C If DICO = 'D', specifies which of the matrices (2) or (3) +C is constructed, as follows: +C = 'D': The matrix S in (2) is constructed; +C = 'I': The (inverse) matrix S in (3) is constructed. +C HINV is not referenced if DICO = 'C'. +C +C UPLO CHARACTER*1 +C Specifies which triangle of the matrices G and Q is +C stored, as follows: +C = 'U': Upper triangle is stored; +C = 'L': Lower triangle is stored. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, G, and Q. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, if DICO = 'D', and INFO = 0, the leading N-by-N +C -1 +C part of this array contains the matrix A . +C Otherwise, the array A is unchanged on exit. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C G (input) DOUBLE PRECISION array, dimension (LDG,N) +C The leading N-by-N upper triangular part (if UPLO = 'U') +C or lower triangular part (if UPLO = 'L') of this array +C must contain the upper triangular part or lower triangular +C part, respectively, of the symmetric matrix G. The stricly +C lower triangular part (if UPLO = 'U') or stricly upper +C triangular part (if UPLO = 'L') is not referenced. +C +C LDG INTEGER +C The leading dimension of array G. LDG >= MAX(1,N). +C +C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) +C The leading N-by-N upper triangular part (if UPLO = 'U') +C or lower triangular part (if UPLO = 'L') of this array +C must contain the upper triangular part or lower triangular +C part, respectively, of the symmetric matrix Q. The stricly +C lower triangular part (if UPLO = 'U') or stricly upper +C triangular part (if UPLO = 'L') is not referenced. +C +C LDQ INTEGER +C The leading dimension of array Q. LDQ >= MAX(1,N). +C +C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) +C If INFO = 0, the leading 2N-by-2N part of this array +C contains the Hamiltonian or symplectic matrix of the +C problem. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,2*N). +C +C Workspace +C +C IWORK INTEGER array, dimension (2*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK; if DICO = 'D', DWORK(2) returns the reciprocal +C condition number of the given matrix A. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 1 if DICO = 'C'; +C LDWORK >= MAX(2,4*N) if DICO = 'D'. +C For optimum performance LDWORK should be larger, if +C DICO = 'D'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = i: if the leading i-by-i (1 <= i <= N) upper triangular +C submatrix of A is singular in discrete-time case; +C = N+1: if matrix A is numerically singular in discrete- +C time case. +C +C METHOD +C +C For a continuous-time problem, the 2n-by-2n Hamiltonian matrix (1) +C is constructed. +C For a discrete-time problem, the 2n-by-2n symplectic matrix (2) or +C (3) - the inverse of the matrix in (2) - is constructed. +C +C NUMERICAL ASPECTS +C +C The discrete-time case needs the inverse of the matrix A, hence +C the routine should not be used when A is ill-conditioned. +C 3 +C The algorithm requires 0(n ) floating point operations in the +C discrete-time case. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, discrete-time system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, HINV, UPLO + INTEGER INFO, LDA, LDG, LDQ, LDS, LDWORK, N +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), + $ S(LDS,*) +C .. Local Scalars .. + LOGICAL DISCR, LHINV, LUPLO + INTEGER I, J, MAXWRK, N2, NJ, NP1 + DOUBLE PRECISION ANORM, RCOND +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGECON, DGEMM, DGETRF, DGETRI, DGETRS, + $ DLACPY, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 + N2 = N + N + DISCR = LSAME( DICO, 'D' ) + LUPLO = LSAME( UPLO, 'U' ) + IF( DISCR ) THEN + LHINV = LSAME( HINV, 'D' ) + ELSE + LHINV = .FALSE. + END IF +C +C Test the input scalar arguments. +C + IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN + INFO = -1 + ELSE IF( DISCR ) THEN + IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) ) + $ INFO = -2 + END IF + IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDG.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN + INFO = -12 + ELSE IF( ( LDWORK.LT.1 ) .OR. + $ ( DISCR .AND. LDWORK.LT.MAX( 2, 4*N ) ) ) THEN + INFO = -15 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB02MU', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK(1) = ONE + IF ( DISCR ) DWORK(2) = ONE + RETURN + END IF +C +C The code tries to exploit data locality as much as possible. +C + IF ( .NOT.LHINV ) THEN + CALL DLACPY( 'Full', N, N, A, LDA, S, LDS ) +C +C Construct Hamiltonian matrix in the continuous-time case, or +C prepare symplectic matrix in (3) in the discrete-time case: +C +C Construct full Q in S(N+1:2*N,1:N) and change the sign, and +C construct full G in S(1:N,N+1:2*N) and change the sign. +C + DO 200 J = 1, N + NJ = N + J + IF ( LUPLO ) THEN +C + DO 20 I = 1, J + S(N+I,J) = -Q(I,J) + 20 CONTINUE +C + DO 40 I = J + 1, N + S(N+I,J) = -Q(J,I) + 40 CONTINUE +C + DO 60 I = 1, J + S(I,NJ) = -G(I,J) + 60 CONTINUE +C + DO 80 I = J + 1, N + S(I,NJ) = -G(J,I) + 80 CONTINUE +C + ELSE +C + DO 100 I = 1, J - 1 + S(N+I,J) = -Q(J,I) + 100 CONTINUE +C + DO 120 I = J, N + S(N+I,J) = -Q(I,J) + 120 CONTINUE +C + DO 140 I = 1, J - 1 + S(I,NJ) = -G(J,I) + 140 CONTINUE +C + DO 180 I = J, N + S(I,NJ) = -G(I,J) + 180 CONTINUE +C + END IF + 200 CONTINUE +C + IF ( .NOT.DISCR ) THEN +C + DO 240 J = 1, N + NJ = N + J +C + DO 220 I = 1, N + S(N+I,NJ) = -A(J,I) + 220 CONTINUE +C + 240 CONTINUE +C + DWORK(1) = ONE + END IF + END IF +C + IF ( DISCR ) THEN +C +C Construct the symplectic matrix (2) or (3) in the discrete-time +C case. +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + MAXWRK = MAX( 4*N, + $ N*ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 ) ) + NP1 = N + 1 +C + IF ( LHINV ) THEN +C +C Put A' in S(N+1:2*N,N+1:2*N). +C + DO 260 I = 1, N + CALL DCOPY( N, A(I, 1), LDA, S(NP1,N+I), 1 ) + 260 CONTINUE +C + END IF +C +C Compute the norm of the matrix A. +C + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) +C +C Compute the LU factorization of A. +C + CALL DGETRF( N, N, A, LDA, IWORK, INFO ) +C +C Return if INFO is non-zero. +C + IF( INFO.GT.0 ) THEN + DWORK(2) = ZERO + RETURN + END IF +C +C Compute the reciprocal of the condition number of A. +C Workspace: need 4*N. +C + CALL DGECON( '1-norm', N, A, LDA, ANORM, RCOND, DWORK, + $ IWORK(NP1), INFO ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN + INFO = N + 1 + DWORK(2) = RCOND + RETURN + END IF +C + IF ( LHINV ) THEN +C +C Compute S in (2). +C +C Construct full Q in S(N+1:2*N,1:N). +C + IF ( LUPLO ) THEN + DO 270 J = 1, N - 1 + CALL DCOPY( J, Q(1,J), 1, S(NP1,J), 1 ) + CALL DCOPY( N-J, Q(J,J+1), LDQ, S(NP1+J,J), 1 ) + 270 CONTINUE + CALL DCOPY( N, Q(1,N), 1, S(NP1,N), 1 ) + ELSE + CALL DCOPY( N, Q(1,1), 1, S(NP1,1), 1 ) + DO 280 J = 2, N + CALL DCOPY( J-1, Q(J,1), LDQ, S(NP1,J), 1 ) + CALL DCOPY( N-J+1, Q(J,J), 1, S(N+J,J), 1 ) + 280 CONTINUE + END IF +C +C Compute the solution matrix X of the system X*A = Q by +C -1 +C solving A'*X' = Q and transposing the result to get Q*A . +C + CALL DGETRS( 'Transpose', N, N, A, LDA, IWORK, S(NP1,1), + $ LDS, INFO ) +C + DO 300 J = 1, N - 1 + CALL DSWAP( N-J, S(NP1+J,J), 1, S(N+J,J+1), LDS ) + 300 CONTINUE +C +C Construct full G in S(1:N,N+1:2*N). +C + IF ( LUPLO ) THEN + DO 310 J = 1, N - 1 + CALL DCOPY( J, G(1,J), 1, S(1,N+J), 1 ) + CALL DCOPY( N-J, G(J,J+1), LDG, S(J+1,N+J), 1 ) + 310 CONTINUE + CALL DCOPY( N, G(1,N), 1, S(1,N2), 1 ) + ELSE + CALL DCOPY( N, G(1,1), 1, S(1,NP1), 1 ) + DO 320 J = 2, N + CALL DCOPY( J-1, G(J,1), LDG, S(1,N+J), 1 ) + CALL DCOPY( N-J+1, G(J,J), 1, S(J,N+J), 1 ) + 320 CONTINUE + END IF +C -1 +C Compute A' + Q*A *G in S(N+1:2N,N+1:2N). +C + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, + $ S(NP1,1), LDS, S(1,NP1), LDS, ONE, S(NP1,NP1), + $ LDS ) +C +C Compute the solution matrix Y of the system A*Y = G. +C + CALL DGETRS( 'No transpose', N, N, A, LDA, IWORK, S(1,NP1), + $ LDS, INFO ) +C +C Compute the inverse of A in situ. +C Workspace: need N; prefer N*NB. +C + CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO ) +C -1 +C Copy A in S(1:N,1:N). +C + CALL DLACPY( 'Full', N, N, A, LDA, S, LDS ) +C + ELSE +C +C Compute S in (3) using the already prepared part. +C +C Compute the solution matrix X' of the system A*X' = -G +C -T +C and transpose the result to obtain X = -G*A . +C + CALL DGETRS( 'No transpose', N, N, A, LDA, IWORK, S(1,NP1), + $ LDS, INFO ) +C + DO 340 J = 1, N - 1 + CALL DSWAP( N-J, S(J+1,N+J), 1, S(J,NP1+J), LDS ) + 340 CONTINUE +C -T +C Compute A + G*A *Q in S(1:N,1:N). +C + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, + $ S(1,NP1), LDS, S(NP1, 1), LDS, ONE, S, LDS ) +C +C Compute the solution matrix Y of the system A'*Y = -Q. +C + CALL DGETRS( 'Transpose', N, N, A, LDA, IWORK, S(NP1,1), + $ LDS, INFO ) +C +C Compute the inverse of A in situ. +C Workspace: need N; prefer N*NB. +C + CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO ) +C -T +C Copy A in S(N+1:2N,N+1:2N). +C + DO 360 J = 1, N + CALL DCOPY( N, A(J,1), LDA, S(NP1,N+J), 1 ) + 360 CONTINUE +C + END IF + DWORK(1) = MAXWRK + DWORK(2) = RCOND + END IF +C +C *** Last line of SB02MU *** + RETURN + END diff --git a/mex/sources/libslicot/SB02MV.f b/mex/sources/libslicot/SB02MV.f new file mode 100644 index 000000000..5dc8e2452 --- /dev/null +++ b/mex/sources/libslicot/SB02MV.f @@ -0,0 +1,75 @@ + LOGICAL FUNCTION SB02MV( REIG, IEIG ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To select the stable eigenvalues for solving the continuous-time +C algebraic Riccati equation. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C REIG (input) DOUBLE PRECISION +C The real part of the current eigenvalue considered. +C +C IEIG (input) DOUBLE PRECISION +C The imaginary part of the current eigenvalue considered. +C +C METHOD +C +C The function value SB02MV is set to .TRUE. for a stable eigenvalue +C and to .FALSE., otherwise. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION IEIG, REIG +C .. Executable Statements .. +C + SB02MV = REIG.LT.ZERO +C + RETURN +C *** Last line of SB02MV *** + END diff --git a/mex/sources/libslicot/SB02MW.f b/mex/sources/libslicot/SB02MW.f new file mode 100644 index 000000000..eb54ebae9 --- /dev/null +++ b/mex/sources/libslicot/SB02MW.f @@ -0,0 +1,79 @@ + LOGICAL FUNCTION SB02MW( REIG, IEIG ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To select the stable eigenvalues for solving the discrete-time +C algebraic Riccati equation. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C REIG (input) DOUBLE PRECISION +C The real part of the current eigenvalue considered. +C +C IEIG (input) DOUBLE PRECISION +C The imaginary part of the current eigenvalue considered. +C +C METHOD +C +C The function value SB02MW is set to .TRUE. for a stable +C eigenvalue (i.e., with modulus less than one) and to .FALSE., +C otherwise. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, discrete-time +C system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION IEIG, REIG +C .. External Functions .. + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2 +C .. Executable Statements .. +C + SB02MW = DLAPY2( REIG, IEIG ).LT.ONE +C + RETURN +C *** Last line of SB02MW *** + END diff --git a/mex/sources/libslicot/SB02ND.f b/mex/sources/libslicot/SB02ND.f new file mode 100644 index 000000000..1f446c023 --- /dev/null +++ b/mex/sources/libslicot/SB02ND.f @@ -0,0 +1,755 @@ + SUBROUTINE SB02ND( DICO, FACT, UPLO, JOBL, N, M, P, A, LDA, B, + $ LDB, R, LDR, IPIV, L, LDL, X, LDX, RNORM, F, + $ LDF, OUFACT, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the optimal feedback matrix F for the problem of +C optimal control given by +C +C -1 +C F = (R + B'XB) (B'XA + L') (1) +C +C in the discrete-time case and +C +C -1 +C F = R (B'X + L') (2) +C +C in the continuous-time case, where A, B and L are N-by-N, N-by-M +C and N-by-M matrices respectively; R and X are M-by-M and N-by-N +C symmetric matrices respectively. +C +C Optionally, matrix R may be specified in a factored form, and L +C may be zero. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the equation from which F is to be determined, +C as follows: +C = 'D': Equation (1), discrete-time case; +C = 'C': Equation (2), continuous-time case. +C +C FACT CHARACTER*1 +C Specifies how the matrix R is given (factored or not), as +C follows: +C = 'N': Array R contains the matrix R; +C = 'D': Array R contains a P-by-M matrix D, where R = D'D; +C = 'C': Array R contains the Cholesky factor of R; +C = 'U': Array R contains the symmetric indefinite UdU' or +C LdL' factorization of R. This option is not +C available for DICO = 'D'. +C +C UPLO CHARACTER*1 +C Specifies which triangle of the possibly factored matrix R +C (or R + B'XB, on exit) is or should be stored, as follows: +C = 'U': Upper triangle is stored; +C = 'L': Lower triangle is stored. +C +C JOBL CHARACTER*1 +C Specifies whether or not the matrix L is zero, as follows: +C = 'Z': L is zero; +C = 'N': L is nonzero. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and X. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C This parameter must be specified only for FACT = 'D'. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C If DICO = 'D', the leading N-by-N part of this array must +C contain the state matrix A of the system. +C If DICO = 'C', this array is not referenced. +C +C LDA INTEGER +C The leading dimension of array A. +C LDA >= MAX(1,N) if DICO = 'D'; +C LDA >= 1 if DICO = 'C'. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input matrix B of the system. +C If DICO = 'D' and FACT = 'D' or 'C', the contents of this +C array is destroyed. +C Otherwise, B is unchanged on exit. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) +C On entry, if FACT = 'N', the leading M-by-M upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array must contain the upper +C triangular part or lower triangular part, respectively, +C of the symmetric input weighting matrix R. +C On entry, if FACT = 'D', the leading P-by-M part of this +C array must contain the direct transmission matrix D of the +C system. +C On entry, if FACT = 'C', the leading M-by-M upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array must contain the Cholesky +C factor of the positive definite input weighting matrix R +C (as produced by LAPACK routine DPOTRF). +C On entry, if DICO = 'C' and FACT = 'U', the leading M-by-M +C upper triangular part (if UPLO = 'U') or lower triangular +C part (if UPLO = 'L') of this array must contain the +C factors of the UdU' or LdL' factorization, respectively, +C of the symmetric indefinite input weighting matrix R (as +C produced by LAPACK routine DSYTRF). +C The stricly lower triangular part (if UPLO = 'U') or +C stricly upper triangular part (if UPLO = 'L') of this +C array is used as workspace. +C On exit, if OUFACT(1) = 1, and INFO = 0 (or INFO = M+1), +C the leading M-by-M upper triangular part (if UPLO = 'U') +C or lower triangular part (if UPLO = 'L') of this array +C contains the Cholesky factor of the given input weighting +C matrix (for DICO = 'C'), or that of the matrix R + B'XB +C (for DICO = 'D'). +C On exit, if OUFACT(1) = 2, and INFO = 0 (or INFO = M+1), +C the leading M-by-M upper triangular part (if UPLO = 'U') +C or lower triangular part (if UPLO = 'L') of this array +C contains the factors of the UdU' or LdL' factorization, +C respectively, of the given input weighting matrix +C (for DICO = 'C'), or that of the matrix R + B'XB +C (for DICO = 'D'). +C On exit R is unchanged if FACT = 'U'. +C +C LDR INTEGER. +C The leading dimension of the array R. +C LDR >= MAX(1,M) if FACT <> 'D'; +C LDR >= MAX(1,M,P) if FACT = 'D'. +C +C IPIV (input/output) INTEGER array, dimension (M) +C On entry, if FACT = 'U', this array must contain details +C of the interchanges performed and the block structure of +C the d factor in the UdU' or LdL' factorization of matrix R +C (as produced by LAPACK routine DSYTRF). +C On exit, if OUFACT(1) = 2, this array contains details of +C the interchanges performed and the block structure of the +C d factor in the UdU' or LdL' factorization of matrix R (or +C D'D) or R + B'XB (or D'D + B'XB), as produced by LAPACK +C routine DSYTRF. +C This array is not referenced for DICO = 'D' or FACT = 'D', +C or 'C'. +C +C L (input) DOUBLE PRECISION array, dimension (LDL,M) +C If JOBL = 'N', the leading N-by-M part of this array must +C contain the cross weighting matrix L. +C If JOBL = 'Z', this array is not referenced. +C +C LDL INTEGER +C The leading dimension of array L. +C LDL >= MAX(1,N) if JOBL = 'N'; +C LDL >= 1 if JOBL = 'Z'. +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, the leading N-by-N part of this array must +C contain the solution matrix X of the algebraic Riccati +C equation as produced by SLICOT Library routines SB02MD or +C SB02OD. Matrix X is assumed non-negative definite. +C On exit, if DICO = 'D', FACT = 'D' or 'C', OUFACT(2) = 1, +C and INFO = 0, the N-by-N upper triangular part of this +C array contains the Cholesky factor of the given matrix X, +C which is found to be positive definite. +C On exit, if DICO = 'D', FACT = 'D' or 'C', OUFACT(2) = 2, +C and INFO = 0, the leading N-by-N part of this array +C contains the matrix of orthonormal eigenvectors of X. +C On exit X is unchanged if DICO = 'C' or FACT = 'N'. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= MAX(1,N). +C +C RNORM (input) DOUBLE PRECISION +C If FACT = 'U', this parameter must contain the 1-norm of +C the original matrix R (before factoring it). +C Otherwise, this parameter is not used. +C +C F (output) DOUBLE PRECISION array, dimension (LDF,N) +C The leading M-by-N part of this array contains the +C optimal feedback matrix F. +C +C LDF INTEGER +C The leading dimension of array F. LDF >= MAX(1,M). +C +C OUFACT (output) INTEGER array, dimension (2) +C Information about the factorization finally used. +C OUFACT(1) = 1: Cholesky factorization of R (or R + B'XB) +C has been used; +C OUFACT(1) = 2: UdU' (if UPLO = 'U') or LdL' (if UPLO = +C 'L') factorization of R (or R + B'XB) +C has been used; +C OUFACT(2) = 1: Cholesky factorization of X has been used; +C OUFACT(2) = 2: Spectral factorization of X has been used. +C The value of OUFACT(2) is not set for DICO = 'C' or for +C DICO = 'D' and FACT = 'N'. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2) contains the reciprocal condition +C number of the matrix R (for DICO = 'C') or of R + B'XB +C (for DICO = 'D'). +C If on exit INFO = 0, and OUFACT(2) = 2, then DWORK(3),..., +C DWORK(N+2) contain the eigenvalues of X, in ascending +C order. +C +C LDWORK INTEGER +C Dimension of working array DWORK. +C LDWORK >= max(2,3*M) if FACT = 'N'; +C LDWORK >= max(2,2*M) if FACT = 'U'; +C LDWORK >= max(2,3*M) if FACT = 'C', DICO = 'C'; +C LDWORK >= N+3*M+2 if FACT = 'C', DICO = 'D'; +C LDWORK >= max(2,min(P,M)+M) if FACT = 'D', DICO = 'C'; +C LDWORK >= max(N+3*M+2,4*N+1) if FACT = 'D', DICO = 'D'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = i: if the i-th element of the d factor is exactly zero; +C the UdU' (or LdL') factorization has been completed, +C but the block diagonal matrix d is exactly singular; +C = M+1: if the matrix R (if DICO = 'C'), or R + B'XB +C (if DICO = 'D') is numerically singular (to working +C precision); +C = M+2: if one or more of the eigenvalues of X has not +C converged. +C +C METHOD +C +C The optimal feedback matrix F is obtained as the solution to the +C system of linear equations +C +C (R + B'XB) * F = B'XA + L' +C +C in the discrete-time case and +C +C R * F = B'X + L' +C +C in the continuous-time case, with R replaced by D'D if FACT = 'D'. +C The factored form of R, specified by FACT <> 'N', is taken into +C account. If FACT = 'N', Cholesky factorization is tried first, but +C if the coefficient matrix is not positive definite, then UdU' (or +C LdL') factorization is used. The discrete-time case involves +C updating of a triangular factorization of R (or D'D); Cholesky or +C symmetric spectral factorization of X is employed to avoid +C squaring of the condition number of the matrix. When D is given, +C its QR factorization is determined, and the triangular factor is +C used as described above. +C +C NUMERICAL ASPECTS +C +C The algorithm consists of numerically stable steps. +C 3 2 +C For DICO = 'C', it requires O(m + mn ) floating point operations +C 2 +C if FACT = 'N' and O(mn ) floating point operations, otherwise. +C For DICO = 'D', the operation counts are similar, but additional +C 3 +C O(n ) floating point operations may be needed in the worst case. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB02BD by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, discrete-time system, matrix algebra, optimal control, +C optimal regulator. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, FACT, JOBL, UPLO + INTEGER INFO, LDA, LDB, LDF, LDL, LDR, LDWORK, LDX, M, + $ N, P + DOUBLE PRECISION RNORM +C .. Array Arguments .. + INTEGER IPIV(*), IWORK(*), OUFACT(2) + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*), + $ L(LDL,*), R(LDR,*), X(LDX,*) +C .. Local Scalars .. + LOGICAL DISCR, LFACTA, LFACTC, LFACTD, LFACTU, LUPLOU, + $ WITHL + INTEGER I, IFAIL, ITAU, J, JW, JWORK, JZ, WRKOPT + DOUBLE PRECISION EPS, RCOND, RNORMP, TEMP +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DGEQRF, DLASET, DPOCON, + $ DPOTRF, DPOTRS, DSCAL, DSYCON, DSYEV, DSYTRF, + $ DSYTRS, DTRCON, DTRMM, MB04KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + LFACTC = LSAME( FACT, 'C' ) + LFACTD = LSAME( FACT, 'D' ) + LFACTU = LSAME( FACT, 'U' ) + LUPLOU = LSAME( UPLO, 'U' ) + WITHL = LSAME( JOBL, 'N' ) + LFACTA = LFACTC.OR.LFACTD.OR.LFACTU +C +C Test the input scalar arguments. +C + IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN + INFO = -1 + ELSE IF( ( .NOT.LFACTA .AND. .NOT.LSAME( FACT, 'N' ) ) .OR. + $ ( DISCR .AND. LFACTU ) ) THEN + INFO = -2 + ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -3 + ELSE IF( .NOT.WITHL .AND. .NOT.LSAME( JOBL, 'Z' ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( ( .NOT.DISCR .AND. LDA.LT.1 ) .OR. + $ ( DISCR .AND. LDA.LT.MAX( 1, N ) ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( ( LDR.LT.MAX( 1, M ) ) .OR. + $ ( LFACTD .AND. LDR.LT.MAX( 1, P ) ) ) THEN + INFO = -13 + ELSE IF( ( .NOT.WITHL .AND. LDL.LT.1 ) .OR. + $ ( WITHL .AND. LDL.LT.MAX( 1, N ) ) ) THEN + INFO = -16 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LFACTU ) THEN + IF( RNORM.LT.ZERO ) + $ INFO = -19 + END IF + IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -21 + ELSE IF( ( ( .NOT.LFACTA .OR. ( LFACTC .AND. .NOT.DISCR ) ) + $ .AND. LDWORK.LT.MAX( 2, 3*M ) ) .OR. + $ ( LFACTU .AND. LDWORK.LT.MAX( 2, 2*M ) ) .OR. + $ ( DISCR .AND. LFACTC .AND. LDWORK.LT.N + 3*M + 2 ) .OR. + $(.NOT.DISCR .AND. LFACTD .AND. LDWORK.LT.MAX( 2, MIN(P,M) + M ) ) + $ .OR. + $ ( DISCR .AND. LFACTD .AND. LDWORK.LT.MAX( N + 3*M + 2, + $ 4*N + 1 ) ) ) THEN + INFO = -25 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB02ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 .OR. ( LFACTD .AND. P.EQ.0 ) ) THEN + DWORK(1) = ONE + DWORK(2) = ONE + RETURN + END IF +C + WRKOPT = 1 + EPS = DLAMCH( 'Epsilon' ) +C +C Determine the right-hand side of the matrix equation. +C Compute B'X in F. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + CALL DGEMM( 'Transpose', 'No transpose', M, N, N, ONE, B, LDB, X, + $ LDX, ZERO, F, LDF ) +C + IF ( .NOT.LFACTA ) THEN + IF ( DISCR ) THEN +C +C Discrete-time case with R not factored. Compute R + B'XB. +C + IF ( LUPLOU ) THEN +C + DO 10 J = 1, M + CALL DGEMV( 'No transpose', J, N, ONE, F, LDF, B(1,J), + $ 1, ONE, R(1,J), 1 ) + 10 CONTINUE +C + ELSE +C + DO 20 J = 1, M + CALL DGEMV( 'Transpose', N, J, ONE, B, LDB, F(J,1), + $ LDF, ONE, R(J,1), LDR ) + 20 CONTINUE +C + END IF + END IF +C +C Compute the 1-norm of the matrix R or R + B'XB. +C Workspace: need M. +C + RNORMP = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) + WRKOPT = MAX( WRKOPT, M ) + END IF +C + IF ( DISCR ) THEN +C +C For discrete-time case, postmultiply B'X by A. +C Workspace: need N. +C + DO 30 I = 1, M + CALL DCOPY( N, F(I,1), LDF, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, A, LDA, DWORK, 1, ZERO, + $ F(I,1), LDF ) + 30 CONTINUE +C + WRKOPT = MAX( WRKOPT, N ) + END IF +C + IF( WITHL ) THEN +C +C Add L'. +C + DO 50 I = 1, M +C + DO 40 J = 1, N + F(I,J) = F(I,J) + L(J,I) + 40 CONTINUE +C + 50 CONTINUE +C + END IF +C +C Solve the matrix equation. +C + IF ( LFACTA ) THEN +C +C Case 1: Matrix R is given in a factored form. +C + IF ( LFACTD ) THEN +C +C Use QR factorization of D. +C Workspace: need min(P,M) + M, +C prefer min(P,M) + M*NB. +C + ITAU = 1 + JWORK = ITAU + MIN( P, M ) + CALL DGEQRF( P, M, R, LDR, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Make positive the diagonal elements of the triangular +C factor. Construct the strictly lower triangle, if requested. +C + DO 70 I = 1, M + IF ( R(I,I).LT.ZERO ) THEN +C + DO 60 J = I, M + R(I,J) = -R(I,J) + 60 CONTINUE +C + END IF + IF ( .NOT.LUPLOU ) + $ CALL DCOPY( I-1, R(1,I), 1, R(I,1), LDR ) + 70 CONTINUE +C + IF ( P.LT.M ) THEN + CALL DLASET( 'Full', M-P, M, ZERO, ZERO, R(P+1,1), LDR ) + IF ( .NOT.DISCR ) THEN + DWORK(2) = ZERO + INFO = M + 1 + RETURN + END IF + END IF + END IF +C + JW = 1 + IF ( DISCR ) THEN +C +C Discrete-time case. Update the factorization for B'XB. +C Try first the Cholesky factorization of X, saving the +C diagonal of X, in order to recover it, if X is not positive +C definite. In the later case, use spectral factorization. +C Workspace: need N. +C Define JW = 1 for Cholesky factorization of X, +C JW = N+3 for spectral factorization of X. +C + CALL DCOPY( N, X, LDX+1, DWORK, 1 ) + CALL DPOTRF( 'Upper', N, X, LDX, IFAIL ) + IF ( IFAIL.EQ.0 ) THEN +C +C Use Cholesky factorization of X to compute chol(X)*B. +C + OUFACT(2) = 1 + CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non unit', + $ N, M, ONE, X, LDX, B, LDB ) + ELSE +C +C Use spectral factorization of X, X = UVU'. +C Workspace: need 4*N+1, +C prefer N*(NB+2)+N+2. +C + JW = N + 3 + OUFACT(2) = 2 + CALL DCOPY( N, DWORK, 1, X, LDX+1 ) + CALL DSYEV( 'Vectors', 'Lower', N, X, LDX, DWORK(3), + $ DWORK(JW), LDWORK-JW+1, IFAIL ) + IF ( IFAIL.GT.0 ) THEN + INFO = M + 2 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(JW) )+JW-1 ) + TEMP = ABS( DWORK(N+2) )*EPS +C +C Count the negligible eigenvalues and compute sqrt(V)U'B. +C Workspace: need 2*N+2. +C + JZ = 0 +C + 80 CONTINUE + IF ( ABS( DWORK(JZ+3) ).LE.TEMP ) THEN + JZ = JZ + 1 + IF ( JZ.LT.N) GO TO 80 + END IF +C + DO 90 J = 1, M + CALL DCOPY( N, B(1,J), 1, DWORK(JW), 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, X, LDX, DWORK(JW), + $ 1, ZERO, B(1,J), 1 ) + 90 CONTINUE +C + DO 100 I = JZ + 1, N + CALL DSCAL( M, SQRT( ABS( DWORK(I+2) ) ), B(I,1), LDB + $ ) + 100 CONTINUE +C + IF ( JZ.GT.0 ) + $ CALL DLASET( 'Full', JZ, M, ZERO, ZERO, B, LDB ) + END IF +C +C Update the triangular factorization. +C + IF ( .NOT.LUPLOU ) THEN +C +C For efficiency, use the transposed of the lower triangle. +C + DO 110 I = 2, M + CALL DCOPY( I-1, R(I,1), LDR, R(1,I), 1 ) + 110 CONTINUE +C + END IF +C +C Workspace: need JW+2*M-1. +C + CALL MB04KD( 'Full', M, 0, N, R, LDR, B, LDB, DUMMY, N, + $ DUMMY, M, DWORK(JW), DWORK(JW+N) ) + WRKOPT = MAX( WRKOPT, JW + 2*M - 1 ) +C +C Make positive the diagonal elements of the triangular +C factor. +C + DO 130 I = 1, M + IF ( R(I,I).LT.ZERO ) THEN +C + DO 120 J = I, M + R(I,J) = -R(I,J) + 120 CONTINUE +C + END IF + 130 CONTINUE +C + IF ( .NOT.LUPLOU ) THEN +C +C Construct the lower triangle. +C + DO 140 I = 2, M + CALL DCOPY( I-1, R(1,I), 1, R(I,1), LDR ) + 140 CONTINUE +C + END IF + END IF +C +C Compute the condition number of the coefficient matrix. +C + IF ( .NOT.LFACTU ) THEN +C +C Workspace: need JW+3*M-1. +C + CALL DTRCON( '1-norm', UPLO, 'Non unit', M, R, LDR, RCOND, + $ DWORK(JW), IWORK, IFAIL ) + OUFACT(1) = 1 + WRKOPT = MAX( WRKOPT, JW + 3*M - 1 ) + ELSE +C +C Workspace: need 2*M. +C + CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK, + $ IWORK, INFO ) + OUFACT(1) = 2 + WRKOPT = MAX( WRKOPT, 2*M ) + END IF + DWORK(2) = RCOND + IF( RCOND.LT.EPS ) THEN + INFO = M + 1 + RETURN + END IF +C + ELSE +C +C Case 2: Matrix R is given in an unfactored form. +C +C Save the given triangle of R or R + B'XB in the other +C strict triangle and the diagonal in the workspace, and try +C Cholesky factorization. +C Workspace: need M. +C + CALL DCOPY( M, R, LDR+1, DWORK, 1 ) + IF( LUPLOU ) THEN +C + DO 150 J = 2, M + CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) + 150 CONTINUE +C + ELSE +C + DO 160 J = 2, M + CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) + 160 CONTINUE +C + END IF + CALL DPOTRF( UPLO, M, R, LDR, INFO ) + OUFACT(1) = 1 + IF( INFO.EQ.0 ) THEN +C +C Compute the reciprocal of the condition number of R. +C Workspace: need 3*M. +C + CALL DPOCON( UPLO, M, R, LDR, RNORMP, RCOND, DWORK, IWORK, + $ INFO ) +C +C Return if the matrix is singular to working precision. +C + DWORK(2) = RCOND + IF( RCOND.LT.EPS ) THEN + INFO = M + 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, 3*M ) + ELSE +C +C Use UdU' or LdL' factorization, first restoring the saved +C triangle. +C + CALL DCOPY( M, DWORK, 1, R, LDR+1 ) + IF( LUPLOU ) THEN +C + DO 170 J = 2, M + CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) + 170 CONTINUE +C + ELSE +C + DO 180 J = 2, M + CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) + 180 CONTINUE +C + END IF +C +C Workspace: need 1, +C prefer M*NB. +C + CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO ) + OUFACT(1) = 2 + IF( INFO.GT.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Compute the reciprocal of the condition number of R. +C Workspace: need 2*M. +C + CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORMP, RCOND, DWORK, + $ IWORK, INFO ) +C +C Return if the matrix is singular to working precision. +C + DWORK(2) = RCOND + IF( RCOND.LT.EPS ) THEN + INFO = M + 1 + RETURN + END IF + END IF + END IF +C + IF (OUFACT(1).EQ.1 ) THEN +C +C Solve the positive definite linear system. +C + CALL DPOTRS( UPLO, M, N, R, LDR, F, LDF, INFO ) + ELSE +C +C Solve the indefinite linear system. +C + CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, F, LDF, INFO ) + END IF +C +C Set the optimal workspace. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB02ND *** + END diff --git a/mex/sources/libslicot/SB02OD.f b/mex/sources/libslicot/SB02OD.f new file mode 100644 index 000000000..7408ba397 --- /dev/null +++ b/mex/sources/libslicot/SB02OD.f @@ -0,0 +1,856 @@ + SUBROUTINE SB02OD( DICO, JOBB, FACT, UPLO, JOBL, SORT, N, M, P, A, + $ LDA, B, LDB, Q, LDQ, R, LDR, L, LDL, RCOND, X, + $ LDX, ALFAR, ALFAI, BETA, S, LDS, T, LDT, U, + $ LDU, TOL, IWORK, DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X either the continuous-time algebraic Riccati +C equation +C -1 +C Q + A'X + XA - (L+XB)R (L+XB)' = 0 (1) +C +C or the discrete-time algebraic Riccati equation +C -1 +C X = A'XA - (L+A'XB)(R + B'XB) (L+A'XB)' + Q (2) +C +C where A, B, Q, R, and L are N-by-N, N-by-M, N-by-N, M-by-M and +C N-by-M matrices, respectively, such that Q = C'C, R = D'D and +C L = C'D; X is an N-by-N symmetric matrix. +C The routine also returns the computed values of the closed-loop +C spectrum of the system, i.e., the stable eigenvalues lambda(1), +C ..., lambda(N) of the corresponding Hamiltonian or symplectic +C pencil, in the continuous-time case or discrete-time case, +C respectively. +C -1 +C Optionally, matrix G = BR B' may be given instead of B and R. +C Other options include the case with Q and/or R given in a +C factored form, Q = C'C, R = D'D, and with L a zero matrix. +C +C The routine uses the method of deflating subspaces, based on +C reordering the eigenvalues in a generalized Schur matrix pair. +C A standard eigenproblem is solved in the continuous-time case +C if G is given. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of Riccati equation to be solved as +C follows: +C = 'C': Equation (1), continuous-time case; +C = 'D': Equation (2), discrete-time case. +C +C JOBB CHARACTER*1 +C Specifies whether or not the matrix G is given, instead +C of the matrices B and R, as follows: +C = 'B': B and R are given; +C = 'G': G is given. +C +C FACT CHARACTER*1 +C Specifies whether or not the matrices Q and/or R (if +C JOBB = 'B') are factored, as follows: +C = 'N': Not factored, Q and R are given; +C = 'C': C is given, and Q = C'C; +C = 'D': D is given, and R = D'D; +C = 'B': Both factors C and D are given, Q = C'C, R = D'D. +C +C UPLO CHARACTER*1 +C If JOBB = 'G', or FACT = 'N', specifies which triangle of +C the matrices G and Q (if FACT = 'N'), or Q and R (if +C JOBB = 'B'), is stored, as follows: +C = 'U': Upper triangle is stored; +C = 'L': Lower triangle is stored. +C +C JOBL CHARACTER*1 +C Specifies whether or not the matrix L is zero, as follows: +C = 'Z': L is zero; +C = 'N': L is nonzero. +C JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed. +C SLICOT Library routine SB02MT should be called just before +C SB02OD, for obtaining the results when JOBB = 'G' and +C JOBL = 'N'. +C +C SORT CHARACTER*1 +C Specifies which eigenvalues should be obtained in the top +C of the generalized Schur form, as follows: +C = 'S': Stable eigenvalues come first; +C = 'U': Unstable eigenvalues come first. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e. the order of the matrices +C A, Q, and X, and the number of rows of the matrices B +C and L. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. If JOBB = 'B', M is the +C order of the matrix R, and the number of columns of the +C matrix B. M >= 0. +C M is not used if JOBB = 'G'. +C +C P (input) INTEGER +C The number of system outputs. If FACT = 'C' or 'D' or 'B', +C P is the number of rows of the matrices C and/or D. +C P >= 0. +C Otherwise, P is not used. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,*) +C If JOBB = 'B', the leading N-by-M part of this array must +C contain the input matrix B of the system. +C If JOBB = 'G', the leading N-by-N upper triangular part +C (if UPLO = 'U') or lower triangular part (if UPLO = 'L') +C of this array must contain the upper triangular part or +C lower triangular part, respectively, of the matrix +C -1 +C G = BR B'. The stricly lower triangular part (if +C UPLO = 'U') or stricly upper triangular part (if +C UPLO = 'L') is not referenced. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) +C If FACT = 'N' or 'D', the leading N-by-N upper triangular +C part (if UPLO = 'U') or lower triangular part (if UPLO = +C 'L') of this array must contain the upper triangular part +C or lower triangular part, respectively, of the symmetric +C state weighting matrix Q. The stricly lower triangular +C part (if UPLO = 'U') or stricly upper triangular part (if +C UPLO = 'L') is not referenced. +C If JOBB = 'B', the triangular part of this array defined +C by UPLO is modified internally, but is restored on exit. +C If FACT = 'C' or 'B', the leading P-by-N part of this +C array must contain the output matrix C of the system. +C If JOBB = 'B', this part is modified internally, but is +C restored on exit. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= MAX(1,N) if FACT = 'N' or 'D', +C LDQ >= MAX(1,P) if FACT = 'C' or 'B'. +C +C R (input) DOUBLE PRECISION array, dimension (LDR,M) +C If FACT = 'N' or 'C', the leading M-by-M upper triangular +C part (if UPLO = 'U') or lower triangular part (if UPLO = +C 'L') of this array must contain the upper triangular part +C or lower triangular part, respectively, of the symmetric +C input weighting matrix R. The stricly lower triangular +C part (if UPLO = 'U') or stricly upper triangular part (if +C UPLO = 'L') is not referenced. +C The triangular part of this array defined by UPLO is +C modified internally, but is restored on exit. +C If FACT = 'D' or 'B', the leading P-by-M part of this +C array must contain the direct transmission matrix D of the +C system. This part is modified internally, but is restored +C on exit. +C If JOBB = 'G', this array is not referenced. +C +C LDR INTEGER +C The leading dimension of array R. +C LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C'; +C LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B'; +C LDR >= 1 if JOBB = 'G'. +C +C L (input) DOUBLE PRECISION array, dimension (LDL,M) +C If JOBL = 'N' (and JOBB = 'B'), the leading N-by-M part of +C this array must contain the cross weighting matrix L. +C This part is modified internally, but is restored on exit. +C If JOBL = 'Z' or JOBB = 'G', this array is not referenced. +C +C LDL INTEGER +C The leading dimension of array L. +C LDL >= MAX(1,N) if JOBL = 'N' and JOBB = 'B'; +C LDL >= 1 if JOBL = 'Z' or JOBB = 'G'. +C +C RCOND (output) DOUBLE PRECISION +C An estimate of the reciprocal of the condition number (in +C the 1-norm) of the N-th order system of algebraic +C equations from which the solution matrix X is obtained. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array contains the +C solution matrix X of the problem. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= MAX(1,N). +C +C ALFAR (output) DOUBLE PRECISION array, dimension (2*N) +C ALFAI (output) DOUBLE PRECISION array, dimension (2*N) +C BETA (output) DOUBLE PRECISION array, dimension (2*N) +C The generalized eigenvalues of the 2N-by-2N matrix pair, +C ordered as specified by SORT (if INFO = 0). For instance, +C if SORT = 'S', the leading N elements of these arrays +C contain the closed-loop spectrum of the system matrix +C A - BF, where F is the optimal feedback matrix computed +C based on the solution matrix X. Specifically, +C lambda(k) = [ALFAR(k)+j*ALFAI(k)]/BETA(k) for +C k = 1,2,...,N. +C If DICO = 'C' and JOBB = 'G', the elements of BETA are +C set to 1. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,*) +C The leading 2N-by-2N part of this array contains the +C ordered real Schur form S of the first matrix in the +C reduced matrix pencil associated to the optimal problem, +C or of the corresponding Hamiltonian matrix, if DICO = 'C' +C and JOBB = 'G'. That is, +C +C (S S ) +C ( 11 12) +C S = ( ), +C (0 S ) +C ( 22) +C +C where S , S and S are N-by-N matrices. +C 11 12 22 +C Array S must have 2*N+M columns if JOBB = 'B', and 2*N +C columns, otherwise. +C +C LDS INTEGER +C The leading dimension of array S. +C LDS >= MAX(1,2*N+M) if JOBB = 'B', +C LDS >= MAX(1,2*N) if JOBB = 'G'. +C +C T (output) DOUBLE PRECISION array, dimension (LDT,2*N) +C If DICO = 'D' or JOBB = 'B', the leading 2N-by-2N part of +C this array contains the ordered upper triangular form T of +C the second matrix in the reduced matrix pencil associated +C to the optimal problem. That is, +C +C (T T ) +C ( 11 12) +C T = ( ), +C (0 T ) +C ( 22) +C +C where T , T and T are N-by-N matrices. +C 11 12 22 +C If DICO = 'C' and JOBB = 'G' this array is not referenced. +C +C LDT INTEGER +C The leading dimension of array T. +C LDT >= MAX(1,2*N+M) if JOBB = 'B', +C LDT >= MAX(1,2*N) if JOBB = 'G' and DICO = 'D', +C LDT >= 1 if JOBB = 'G' and DICO = 'C'. +C +C U (output) DOUBLE PRECISION array, dimension (LDU,2*N) +C The leading 2N-by-2N part of this array contains the right +C transformation matrix U which reduces the 2N-by-2N matrix +C pencil to the ordered generalized real Schur form (S,T), +C or the Hamiltonian matrix to the ordered real Schur +C form S, if DICO = 'C' and JOBB = 'G'. That is, +C +C (U U ) +C ( 11 12) +C U = ( ), +C (U U ) +C ( 21 22) +C +C where U , U , U and U are N-by-N matrices. +C 11 12 21 22 +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,2*N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the original matrix pencil, specifically of the triangular +C factor obtained during the reduction process. If the user +C sets TOL > 0, then the given value of TOL is used as a +C lower bound for the reciprocal condition number of that +C matrix; a matrix whose estimated condition number is less +C than 1/TOL is considered to be nonsingular. If the user +C sets TOL <= 0, then a default tolerance, defined by +C TOLDEF = EPS, is used instead, where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C This parameter is not referenced if JOBB = 'G'. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK >= MAX(1,M,2*N) if JOBB = 'B', +C LIWORK >= MAX(1,2*N) if JOBB = 'G'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. If JOBB = 'B' and N > 0, DWORK(2) returns the +C reciprocal of the condition number of the M-by-M lower +C triangular matrix obtained after compressing the matrix +C pencil of order 2N+M to obtain a pencil of order 2N. +C If INFO = 0 or INFO = 6, DWORK(3) returns the scaling +C factor used internally, which should multiply the +C submatrix Y2 to recover X from the first N columns of U +C (see METHOD). +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(3,6*N), if JOBB = 'G', +C DICO = 'C'; +C LDWORK >= MAX(7*(2*N+1)+16,16*N), if JOBB = 'G', +C DICO = 'D'; +C LDWORK >= MAX(7*(2*N+1)+16,16*N,2*N+M,3*M), if JOBB = 'B'. +C For optimum performance LDWORK should be larger. +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the computed extended matrix pencil is singular, +C possibly due to rounding errors; +C = 2: if the QZ (or QR) algorithm failed; +C = 3: if reordering of the (generalized) eigenvalues +C failed; +C = 4: if after reordering, roundoff changed values of +C some complex eigenvalues so that leading eigenvalues +C in the (generalized) Schur form no longer satisfy +C the stability condition; this could also be caused +C due to scaling; +C = 5: if the computed dimension of the solution does not +C equal N; +C = 6: if a singular matrix was encountered during the +C computation of the solution matrix X. +C +C METHOD +C +C The routine uses a variant of the method of deflating subspaces +C proposed by van Dooren [1]. See also [2], [3]. +C It is assumed that (A,B) is stabilizable and (C,A) is detectable. +C Under these assumptions the algebraic Riccati equation is known to +C have a unique non-negative definite solution. +C The first step in the method of deflating subspaces is to form the +C extended Hamiltonian matrices, dimension 2N + M given by +C +C discrete-time continuous-time +C +C |A 0 B| |I 0 0| |A 0 B| |I 0 0| +C |Q -I L| - z |0 -A' 0|, |Q A' L| - s |0 -I 0|. +C |L' 0 R| |0 -B' 0| |L' B' R| |0 0 0| +C +C Next, these pencils are compressed to a form (see [1]) +C +C lambda x A - B . +C f f +C +C This generalized eigenvalue problem is then solved using the QZ +C algorithm and the stable deflating subspace Ys is determined. +C If [Y1'|Y2']' is a basis for Ys, then the required solution is +C -1 +C X = Y2 x Y1 . +C A standard eigenvalue problem is solved using the QR algorithm in +C the continuous-time case when G is given (DICO = 'C', JOBB = 'G'). +C +C REFERENCES +C +C [1] Van Dooren, P. +C A Generalized Eigenvalue Approach for Solving Riccati +C Equations. +C SIAM J. Sci. Stat. Comp., 2, pp. 121-135, 1981. +C +C [2] Mehrmann, V. +C The Autonomous Linear Quadratic Control Problem. Theory and +C Numerical Solution. +C Lect. Notes in Control and Information Sciences, vol. 163, +C Springer-Verlag, Berlin, 1991. +C +C [3] Sima, V. +C Algorithms for Linear-Quadratic Optimization. +C Pure and Applied Mathematics: A Series of Monographs and +C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C +C This routine is particularly suited for systems where the matrix R +C is ill-conditioned. Internal scaling is used. +C +C FURTHER COMMENTS +C +C To obtain a stabilizing solution of the algebraic Riccati +C equations set SORT = 'S'. +C +C The routine can also compute the anti-stabilizing solutions of +C the algebraic Riccati equations, by specifying SORT = 'U'. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB02CD by T.G.J. Beelen, Philips, +C Eindhoven, Holland. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, June 2002, +C December 2002, January 2005. +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, discrete-time system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, THREE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, + $ THREE = 3.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, FACT, JOBB, JOBL, SORT, UPLO + INTEGER INFO, LDA, LDB, LDL, LDQ, LDR, LDS, LDT, LDU, + $ LDWORK, LDX, M, N, P + DOUBLE PRECISION RCOND, TOL +C .. Array Arguments .. + LOGICAL BWORK(*) + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), ALFAI(*), ALFAR(*), B(LDB,*), BETA(*), + $ DWORK(*), L(LDL,*), Q(LDQ,*), R(LDR,*), + $ S(LDS,*), T(LDT,*), U(LDU,*), X(LDX,*) +C .. Local Scalars .. + CHARACTER QTYPE, RTYPE + LOGICAL DISCR, LFACB, LFACN, LFACQ, LFACR, LJOBB, LJOBL, + $ LJOBLN, LSCAL, LSCL, LSORT, LUPLO + INTEGER I, INFO1, J, LDW, MP, NDIM, NN, NNM, NP, NP1, + $ WRKOPT + DOUBLE PRECISION QSCAL, RCONDL, RNORM, RSCAL, SCALE, UNORM +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME, SB02MR, SB02MV, SB02OU, SB02OV, SB02OW + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02MR, SB02MV, + $ SB02OU, SB02OV, SB02OW +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGECON, DGEES, DGETRF, DGETRS, + $ DGGES, DLACPY, DLASCL, DLASET, DSCAL, DSWAP, + $ SB02OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + LJOBB = LSAME( JOBB, 'B' ) + LFACN = LSAME( FACT, 'N' ) + LFACQ = LSAME( FACT, 'C' ) + LFACR = LSAME( FACT, 'D' ) + LFACB = LSAME( FACT, 'B' ) + LUPLO = LSAME( UPLO, 'U' ) + LSORT = LSAME( SORT, 'S' ) +C + NN = 2*N + IF ( LJOBB ) THEN + LJOBL = LSAME( JOBL, 'Z' ) + LJOBLN = LSAME( JOBL, 'N' ) + NNM = NN + M + LDW = MAX( NNM, 3*M ) + ELSE + NNM = NN + LDW = 1 + END IF + NP1 = N + 1 +C +C Test the input scalar arguments. +C + IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LJOBB .AND. .NOT.LSAME( JOBB, 'G' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LFACQ .AND. .NOT.LFACR .AND. .NOT.LFACB + $ .AND. .NOT.LFACN ) THEN + INFO = -3 + ELSE IF( .NOT.LJOBB .OR. LFACN ) THEN + IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) + $ INFO = -4 + END IF + IF( INFO.EQ.0 .AND. LJOBB ) THEN + IF( .NOT.LJOBL .AND. .NOT.LJOBLN ) + $ INFO = -5 + END IF + IF( INFO.EQ.0 ) THEN + IF( .NOT.LSORT .AND. .NOT.LSAME( SORT, 'U' ) ) THEN + INFO = -6 + ELSE IF( N.LT.0 ) THEN + INFO = -7 + ELSE IF( LJOBB ) THEN + IF( M.LT.0 ) + $ INFO = -8 + END IF + END IF + IF( INFO.EQ.0 .AND. .NOT.LFACN ) THEN + IF( P.LT.0 ) + $ INFO = -9 + END IF + IF( INFO.EQ.0 ) THEN + IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( ( ( LFACN.OR.LFACR ) .AND. LDQ.LT.MAX( 1, N ) ) .OR. + $ ( ( LFACQ.OR.LFACB ) .AND. LDQ.LT.MAX( 1, P ) ) ) THEN + INFO = -15 + ELSE IF( LDR.LT.1 ) THEN + INFO = -17 + ELSE IF( LDL.LT.1 ) THEN + INFO = -19 + ELSE IF( LJOBB ) THEN + IF ( ( LFACN.OR.LFACQ ) .AND. LDR.LT.M .OR. + $ ( LFACR.OR.LFACB ) .AND. LDR.LT.P ) THEN + INFO = -17 + ELSE IF( LJOBLN .AND. LDL.LT.N ) THEN + INFO = -19 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -22 + ELSE IF( LDS.LT.MAX( 1, NNM ) ) THEN + INFO = -27 + ELSE IF( LDT.LT.1 ) THEN + INFO = -29 + ELSE IF( LDU.LT.MAX( 1, NN ) ) THEN + INFO = -31 + ELSE IF( LDWORK.LT.MAX( 3, 6*N ) ) THEN + INFO = -35 + ELSE IF( DISCR .OR. LJOBB ) THEN + IF( LDT.LT.NNM ) THEN + INFO = -29 + ELSE IF( LDWORK.LT.MAX( 14*N + 23, 16*N, LDW ) ) THEN + INFO = -35 + END IF + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB02OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + RCOND = ONE + DWORK(1) = THREE + DWORK(3) = ONE + RETURN + END IF +C +C Always scale the matrix pencil. +C + LSCAL = .TRUE. +C +C Start computations. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF ( LSCAL .AND. LJOBB ) THEN +C +C Scale the matrices Q, R, and L so that +C norm(Q) + norm(R) + norm(L) = 1, +C using the 1-norm. If Q and/or R are factored, the norms of +C the factors are used. +C Workspace: need max(N,M), if FACT = 'N'; +C N, if FACT = 'D'; +C M, if FACT = 'C'. +C + IF ( LFACN .OR. LFACR ) THEN + SCALE = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) + QTYPE = UPLO + NP = N + ELSE + SCALE = DLANGE( '1-norm', P, N, Q, LDQ, DWORK ) + QTYPE = 'G' + NP = P + END IF +C + IF ( LFACN .OR. LFACQ ) THEN + RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) + RTYPE = UPLO + MP = M + ELSE + RNORM = DLANGE( '1-norm', P, M, R, LDR, DWORK ) + RTYPE = 'G' + MP = P + END IF + SCALE = SCALE + RNORM +C + IF ( LJOBLN ) + $ SCALE = SCALE + DLANGE( '1-norm', N, M, L, LDL, DWORK ) + IF ( SCALE.EQ.ZERO ) + $ SCALE = ONE +C + IF ( LFACN .OR. LFACR ) THEN + QSCAL = SCALE + ELSE + QSCAL = SQRT( SCALE ) + END IF +C + IF ( LFACN .OR. LFACQ ) THEN + RSCAL = SCALE + ELSE + RSCAL = SQRT( SCALE ) + END IF +C + CALL DLASCL( QTYPE, 0, 0, QSCAL, ONE, NP, N, Q, LDQ, INFO1 ) + CALL DLASCL( RTYPE, 0, 0, RSCAL, ONE, MP, M, R, LDR, INFO1 ) + IF ( LJOBLN ) + $ CALL DLASCL( 'G', 0, 0, SCALE, ONE, N, M, L, LDL, INFO1 ) + END IF +C +C Construct the extended matrix pair. +C +C Workspace: need 1, if JOBB = 'G', +C max(1,2*N+M,3*M), if JOBB = 'B'; +C prefer larger. +C + CALL SB02OY( 'Optimal control', DICO, JOBB, FACT, UPLO, JOBL, + $ 'Identity E', N, M, P, A, LDA, B, LDB, Q, LDQ, R, + $ LDR, L, LDL, U, 1, S, LDS, T, LDT, TOL, IWORK, DWORK, + $ LDWORK, INFO ) +C + IF ( LSCAL .AND. LJOBB ) THEN +C +C Undo scaling of the data arrays. +C + CALL DLASCL( QTYPE, 0, 0, ONE, QSCAL, NP, N, Q, LDQ, INFO1 ) + CALL DLASCL( RTYPE, 0, 0, ONE, RSCAL, MP, M, R, LDR, INFO1 ) + IF ( LJOBLN ) + $ CALL DLASCL( 'G', 0, 0, ONE, SCALE, N, M, L, LDL, INFO1 ) + END IF +C + IF ( INFO.NE.0 ) + $ RETURN + WRKOPT = DWORK(1) + IF ( LJOBB ) RCONDL = DWORK(2) +C + IF ( LSCAL .AND. .NOT.LJOBB ) THEN +C +C This part of the code is used when G is given (JOBB = 'G'). +C A standard eigenproblem is solved in the continuous-time case. +C Scale the Hamiltonian matrix S, if DICO = 'C', or the +C symplectic pencil (S,T), if DICO = 'D', using the square roots +C of the norms of the matrices Q and G. +C Workspace: need N. +C + IF ( LFACN .OR. LFACR ) THEN + SCALE = SQRT( DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) ) + ELSE + SCALE = DLANGE( '1-norm', P, N, Q, LDQ, DWORK ) + END IF + RNORM = SQRT( DLANSY( '1-norm', UPLO, N, B, LDB, DWORK ) ) +C + LSCL = MIN( SCALE, RNORM ).GT.ZERO .AND. SCALE.NE.RNORM +C + IF( LSCL ) THEN + IF( DISCR ) THEN + CALL DLASCL( 'G', 0, 0, SCALE, RNORM, N, N, S(NP1,1), + $ LDS, INFO1 ) + CALL DLASCL( 'G', 0, 0, RNORM, SCALE, N, N, T(1,NP1), + $ LDT, INFO1 ) + ELSE + CALL DLASCL( 'G', 0, 0, SCALE, -RNORM, N, N, S(NP1,1), + $ LDS, INFO1 ) + CALL DLASCL( 'G', 0, 0, RNORM, SCALE, N, N, S(1,NP1), + $ LDS, INFO1 ) + CALL DLASCL( 'G', 0, 0, ONE, -ONE, N, N, S(NP1,NP1), + $ LDS, INFO1 ) + END IF + ELSE + IF( .NOT.DISCR ) THEN + CALL DLASCL( 'G', 0, 0, ONE, -ONE, N, NN, S(NP1,1), LDS, + $ INFO1 ) + END IF + END IF + ELSE + LSCL = .FALSE. + END IF +C +C Workspace: need max(7*(2*N+1)+16,16*N), +C if JOBB = 'B' or DICO = 'D'; +C 6*N, if JOBB = 'G' and DICO = 'C'; +C prefer larger. +C + IF ( DISCR ) THEN + IF ( LSORT ) THEN +C +C The natural tendency of the QZ algorithm to get the largest +C eigenvalues in the leading part of the matrix pair is +C exploited, by computing the unstable eigenvalues of the +C permuted matrix pair. +C + CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, T, + $ LDT, S, LDS, NDIM, ALFAR, ALFAI, BETA, U, LDU, + $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) + CALL DSWAP( N, ALFAR(NP1), 1, ALFAR, 1 ) + CALL DSWAP( N, ALFAI(NP1), 1, ALFAI, 1 ) + CALL DSWAP( N, BETA (NP1), 1, BETA, 1 ) + ELSE + CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, S, + $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, + $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) + END IF + ELSE + IF ( LJOBB ) THEN + IF ( LSORT ) THEN + CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OW, NN, + $ S, LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, + $ LDU, U, LDU, DWORK, LDWORK, BWORK, INFO1 ) + ELSE + CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OU, NN, + $ S, LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, + $ LDU, U, LDU, DWORK, LDWORK, BWORK, INFO1 ) + END IF + ELSE + IF ( LSORT ) THEN + CALL DGEES( 'Vectors', 'Sort', SB02MV, NN, S, LDS, NDIM, + $ ALFAR, ALFAI, U, LDU, DWORK, LDWORK, BWORK, + $ INFO1 ) + ELSE + CALL DGEES( 'Vectors', 'Sort', SB02MR, NN, S, LDS, NDIM, + $ ALFAR, ALFAI, U, LDU, DWORK, LDWORK, BWORK, + $ INFO1 ) + END IF + DUM(1) = ONE + CALL DCOPY( NN, DUM, 0, BETA, 1 ) + END IF + END IF + IF ( INFO1.GT.0 .AND. INFO1.LE.NN+1 ) THEN + INFO = 2 + ELSE IF ( INFO1.EQ.NN+2 ) THEN + INFO = 4 + ELSE IF ( INFO1.EQ.NN+3 ) THEN + INFO = 3 + ELSE IF ( NDIM.NE.N ) THEN + INFO = 5 + END IF + IF ( INFO.NE.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Select submatrices U1 and U2 out of the array U which define the +C solution X = U2 x inv(U1). +C Since X = X' we may obtain X as the solution of the system of +C linear equations U1' x X = U2', where +C U1 = U(1:n, 1:n), +C U2 = U(n+1:2n, 1:n). +C Use the (2,1) block of S as a workspace for factoring U1. +C + DO 20 J = 1, N + CALL DCOPY( N, U(NP1,J), 1, X(J,1), LDX ) + 20 CONTINUE +C + CALL DLACPY( 'Full', N, N, U, LDU, S(NP1,1), LDS ) +C +C Check if U1 is singular. +C + UNORM = DLANGE( '1-norm', N, N, S(NP1,1), LDS, DWORK ) +C +C Solve the system U1' x X = U2'. +C + CALL DGETRF( N, N, S(NP1,1), LDS, IWORK, INFO1 ) + IF ( INFO1.NE.0 ) THEN + INFO = 6 + DWORK(3) = ONE + IF ( LSCAL ) THEN + IF ( LJOBB ) THEN + DWORK(3) = SCALE + ELSE IF ( LSCL ) THEN + DWORK(3) = SCALE / RNORM + END IF + END IF + RETURN + ELSE +C +C Estimate the reciprocal condition of U1. +C Workspace: need 3*N. +C + CALL DGECON( '1-norm', N, S(NP1,1), LDS, UNORM, RCOND, DWORK, + $ IWORK(NP1), INFO ) +C + IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN +C +C Nearly singular matrix. Set INFO for error return. +C + INFO = 6 + RETURN + END IF + WRKOPT = MAX( WRKOPT, 3*N ) + CALL DGETRS( 'Transpose', N, N, S(NP1,1), LDS, IWORK, X, LDX, + $ INFO1 ) +C +C Set S(2,1) to zero. +C + CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) +C + IF ( LSCAL ) THEN +C +C Prepare to undo scaling for the solution X. +C + IF ( .NOT.LJOBB ) THEN + IF ( LSCL ) THEN + SCALE = SCALE / RNORM + ELSE + SCALE = ONE + END IF + END IF + DWORK(3) = SCALE + SCALE = HALF*SCALE + ELSE + DWORK(3) = ONE + SCALE = HALF + END IF +C +C Make sure the solution matrix X is symmetric. +C + DO 40 I = 1, N + CALL DAXPY( N-I+1, ONE, X(I,I), LDX, X(I,I), 1 ) + CALL DSCAL( N-I+1, SCALE, X(I,I), 1 ) + CALL DCOPY( N-I+1, X(I,I), 1, X(I,I), LDX ) + 40 CONTINUE + END IF +C + DWORK(1) = WRKOPT + IF ( LJOBB ) DWORK(2) = RCONDL +C + RETURN +C *** Last line of SB02OD *** + END diff --git a/mex/sources/libslicot/SB02OU.f b/mex/sources/libslicot/SB02OU.f new file mode 100644 index 000000000..530d202f6 --- /dev/null +++ b/mex/sources/libslicot/SB02OU.f @@ -0,0 +1,83 @@ + LOGICAL FUNCTION SB02OU( ALPHAR, ALPHAI, BETA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To select the unstable generalized eigenvalues for solving the +C continuous-time algebraic Riccati equation. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C ALPHAR (input) DOUBLE PRECISION +C The real part of the numerator of the current eigenvalue +C considered. +C +C ALPHAI (input) DOUBLE PRECISION +C The imaginary part of the numerator of the current +C eigenvalue considered. +C +C BETA (input) DOUBLE PRECISION +C The (real) denominator of the current eigenvalue +C considered. It is assumed that BETA <> 0 (regular case). +C +C METHOD +C +C The function value SB02OU is set to .TRUE. for an unstable +C eigenvalue and to .FALSE., otherwise. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB02CW by P. Van Dooren, Philips +C Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, optimal regulator, Schur form. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION ALPHAR, ALPHAI, BETA +C .. Executable Statements .. +C + SB02OU = ( ALPHAR.LT.ZERO .AND. BETA.LT.ZERO ) .OR. + $ ( ALPHAR.GT.ZERO .AND. BETA.GT.ZERO ) +C + RETURN +C *** Last line of SB02OU *** + END diff --git a/mex/sources/libslicot/SB02OV.f b/mex/sources/libslicot/SB02OV.f new file mode 100644 index 000000000..db114ae96 --- /dev/null +++ b/mex/sources/libslicot/SB02OV.f @@ -0,0 +1,88 @@ + LOGICAL FUNCTION SB02OV( ALPHAR, ALPHAI, BETA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To select the unstable generalized eigenvalues for solving the +C discrete-time algebraic Riccati equation. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C ALPHAR (input) DOUBLE PRECISION +C The real part of the numerator of the current eigenvalue +C considered. +C +C ALPHAI (input) DOUBLE PRECISION +C The imaginary part of the numerator of the current +C eigenvalue considered. +C +C BETA (input) DOUBLE PRECISION +C The (real) denominator of the current eigenvalue +C considered. +C +C METHOD +C +C The function value SB02OV is set to .TRUE. for an unstable +C eigenvalue (i.e., with modulus greater than or equal to one) and +C to .FALSE., otherwise. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB02CX by P. Van Dooren, Philips +C Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, optimal regulator, Schur form. +C +C ****************************************************************** +C + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION ALPHAR, ALPHAI, BETA +C .. External Functions .. + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2 +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + SB02OV = DLAPY2( ALPHAR, ALPHAI ).GE.ABS( BETA ) +C + RETURN +C *** Last line of SB02OV *** + END diff --git a/mex/sources/libslicot/SB02OW.f b/mex/sources/libslicot/SB02OW.f new file mode 100644 index 000000000..11de0b233 --- /dev/null +++ b/mex/sources/libslicot/SB02OW.f @@ -0,0 +1,83 @@ + LOGICAL FUNCTION SB02OW( ALPHAR, ALPHAI, BETA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To select the stable generalized eigenvalues for solving the +C continuous-time algebraic Riccati equation. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C ALPHAR (input) DOUBLE PRECISION +C The real part of the numerator of the current eigenvalue +C considered. +C +C ALPHAI (input) DOUBLE PRECISION +C The imaginary part of the numerator of the current +C eigenvalue considered. +C +C BETA (input) DOUBLE PRECISION +C The (real) denominator of the current eigenvalue +C considered. It is assumed that BETA <> 0 (regular case). +C +C METHOD +C +C The function value SB02OW is set to .TRUE. for a stable eigenvalue +C and to .FALSE., otherwise. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB02CW by P. Van Dooren, Philips +C Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, optimal regulator, Schur form. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION ALPHAR, ALPHAI, BETA +C .. Executable Statements .. +C + SB02OW = ( ALPHAR.LT.ZERO .AND. BETA.GT.ZERO ) .OR. + $ ( ALPHAR.GT.ZERO .AND. BETA.LT.ZERO ) +C + RETURN +C *** Last line of SB02OW *** + END diff --git a/mex/sources/libslicot/SB02OX.f b/mex/sources/libslicot/SB02OX.f new file mode 100644 index 000000000..b3f90b53b --- /dev/null +++ b/mex/sources/libslicot/SB02OX.f @@ -0,0 +1,87 @@ + LOGICAL FUNCTION SB02OX( ALPHAR, ALPHAI, BETA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To select the stable generalized eigenvalues for solving the +C discrete-time algebraic Riccati equation. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C ALPHAR (input) DOUBLE PRECISION +C The real part of the numerator of the current eigenvalue +C considered. +C +C ALPHAI (input) DOUBLE PRECISION +C The imaginary part of the numerator of the current +C eigenvalue considered. +C +C BETA (input) DOUBLE PRECISION +C The (real) denominator of the current eigenvalue +C considered. +C +C METHOD +C +C The function value SB02OX is set to .TRUE. for a stable eigenvalue +C (i.e., with modulus less than one) and to .FALSE., otherwise. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB02CX by P. Van Dooren, Philips +C Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, optimal regulator, Schur form. +C +C ****************************************************************** +C + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION ALPHAR, ALPHAI, BETA +C .. External Functions .. + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2 +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + SB02OX = DLAPY2( ALPHAR, ALPHAI ).LT.ABS( BETA ) +C + RETURN +C *** Last line of SB02OX *** + END diff --git a/mex/sources/libslicot/SB02OY.f b/mex/sources/libslicot/SB02OY.f new file mode 100644 index 000000000..367befee2 --- /dev/null +++ b/mex/sources/libslicot/SB02OY.f @@ -0,0 +1,791 @@ + SUBROUTINE SB02OY( TYPE, DICO, JOBB, FACT, UPLO, JOBL, JOBE, N, M, + $ P, A, LDA, B, LDB, Q, LDQ, R, LDR, L, LDL, E, + $ LDE, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the extended matrix pairs for the computation of the +C solution of the algebraic matrix Riccati equations arising in the +C problems of optimal control, both discrete and continuous-time, +C and of spectral factorization, both discrete and continuous-time. +C These matrix pairs, of dimension 2N + M, are given by +C +C discrete-time continuous-time +C +C |A 0 B| |E 0 0| |A 0 B| |E 0 0| +C |Q -E' L| - z |0 -A' 0|, |Q A' L| - s |0 -E' 0|. (1) +C |L' 0 R| |0 -B' 0| |L' B' R| |0 0 0| +C +C After construction, these pencils are compressed to a form +C (see [1]) +C +C lambda x A - B , +C f f +C +C where A and B are 2N-by-2N matrices. +C f f +C -1 +C Optionally, matrix G = BR B' may be given instead of B and R; +C then, for L = 0, 2N-by-2N matrix pairs are directly constructed as +C +C discrete-time continuous-time +C +C |A 0 | |E G | |A -G | |E 0 | +C | | - z | |, | | - s | |. (2) +C |Q -E'| |0 -A'| |Q A'| |0 -E'| +C +C Similar pairs are obtained for non-zero L, if SLICOT Library +C routine SB02MT is called before SB02OY. +C Other options include the case with E identity matrix, L a zero +C matrix, or Q and/or R given in a factored form, Q = C'C, R = D'D. +C For spectral factorization problems, there are minor differences +C (e.g., B is replaced by C'). +C The second matrix in (2) is not constructed in the continuous-time +C case if E is specified as being an identity matrix. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPE CHARACTER*1 +C Specifies the type of problem to be addressed as follows: +C = 'O': Optimal control problem; +C = 'S': Spectral factorization problem. +C +C DICO CHARACTER*1 +C Specifies the type of linear system considered as follows: +C = 'C': Continuous-time system; +C = 'D': Discrete-time system. +C +C JOBB CHARACTER*1 +C Specifies whether or not the matrix G is given, instead +C of the matrices B and R, as follows: +C = 'B': B and R are given; +C = 'G': G is given. +C For JOBB = 'G', a 2N-by-2N matrix pair is directly +C obtained assuming L = 0 (see the description of JOBL). +C +C FACT CHARACTER*1 +C Specifies whether or not the matrices Q and/or R (if +C JOBB = 'B') are factored, as follows: +C = 'N': Not factored, Q and R are given; +C = 'C': C is given, and Q = C'C; +C = 'D': D is given, and R = D'D (if TYPE = 'O'), or +C R = D + D' (if TYPE = 'S'); +C = 'B': Both factors C and D are given, Q = C'C, R = D'D +C (or R = D + D'). +C +C UPLO CHARACTER*1 +C If JOBB = 'G', or FACT = 'N', specifies which triangle of +C the matrices G and Q (if FACT = 'N'), or Q and R (if +C JOBB = 'B'), is stored, as follows: +C = 'U': Upper triangle is stored; +C = 'L': Lower triangle is stored. +C +C JOBL CHARACTER*1 +C Specifies whether or not the matrix L is zero, as follows: +C = 'Z': L is zero; +C = 'N': L is nonzero. +C JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed. +C Using SLICOT Library routine SB02MT to compute the +C corresponding A and Q in this case, before calling SB02OY, +C enables to obtain 2N-by-2N matrix pairs directly. +C +C JOBE CHARACTER*1 +C Specifies whether or not the matrix E is identity, as +C follows: +C = 'I': E is the identity matrix; +C = 'N': E is a general matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, Q, and E, and the number +C of rows of the matrices B and L. N >= 0. +C +C M (input) INTEGER +C If JOBB = 'B', M is the order of the matrix R, and the +C number of columns of the matrix B. M >= 0. +C M is not used if JOBB = 'G'. +C +C P (input) INTEGER +C If FACT = 'C' or 'D' or 'B', or if TYPE = 'S', P is the +C number of rows of the matrix C and/or D, respectively. +C P >= 0, and if JOBB = 'B' and TYPE = 'S', then P = M. +C Otherwise, P is not used. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,*) +C If JOBB = 'B', the leading N-by-M part of this array must +C contain the input matrix B of the system. +C If JOBB = 'G', the leading N-by-N upper triangular part +C (if UPLO = 'U') or lower triangular part (if UPLO = 'L') +C of this array must contain the upper triangular part or +C lower triangular part, respectively, of the matrix +C -1 +C G = BR B'. The stricly lower triangular part (if +C UPLO = 'U') or stricly upper triangular part (if +C UPLO = 'L') is not referenced. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) +C If FACT = 'N' or 'D', the leading N-by-N upper triangular +C part (if UPLO = 'U') or lower triangular part (if UPLO = +C 'L') of this array must contain the upper triangular part +C or lower triangular part, respectively, of the symmetric +C output weighting matrix Q. The stricly lower triangular +C part (if UPLO = 'U') or stricly upper triangular part (if +C UPLO = 'L') is not referenced. +C If FACT = 'C' or 'B', the leading P-by-N part of this +C array must contain the output matrix C of the system. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= MAX(1,N) if FACT = 'N' or 'D', +C LDQ >= MAX(1,P) if FACT = 'C' or 'B'. +C +C R (input) DOUBLE PRECISION array, dimension (LDR,M) +C If FACT = 'N' or 'C', the leading M-by-M upper triangular +C part (if UPLO = 'U') or lower triangular part (if UPLO = +C 'L') of this array must contain the upper triangular part +C or lower triangular part, respectively, of the symmetric +C input weighting matrix R. The stricly lower triangular +C part (if UPLO = 'U') or stricly upper triangular part (if +C UPLO = 'L') is not referenced. +C If FACT = 'D' or 'B', the leading P-by-M part of this +C array must contain the direct transmission matrix D of the +C system. +C If JOBB = 'G', this array is not referenced. +C +C LDR INTEGER +C The leading dimension of array R. +C LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C'; +C LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B'; +C LDR >= 1 if JOBB = 'G'. +C +C L (input) DOUBLE PRECISION array, dimension (LDL,M) +C If JOBL = 'N' (and JOBB = 'B'), the leading N-by-M part of +C this array must contain the cross weighting matrix L. +C If JOBL = 'Z' or JOBB = 'G', this array is not referenced. +C +C LDL INTEGER +C The leading dimension of array L. +C LDL >= MAX(1,N) if JOBL = 'N'; +C LDL >= 1 if JOBL = 'Z' or JOBB = 'G'. +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C If JOBE = 'N', the leading N-by-N part of this array must +C contain the matrix E of the descriptor system. +C If JOBE = 'I', E is taken as identity and this array is +C not referenced. +C +C LDE INTEGER +C The leading dimension of array E. +C LDE >= MAX(1,N) if JOBE = 'N'; +C LDE >= 1 if JOBE = 'I'. +C +C AF (output) DOUBLE PRECISION array, dimension (LDAF,*) +C The leading 2N-by-2N part of this array contains the +C matrix A in the matrix pencil. +C f +C Array AF must have 2*N+M columns if JOBB = 'B', and 2*N +C columns, otherwise. +C +C LDAF INTEGER +C The leading dimension of array AF. +C LDAF >= MAX(1,2*N+M) if JOBB = 'B', +C LDAF >= MAX(1,2*N) if JOBB = 'G'. +C +C BF (output) DOUBLE PRECISION array, dimension (LDBF,2*N) +C If DICO = 'D' or JOBB = 'B' or JOBE = 'N', the leading +C 2N-by-2N part of this array contains the matrix B in the +C f +C matrix pencil. +C The last M zero columns are never constructed. +C If DICO = 'C' and JOBB = 'G' and JOBE = 'I', this array +C is not referenced. +C +C LDBF INTEGER +C The leading dimension of array BF. +C LDBF >= MAX(1,2*N+M) if JOBB = 'B', +C LDBF >= MAX(1,2*N) if JOBB = 'G' and ( DICO = 'D' or +C JOBE = 'N' ), +C LDBF >= 1 if JOBB = 'G' and ( DICO = 'C' and +C JOBE = 'I' ). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the original matrix pencil, specifically of the triangular +C factor obtained during the reduction process. If the user +C sets TOL > 0, then the given value of TOL is used as a +C lower bound for the reciprocal condition number of that +C matrix; a matrix whose estimated condition number is less +C than 1/TOL is considered to be nonsingular. If the user +C sets TOL <= 0, then a default tolerance, defined by +C TOLDEF = EPS, is used instead, where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C This parameter is not referenced if JOBB = 'G'. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK >= M if JOBB = 'B', +C LIWORK >= 1 if JOBB = 'G'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. If JOBB = 'B', DWORK(2) returns the reciprocal +C of the condition number of the M-by-M lower triangular +C matrix obtained after compression. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 1 if JOBB = 'G', +C LDWORK >= MAX(1,2*N + M,3*M) if JOBB = 'B'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the computed extended matrix pencil is singular, +C possibly due to rounding errors. +C +C METHOD +C +C The extended matrix pairs are constructed, taking various options +C into account. If JOBB = 'B', the problem order is reduced from +C 2N+M to 2N (see [1]). +C +C REFERENCES +C +C [1] Van Dooren, P. +C A Generalized Eigenvalue Approach for Solving Riccati +C Equations. +C SIAM J. Sci. Stat. Comp., 2, pp. 121-135, 1981. +C +C [2] Mehrmann, V. +C The Autonomous Linear Quadratic Control Problem. Theory and +C Numerical Solution. +C Lect. Notes in Control and Information Sciences, vol. 163, +C Springer-Verlag, Berlin, 1991. +C +C [3] Sima, V. +C Algorithms for Linear-Quadratic Optimization. +C Pure and Applied Mathematics: A Series of Monographs and +C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB02CY by T.G.J. Beelen, Philips, +C Eindhoven, Holland, M. Vanbegin, and P. Van Dooren, Philips +C Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2002. +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, discrete-time system, optimal regulator, Schur form. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, FACT, JOBB, JOBE, JOBL, TYPE, UPLO + INTEGER INFO, LDA, LDAF, LDB, LDBF, LDE, LDL, LDQ, LDR, + $ LDWORK, M, N, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), AF(LDAF,*), B(LDB,*), BF(LDBF,*), + $ DWORK(*), E(LDE,*), L(LDL,*), Q(LDQ,*), R(LDR,*) +C .. Local Scalars .. + LOGICAL DISCR, LFACB, LFACN, LFACQ, LFACR, LJOBB, LJOBE, + $ LJOBL, LUPLO, OPTC + INTEGER I, ITAU, J, JWORK, N2, N2P1, NM, NNM, NP1, + $ WRKOPT + DOUBLE PRECISION RCOND, TOLDEF +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEQLF, DLACPY, DLASET, DORMQL, DSYRK, + $ DTRCON, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + INFO = 0 + OPTC = LSAME( TYPE, 'O' ) + DISCR = LSAME( DICO, 'D' ) + LJOBB = LSAME( JOBB, 'B' ) + LFACN = LSAME( FACT, 'N' ) + LFACQ = LSAME( FACT, 'C' ) + LFACR = LSAME( FACT, 'D' ) + LFACB = LSAME( FACT, 'B' ) + LUPLO = LSAME( UPLO, 'U' ) + LJOBE = LSAME( JOBE, 'I' ) + N2 = N + N + IF ( LJOBB ) THEN + LJOBL = LSAME( JOBL, 'Z' ) + NM = N + M + NNM = N2 + M + ELSE + NM = N + NNM = N2 + END IF + NP1 = N + 1 + N2P1 = N2 + 1 +C +C Test the input scalar arguments. +C + IF( .NOT.OPTC .AND. .NOT.LSAME( TYPE, 'S' ) ) THEN + INFO = -1 + ELSE IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LJOBB .AND. .NOT.LSAME( JOBB, 'G' ) ) THEN + INFO = -3 + ELSE IF( .NOT.LFACQ .AND. .NOT.LFACR .AND. .NOT.LFACB + $ .AND. .NOT.LFACN ) THEN + INFO = -4 + ELSE IF( .NOT.LJOBB .OR. LFACN ) THEN + IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) + $ INFO = -5 + ELSE IF( LJOBB ) THEN + IF( .NOT.LJOBL .AND. .NOT.LSAME( JOBL, 'N' ) ) + $ INFO = -6 + ELSE IF( .NOT.LJOBE .AND. .NOT.LSAME( JOBE, 'N' ) ) THEN + INFO = -7 + ELSE IF( N.LT.0 ) THEN + INFO = -8 + ELSE IF( LJOBB ) THEN + IF( M.LT.0 ) + $ INFO = -9 + ELSE IF( .NOT.LFACN .OR. .NOT.OPTC ) THEN + IF( P.LT.0 ) THEN + INFO = -10 + ELSE IF( LJOBB ) THEN + IF( .NOT.OPTC .AND. P.NE.M ) + $ INFO = -10 + END IF + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( ( ( LFACN.OR.LFACR ) .AND. LDQ.LT.MAX( 1, N ) ) .OR. + $ ( ( LFACQ.OR.LFACB ) .AND. LDQ.LT.MAX( 1, P ) ) ) THEN + INFO = -16 + ELSE IF( LDR.LT.1 ) THEN + INFO = -18 + ELSE IF( LJOBB ) THEN + IF ( ( LFACN.OR.LFACQ ) .AND. LDR.LT.M .OR. + $ ( LFACR.OR.LFACB ) .AND. LDR.LT.P ) THEN + INFO = -18 + ELSE IF( ( .NOT.LJOBL .AND. LDL.LT.MAX( 1, N ) ) .OR. + $ ( LJOBL .AND. LDL.LT.1 ) ) THEN + INFO = -20 + END IF + END IF + IF( ( .NOT.LJOBE .AND. LDE.LT.MAX( 1, N ) ) .OR. + $ ( LJOBE .AND. LDE.LT.1 ) ) THEN + INFO = -22 + ELSE IF( LDAF.LT.MAX( 1, NNM ) ) THEN + INFO = -24 + ELSE IF( ( ( LJOBB .OR. DISCR .OR. .NOT.LJOBE ) .AND. + $ LDBF.LT.NNM ) .OR. ( LDBF.LT.1 ) ) THEN + INFO = -26 + ELSE IF( ( LJOBB .AND. LDWORK.LT.MAX( NNM, 3*M ) ) .OR. + $ LDWORK.LT.1 ) THEN + INFO = -30 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB02OY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + DWORK(1) = ONE + IF ( N.EQ.0 ) + $ RETURN +C +C Construct the extended matrices in AF and BF, by block-columns. +C + CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF ) +C + IF ( .NOT.LFACQ .AND. .NOT.LFACB ) THEN + CALL DLACPY( UPLO, N, N, Q, LDQ, AF(NP1,1), LDAF ) + IF ( LUPLO ) THEN +C +C Construct the lower triangle of Q. +C + DO 20 J = 1, N - 1 + CALL DCOPY( N-J, Q(J,J+1), LDQ, AF(NP1+J,J), 1 ) + 20 CONTINUE +C + ELSE +C +C Construct the upper triangle of Q. +C + DO 40 J = 2, N + CALL DCOPY( J-1, Q(J,1), LDQ, AF(NP1,J), 1 ) + 40 CONTINUE +C + END IF + ELSE + CALL DSYRK( 'Upper', 'Transpose', N, P, ONE, Q, LDQ, ZERO, + $ AF(NP1,1), LDAF ) +C + DO 60 J = 2, N + CALL DCOPY( J-1, AF(NP1,J), 1, AF(N+J,1), LDAF ) + 60 CONTINUE +C + END IF +C + IF ( LJOBB ) THEN + IF ( LJOBL ) THEN + CALL DLASET( 'Full', M, N, ZERO, ZERO, AF(N2P1,1), LDAF ) + ELSE +C + DO 80 I = 1, N + CALL DCOPY( M, L(I,1), LDL, AF(N2P1,I), 1 ) + 80 CONTINUE +C + END IF + END IF +C + IF ( DISCR.OR.LJOBB ) THEN + CALL DLASET( 'Full', N, N, ZERO, ZERO, AF(1,NP1), LDAF ) + ELSE + IF ( LUPLO ) THEN +C +C Construct (1,2) block of AF using the upper triangle of G. +C + DO 140 J = 1, N +C + DO 100 I = 1, J + AF(I,N+J)= -B(I,J) + 100 CONTINUE +C + DO 120 I = J + 1, N + AF(I,N+J)= -B(J,I) + 120 CONTINUE +C + 140 CONTINUE +C + ELSE +C +C Construct (1,2) block of AF using the lower triangle of G. +C + DO 200 J = 1, N +C + DO 160 I = 1, J - 1 + AF(I,N+J)= -B(J,I) + 160 CONTINUE +C + DO 180 I = J, N + AF(I,N+J)= -B(I,J) + 180 CONTINUE +C + 200 CONTINUE +C + END IF + END IF +C + IF ( DISCR ) THEN + IF ( LJOBE ) THEN + CALL DLASET( 'Full', NM, N, ZERO, -ONE, AF(NP1,NP1), LDAF ) + ELSE +C + DO 240 J = 1, N +C + DO 220 I = 1, N + AF(N+I,N+J)= -E(J,I) + 220 CONTINUE +C + 240 CONTINUE +C + IF ( LJOBB ) + $ CALL DLASET( 'Full', M, N, ZERO, ZERO, AF(N2P1,NP1), + $ LDAF ) + END IF + ELSE +C + DO 280 J = 1, N +C + DO 260 I = 1, N + AF(N+I,N+J)= A(J,I) + 260 CONTINUE +C + 280 CONTINUE +C + IF ( LJOBB ) THEN + IF ( OPTC ) THEN +C + DO 300 J = 1, N + CALL DCOPY ( M, B(J,1), LDB, AF(N2P1,N+J), 1 ) + 300 CONTINUE +C + ELSE + CALL DLACPY( 'Full', P, N, Q, LDQ, AF(N2P1,NP1), LDAF ) + END IF + END IF + END IF +C + IF ( LJOBB ) THEN +C + IF ( OPTC ) THEN + CALL DLACPY( 'Full', N, M, B, LDB, AF(1,N2P1), LDAF ) + ELSE +C + DO 320 I = 1, P + CALL DCOPY( N, Q(I,1), LDQ, AF(1,N2+I), 1 ) + 320 CONTINUE +C + END IF +C + IF ( LJOBL ) THEN + CALL DLASET( 'Full', N, M, ZERO, ZERO, AF(NP1,N2P1), LDAF ) + ELSE + CALL DLACPY( 'Full', N, M, L, LDL, AF(NP1,N2P1), LDAF ) + END IF +C + IF ( .NOT.LFACR .AND. .NOT.LFACB ) THEN + CALL DLACPY( UPLO, M, M, R, LDR, AF(N2P1,N2P1), LDAF ) + IF ( LUPLO ) THEN +C +C Construct the lower triangle of R. +C + DO 340 J = 1, M - 1 + CALL DCOPY( M-J, R(J,J+1), LDR, AF(N2P1+J,N2+J), 1 ) + 340 CONTINUE +C + ELSE +C +C Construct the upper triangle of R. +C + DO 360 J = 2, M + CALL DCOPY( J-1, R(J,1), LDR, AF(N2P1,N2+J), 1 ) + 360 CONTINUE +C + END IF + ELSE IF ( OPTC ) THEN + CALL DSYRK( 'Upper', 'Transpose', M, P, ONE, R, LDR, ZERO, + $ AF(N2P1,N2P1), LDAF ) +C + DO 380 J = 2, M + CALL DCOPY( J-1, AF(N2P1,N2+J), 1, AF(N2+J,N2P1), LDAF ) + 380 CONTINUE +C + ELSE +C + DO 420 J = 1, M +C + DO 400 I = 1, P + AF(N2+I,N2+J) = R(I,J) + R(J,I) + 400 CONTINUE +C + 420 CONTINUE +C + END IF + END IF +C + IF ( .NOT.LJOBB .AND. .NOT.DISCR .AND. LJOBE ) + $ RETURN +C +C Construct the first two block columns of BF. +C + IF ( LJOBE ) THEN + CALL DLASET( 'Full', N+NM, N, ZERO, ONE, BF, LDBF ) + ELSE + CALL DLACPY( 'Full', N, N, E, LDE, BF, LDBF ) + CALL DLASET( 'Full', NM, N, ZERO, ZERO, BF(NP1,1), LDBF ) + END IF +C + IF ( .NOT.DISCR.OR.LJOBB ) THEN + CALL DLASET( 'Full', N, N, ZERO, ZERO, BF(1,NP1), LDBF ) + ELSE + IF ( LUPLO ) THEN +C +C Construct (1,2) block of BF using the upper triangle of G. +C + DO 480 J = 1, N +C + DO 440 I = 1, J + BF(I,N+J)= B(I,J) + 440 CONTINUE +C + DO 460 I = J + 1, N + BF(I,N+J)= B(J,I) + 460 CONTINUE +C + 480 CONTINUE +C + ELSE +C +C Construct (1,2) block of BF using the lower triangle of G. +C + DO 540 J = 1, N +C + DO 500 I = 1, J - 1 + BF(I,N+J)= B(J,I) + 500 CONTINUE +C + DO 520 I = J, N + BF(I,N+J)= B(I,J) + 520 CONTINUE +C + 540 CONTINUE +C + END IF + END IF +C + IF ( DISCR ) THEN +C + DO 580 J = 1, N +C + DO 560 I = 1, N + BF(N+I,N+J)= -A(J,I) + 560 CONTINUE +C + 580 CONTINUE +C + IF ( LJOBB ) THEN +C + IF ( OPTC ) THEN +C + DO 620 J = 1, N +C + DO 600 I = 1, M + BF(N2+I,N+J)= -B(J,I) + 600 CONTINUE +C + 620 CONTINUE +C + ELSE +C + DO 660 J = 1, N +C + DO 640 I = 1, P + BF(N2+I,N+J) = -Q(I,J) + 640 CONTINUE +C + 660 CONTINUE +C + END IF + END IF +C + ELSE + IF ( LJOBE ) THEN + CALL DLASET( 'Full', NM, N, ZERO, -ONE, BF(NP1,NP1), LDBF ) + ELSE +C + DO 700 J = 1, N +C + DO 680 I = 1, N + BF(N+I,N+J)= -E(J,I) + 680 CONTINUE +C + 700 CONTINUE +C + IF ( LJOBB ) + $ CALL DLASET( 'Full', M, N, ZERO, ZERO, BF(N2P1,NP1), + $ LDBF ) + END IF + END IF +C + IF ( .NOT.LJOBB ) + $ RETURN +C +C Compress the pencil lambda x BF - AF, using QL factorization. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C +C Workspace: need 2*M; prefer M + M*NB. +C + ITAU = 1 + JWORK = ITAU + M + CALL DGEQLF( NNM, M, AF(1,N2P1), LDAF, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = DWORK(JWORK) +C +C Workspace: need 2*N+M; prefer M + 2*N*NB. +C + CALL DORMQL( 'Left', 'Transpose', NNM, N2, M, AF(1,N2P1), LDAF, + $ DWORK(ITAU), AF, LDAF, DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + CALL DORMQL( 'Left', 'Transpose', NNM, N2, M, AF(1,N2P1), LDAF, + $ DWORK(ITAU), BF, LDBF, DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) +C +C Check the singularity of the L factor in the QL factorization: +C if singular, then the extended matrix pencil is also singular. +C Workspace 3*M. +C + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) + $ TOLDEF = DLAMCH( 'Epsilon' ) +C + CALL DTRCON( '1-norm', 'Lower', 'Non unit', M, AF(N2P1,N2P1), + $ LDAF, RCOND, DWORK, IWORK, INFO ) + WRKOPT = MAX( WRKOPT, 3*M ) +C + IF ( RCOND.LE.TOLDEF ) + $ INFO = 1 +C + DWORK(1) = WRKOPT + DWORK(2) = RCOND +C + RETURN +C *** Last line of SB02OY *** + END diff --git a/mex/sources/libslicot/SB02PD.f b/mex/sources/libslicot/SB02PD.f new file mode 100644 index 000000000..fe63ddfca --- /dev/null +++ b/mex/sources/libslicot/SB02PD.f @@ -0,0 +1,756 @@ + SUBROUTINE SB02PD( JOB, TRANA, UPLO, N, A, LDA, G, LDG, Q, LDQ, X, + $ LDX, RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the real continuous-time matrix algebraic Riccati +C equation +C +C op(A)'*X + X*op(A) + Q - X*G*X = 0, +C +C where op(A) = A or A' = A**T and G, Q are symmetric (G = G**T, +C Q = Q**T). The matrices A, G and Q are N-by-N and the solution X +C is an N-by-N symmetric matrix. +C +C An error bound on the solution and a condition estimate are also +C optionally provided. +C +C It is assumed that the matrices A, G and Q are such that the +C corresponding Hamiltonian matrix has N eigenvalues with negative +C real parts. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'X': Compute the solution only; +C = 'A': Compute all: the solution, reciprocal condition +C number, and the error bound. +C +C TRANA CHARACTER*1 +C Specifies the option op(A): +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C UPLO CHARACTER*1 +C Specifies which triangle of the matrices G and Q is +C stored, as follows: +C = 'U': Upper triangles of G and Q are stored; +C = 'L': Lower triangles of G and Q are stored. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, G, Q, and X. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C coefficient matrix A of the equation. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C G (input) DOUBLE PRECISION array, dimension (LDG,N) +C If UPLO = 'U', the leading N-by-N upper triangular part of +C this array must contain the upper triangular part of the +C matrix G. +C If UPLO = 'L', the leading N-by-N lower triangular part of +C this array must contain the lower triangular part of the +C matrix G. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= max(1,N). +C +C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) +C If UPLO = 'U', the leading N-by-N upper triangular part of +C this array must contain the upper triangular part of the +C matrix Q. +C If UPLO = 'L', the leading N-by-N lower triangular part of +C this array must contain the lower triangular part of the +C matrix Q. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= max(1,N). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C If INFO = 0, INFO = 2, or INFO = 4, the leading N-by-N +C part of this array contains the symmetric solution matrix +C X of the algebraic Riccati equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C RCOND (output) DOUBLE PRECISION +C If JOB = 'A', the estimate of the reciprocal condition +C number of the Riccati equation. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'A', the estimated forward error bound for the +C solution X. If XTRUE is the true solution, FERR bounds the +C magnitude of the largest entry in (X - XTRUE) divided by +C the magnitude of the largest entry in X. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C If JOB = 'A' and TRANA = 'N', WR and WI contain the real +C and imaginary parts, respectively, of the eigenvalues of +C the matrix A - G*X, i.e., the closed-loop system poles. +C If JOB = 'A' and TRANA = 'T' or 'C', WR and WI contain the +C real and imaginary parts, respectively, of the eigenvalues +C of the matrix A - X*G, i.e., the closed-loop system poles. +C If JOB = 'X', these arrays are not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), where +C LIWORK >= 2*N, if JOB = 'X'; +C LIWORK >= max(2*N,N*N), if JOB = 'A'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = 2, DWORK(1) contains the +C optimal value of LDWORK. If JOB = 'A', then DWORK(2:N*N+1) +C and DWORK(N*N+2:2*N*N+1) contain a real Schur form of the +C closed-loop system matrix, Ac = A - G*X (if TRANA = 'N') +C or Ac = A - X*G (if TRANA = 'T' or 'C'), and the +C orthogonal matrix which reduced Ac to real Schur form, +C respectively. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 4*N*N + 8*N + 1, if JOB = 'X'; +C LDWORK >= max( 4*N*N + 8*N, 6*N*N ) + 1, if JOB = 'A'. +C For good performance, LDWORK should be larger, e.g., +C LDWORK >= 4*N*N + 6*N +( 2*N+1 )*NB, if JOB = 'X', +C where NB is the optimal blocksize. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the Hamiltonian matrix has eigenvalues on the +C imaginary axis, so the solution and error bounds +C could not be computed; +C = 2: the iteration for the matrix sign function failed to +C converge after 50 iterations, but an approximate +C solution and error bounds (if JOB = 'A') have been +C computed; +C = 3: the system of linear equations for the solution is +C singular to working precision, so the solution and +C error bounds could not be computed; +C = 4: the matrix A-G*X (or A-X*G) cannot be reduced to +C Schur canonical form and condition number estimate +C and forward error estimate have not been computed. +C +C METHOD +C +C The Riccati equation is solved by the matrix sign function +C approach [1], [2], implementing a scaling which enhances the +C numerical stability [4]. +C +C REFERENCES +C +C [1] Bai, Z., Demmel, J., Dongarra, J., Petitet, A., Robinson, H., +C and Stanley, K. +C The spectral decomposition of nonsymmetric matrices on +C distributed memory parallel computers. +C SIAM J. Sci. Comput., vol. 18, pp. 1446-1461, 1997. +C +C [2] Byers, R., He, C., and Mehrmann, V. +C The matrix sign function method and the computation of +C invariant subspaces. +C SIAM J. Matrix Anal. Appl., vol. 18, pp. 615-632, 1997. +C +C [3] Higham, N.J. +C Perturbation theory and backward error for AX-XB=C. +C BIT, vol. 33, pp. 124-136, 1993. +C +C [4] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V., +C DGRSVX and DMSRIC: Fortran 77 subroutines for solving +C continuous-time matrix algebraic Riccati equations with +C condition and accuracy estimates. +C Preprint SFB393/98-16, Fak. f. Mathematik, Technical +C University Chemnitz, May 1998. +C +C NUMERICAL ASPECTS +C +C The solution accuracy can be controlled by the output parameter +C FERR. +C +C FURTHER COMMENTS +C +C The condition number of the Riccati equation is estimated as +C +C cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) + +C norm(Pi)*norm(G) ) / norm(X), +C +C where Omega, Theta and Pi are linear operators defined by +C +C Omega(W) = op(Ac)'*W + W*op(Ac), +C Theta(W) = inv(Omega(op(W)'*X + X*op(W))), +C Pi(W) = inv(Omega(X*W*X)), +C +C and the matrix Ac (the closed-loop system matrix) is given by +C Ac = A - G*X, if TRANA = 'N', or +C Ac = A - X*G, if TRANA = 'T' or 'C'. +C +C The program estimates the quantities +C +C sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)), +C +C norm(Theta) and norm(Pi) using 1-norm condition estimator. +C +C The forward error bound is estimated using a practical error bound +C similar to the one proposed in [3]. +C +C CONTRIBUTOR +C +C P. Petkov, Tech. University of Sofia, March 2000. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000. +C +C KEYWORDS +C +C Algebraic Riccati equation, continuous-time system, +C optimal control, optimal regulator. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 50 ) + DOUBLE PRECISION ZERO, HALF, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, + $ TWO = 2.0D+0, TEN = 10.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER JOB, TRANA, UPLO + INTEGER INFO, LDA, LDG, LDQ, LDWORK, LDX, N + DOUBLE PRECISION FERR, RCOND +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), DWORK( * ), G( LDG, * ), + $ Q( LDQ, * ), WI( * ), WR( * ), X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL ALL, LOWER, NOTRNA + CHARACTER EQUED, LOUP + INTEGER I, IAF, IB, IBR, IC, IFR, IJ, IJ1, IJ2, INFO2, + $ INI, IR, ISCL, ISV, IT, ITAU, ITER, IU, IWRK, + $ J, JI, LWAMAX, MINWRK, N2, SDIM + DOUBLE PRECISION CONV, GNORM2, EPS, HNORM, HINNRM, QNORM2, + $ SCALE, SEP, TEMP, TOL +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY, ILAENV, LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEQP3, DGESVX, DLACPY, DLASCL, + $ DLASET, DORMQR, DSCAL, DSWAP, DSYMM, DSYTRF, + $ DSYTRI, MA02AD, MA02ED, SB02QD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + ALL = LSAME( JOB, 'A' ) + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) +C + INFO = 0 + IF( .NOT.ALL .AND. .NOT.LSAME( JOB, 'X' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( TRANA, 'T' ) .AND. + $ .NOT.LSAME( TRANA, 'C' ) .AND. .NOT.NOTRNA ) THEN + INFO = -2 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDG.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE +C +C Compute workspace. +C + IF( ALL ) THEN + MINWRK = MAX( 4*N*N + 8*N + 1, 6*N*N ) + ELSE + MINWRK = 4*N*N + 8*N + 1 + END IF + IF( LDWORK.LT.MINWRK ) THEN + INFO = -19 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB02PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + IF( ALL ) THEN + RCOND = ONE + FERR = ZERO + END IF + DWORK(1) = ONE + RETURN + END IF +C +C Set tol. +C + EPS = DLAMCH( 'P' ) + TOL = TEN*DBLE( N )*EPS +C +C Compute the square-roots of the norms of the matrices Q and G . +C + QNORM2 = SQRT( DLANSY( '1', UPLO, N, Q, LDQ, DWORK ) ) + GNORM2 = SQRT( DLANSY( '1', UPLO, N, G, LDG, DWORK ) ) +C + N2 = 2*N +C +C Construct the lower (if UPLO = 'L') or upper (if UPLO = 'U') +C triangle of the symmetric block-permuted Hamiltonian matrix. +C During iteration, both the current iterate corresponding to the +C Hamiltonian matrix, and its inverse are needed. To reduce the +C workspace length, the transpose of the triangle specified by UPLO +C of the current iterate H is saved in the opposite triangle, +C suitably shifted with one column, and then the inverse of H +C overwrites H. The triangles of the saved iterate and its inverse +C are stored together in an 2*N-by-(2*N+1) matrix. For instance, if +C UPLO = 'U', then the upper triangle is built starting from the +C location 2*N+1 of the array DWORK, so that its transpose can be +C stored in the lower triangle of DWORK. +C Workspace: need 4*N*N, if UPLO = 'L'; +C 4*N*N + 2*N, if UPLO = 'U'. +C + IF ( LOWER ) THEN + INI = 0 + ISV = N2 + LOUP = 'U' +C + DO 40 J = 1, N + IJ = ( J - 1 )*N2 + J +C + DO 10 I = J, N + DWORK(IJ) = -Q(I,J) + IJ = IJ + 1 + 10 CONTINUE +C + IF( NOTRNA ) THEN +C + DO 20 I = 1, N + DWORK( IJ ) = -A( I, J ) + IJ = IJ + 1 + 20 CONTINUE +C + ELSE +C + DO 30 I = 1, N + DWORK( IJ ) = -A( J, I ) + IJ = IJ + 1 + 30 CONTINUE +C + END IF + 40 CONTINUE +C + DO 60 J = 1, N + IJ = ( N + J - 1 )*N2 + N + J +C + DO 50 I = J, N + DWORK( IJ ) = G( I, J ) + IJ = IJ + 1 + 50 CONTINUE +C + 60 CONTINUE +C + ELSE + INI = N2 + ISV = 0 + LOUP = 'L' +C + DO 80 J = 1, N + IJ = J*N2 + 1 +C + DO 70 I = 1, J + DWORK(IJ) = -Q(I,J) + IJ = IJ + 1 + 70 CONTINUE +C + 80 CONTINUE +C + DO 120 J = 1, N + IJ = ( N + J )*N2 + 1 +C + IF( NOTRNA ) THEN +C + DO 90 I = 1, N + DWORK( IJ ) = -A( J, I ) + IJ = IJ + 1 + 90 CONTINUE +C + ELSE +C + DO 100 I = 1, N + DWORK( IJ ) = -A( I, J ) + IJ = IJ + 1 + 100 CONTINUE +C + END IF +C + DO 110 I = 1, J + DWORK( IJ ) = G( I, J ) + IJ = IJ + 1 + 110 CONTINUE +C + 120 CONTINUE +C + END IF +C +C Block-scaling. +C + ISCL = 0 + IF( QNORM2.GT.GNORM2 .AND. GNORM2.GT.ZERO ) THEN + CALL DLASCL( UPLO, 0, 0, QNORM2, GNORM2, N, N, DWORK( INI+1 ), + $ N2, INFO2 ) + CALL DLASCL( UPLO, 0, 0, GNORM2, QNORM2, N, N, + $ DWORK( N2*N+N+INI+1 ), N2, INFO2 ) + ISCL = 1 + END IF +C +C Workspace usage. +C + ITAU = N2*N2 + IWRK = ITAU + N2 +C + LWAMAX = N2*ILAENV( 1, 'DSYTRF', UPLO, N2, -1, -1, -1 ) +C +C Compute the matrix sign function. +C + DO 230 ITER = 1, MAXIT +C +C Save the transpose of the corresponding triangle of the +C current iterate in the free locations of the shifted opposite +C triangle. +C Workspace: need 4*N*N + 2*N. +C + IF( LOWER ) THEN +C + DO 130 I = 1, N2 + CALL DCOPY( I, DWORK( I ), N2, DWORK( I*N2+1 ), 1 ) + 130 CONTINUE +C + ELSE +C + DO 140 I = 1, N2 + CALL DCOPY( I, DWORK( I*N2+1 ), 1, DWORK( I ), N2 ) + 140 CONTINUE +C + END IF +C +C Store the norm of the Hamiltonian matrix. +C + HNORM = DLANSY( 'F', UPLO, N2, DWORK( INI+1 ), N2, DWORK ) +C +C Compute the inverse of the block-permuted Hamiltonian matrix. +C Workspace: need 4*N*N + 2*N + 1; +C prefer 4*N*N + 2*N + 2*N*NB. +C + CALL DSYTRF( UPLO, N2, DWORK( INI+1 ), N2, IWORK, + $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C +C Workspace: need 4*N*N + 4*N. +C + CALL DSYTRI( UPLO, N2, DWORK( INI+1 ), N2, IWORK, + $ DWORK( IWRK+1 ), INFO2 ) +C +C Block-permutation of the inverse matrix. +C + IF( LOWER ) THEN +C + DO 160 J = 1, N + IJ2 = ( N + J - 1 )*N2 + N + J +C + DO 150 IJ1 = ( J - 1 )*N2 + J, ( J - 1 )*N2 + N + TEMP = DWORK( IJ1 ) + DWORK( IJ1 ) = -DWORK( IJ2 ) + DWORK( IJ2 ) = -TEMP + IJ2 = IJ2 + 1 + 150 CONTINUE +C + CALL DSWAP( J-1, DWORK( N+J ), N2, DWORK( (J-1)*N2+N+1 ), + $ 1 ) + 160 CONTINUE +C + ELSE +C + DO 180 J = 1, N + IJ2 = ( N + J )*N2 + N + 1 +C + DO 170 IJ1 = J*N2 + 1, J*N2 + J + TEMP = DWORK( IJ1 ) + DWORK( IJ1 ) = -DWORK( IJ2 ) + DWORK( IJ2 ) = -TEMP + IJ2 = IJ2 + 1 + 170 CONTINUE +C + CALL DSWAP( J-1, DWORK( (N+1)*N2+J ), N2, + $ DWORK( (N+J)*N2+1 ), 1 ) + 180 CONTINUE +C + END IF +C +C Scale the Hamiltonian matrix and its inverse and compute +C the next iterate. +C + HINNRM = DLANSY( 'F', UPLO, N2, DWORK( INI+1 ), N2, DWORK ) + SCALE = SQRT( HINNRM / HNORM ) +C + IF( LOWER ) THEN +C + DO 200 J = 1, N2 + JI = ( J - 1 )*N2 + J +C + DO 190 IJ = JI, J*N2 + JI = JI + N2 + DWORK( IJ ) = ( DWORK( IJ ) / SCALE + + $ DWORK( JI )*SCALE ) / TWO + DWORK( JI ) = DWORK( JI ) - DWORK( IJ ) + 190 CONTINUE +C + 200 CONTINUE +C + ELSE +C + DO 220 J = 1, N2 + JI = J +C + DO 210 IJ = J*N2 + 1, J*N2 + J + DWORK( IJ ) = ( DWORK( IJ ) / SCALE + + $ DWORK( JI )*SCALE ) / TWO + DWORK( JI ) = DWORK( JI ) - DWORK( IJ ) + JI = JI + N2 + 210 CONTINUE +C + 220 CONTINUE +C + END IF +C +C Test for convergence. +C + CONV = DLANSY( 'F', LOUP, N2, DWORK( ISV+1 ), N2, DWORK ) + IF( CONV.LE.TOL*HNORM ) GO TO 240 + 230 CONTINUE +C +C No convergence after MAXIT iterations, but an approximate solution +C has been found. +C + INFO = 2 +C + 240 CONTINUE +C +C If UPLO = 'U', shift the upper triangle one column to the left. +C + IF( .NOT.LOWER ) + $ CALL DLACPY( 'U', N2, N2, DWORK( INI+1 ), N2, DWORK, N2 ) +C +C Divide the triangle elements by -2 and then fill-in the other +C triangle by symmetry. +C + IF( LOWER ) THEN +C + DO 250 I = 1, N2 + CALL DSCAL( N2-I+1, -HALF, DWORK( (I-1)*N2+I ), 1 ) + 250 CONTINUE +C + ELSE +C + DO 260 I = 1, N2 + CALL DSCAL( I, -HALF, DWORK( (I-1)*N2+1 ), 1 ) + 260 CONTINUE +C + END IF + CALL MA02ED( UPLO, N2, DWORK, N2 ) +C +C Back block-permutation. +C + DO 280 J = 1, N2 +C + DO 270 I = ( J - 1 )*N2 + 1, ( J - 1 )*N2 + N + TEMP = DWORK( I ) + DWORK( I ) = -DWORK( I+N ) + DWORK( I+N ) = TEMP + 270 CONTINUE +C + 280 CONTINUE +C +C Compute the QR decomposition of the projector onto the stable +C invariant subspace. +C Workspace: need 4*N*N + 8*N + 1. +C prefer 4*N*N + 6*N + ( 2*N+1 )*NB. +C + DO 290 I = 1, N2 + IWORK( I ) = 0 + DWORK( ( I-1 )*N2 + I ) = DWORK( ( I-1 )*N2 + I ) + HALF + 290 CONTINUE +C + CALL DGEQP3( N2, N2, DWORK, N2, IWORK, DWORK( ITAU+1 ), + $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) + LWAMAX = MAX( INT( DWORK( IWRK+1 ) ), LWAMAX ) +C +C Accumulate the orthogonal transformations. Note that only the +C first N columns of the array DWORK, returned by DGEQP3, are +C needed, so that the last N columns of DWORK are used to get the +C orthogonal basis for the stable invariant subspace. +C Workspace: need 4*N*N + 3*N. +C prefer 4*N*N + 2*N + N*NB. +C + IB = N*N + IAF = N2*N + CALL DLASET( 'F', N2, N, ZERO, ONE, DWORK( IAF+1 ), N2 ) + CALL DORMQR( 'L', 'N', N2, N, N, DWORK, N2, DWORK( ITAU+1 ), + $ DWORK( IAF+1 ), N2, DWORK( IWRK+1 ), LDWORK-IWRK, + $ INFO2 ) + LWAMAX = IWRK + MAX( INT( DWORK( IWRK+1 ) ), LWAMAX ) +C +C Store the matrices V11 and V21' . +C + CALL DLACPY( 'F', N, N, DWORK( IAF+1 ), N2, DWORK, N ) + CALL MA02AD( 'F', N, N, DWORK( IAF+N+1 ), N2, DWORK( IB+1 ), N ) +C + IR = IAF + IB + IC = IR + N + IFR = IC + N + IBR = IFR + N + IWRK = IBR + N +C +C Compute the solution matrix X . +C Workspace: need 3*N*N + 8*N. +C + CALL DGESVX( 'E', 'T', N, N, DWORK, N, DWORK( IAF+1 ), N, + $ IWORK, EQUED, DWORK( IR+1 ), DWORK( IC+1 ), + $ DWORK( IB+1 ), N, X, LDX, RCOND, DWORK( IFR+1 ), + $ DWORK( IBR+1 ), DWORK( IWRK+1 ), IWORK( N+1 ), + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 3 + RETURN + END IF +C +C Symmetrize the solution. +C + DO 310 I = 1, N - 1 +C + DO 300 J = I + 1, N + TEMP = ( X( I, J ) + X( J, I ) ) / TWO + X( I, J ) = TEMP + X( J, I ) = TEMP + 300 CONTINUE +C + 310 CONTINUE +C +C Undo scaling for the solution matrix. +C + IF( ISCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, GNORM2, QNORM2, N, N, X, LDX, INFO2 ) + END IF +C + IF( ALL ) THEN +C +C Compute the estimates of the reciprocal condition number and +C error bound. +C Workspace usage. +C + IT = 1 + IU = IT + N*N + IWRK = IU + N*N +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IT+1 ), N ) + IF( NOTRNA ) THEN +C +C Compute Ac = A-G*X . +C + CALL DSYMM( 'L', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, + $ DWORK( IT+1 ), N ) + ELSE +C +C Compute Ac = A-X*G . +C + CALL DSYMM( 'R', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, + $ DWORK( IT+1 ), N ) + END IF +C +C Compute the Schur factorization of Ac . +C Workspace: need 2*N*N + 5*N + 1; +C prefer larger. +C + CALL DGEES( 'V', 'N', SELECT, N, DWORK( IT+1 ), N, SDIM, WR, + $ WI, DWORK( IU+1 ), N, DWORK( IWRK+1 ), LDWORK-IWRK, + $ BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 4 + RETURN + END IF + LWAMAX = IWRK + MAX( INT( DWORK( IWRK+1 ) ), LWAMAX ) +C +C Estimate the reciprocal condition number and the forward error. +C Workspace: need 6*N*N + 1; +C prefer larger. +C + CALL SB02QD( 'B', 'F', TRANA, UPLO, 'O', N, A, LDA, + $ DWORK( IT+1 ), N, DWORK( IU+1 ), N, G, LDG, Q, + $ LDQ, X, LDX, SEP, RCOND, FERR, IWORK, + $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) + LWAMAX = IWRK + MAX( INT( DWORK( IWRK+1 ) ), LWAMAX ) + END IF +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB02PD + END diff --git a/mex/sources/libslicot/SB02QD.f b/mex/sources/libslicot/SB02QD.f new file mode 100644 index 000000000..8ce39d1b3 --- /dev/null +++ b/mex/sources/libslicot/SB02QD.f @@ -0,0 +1,804 @@ + SUBROUTINE SB02QD( JOB, FACT, TRANA, UPLO, LYAPUN, N, A, LDA, T, + $ LDT, U, LDU, G, LDG, Q, LDQ, X, LDX, SEP, + $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the conditioning and compute an error bound on the +C solution of the real continuous-time matrix algebraic Riccati +C equation +C +C op(A)'*X + X*op(A) + Q - X*G*X = 0, (1) +C +C where op(A) = A or A' (A**T) and Q, G are symmetric (Q = Q**T, +C G = G**T). The matrices A, Q and G are N-by-N and the solution X +C is N-by-N. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'C': Compute the reciprocal condition number only; +C = 'E': Compute the error bound only; +C = 'B': Compute both the reciprocal condition number and +C the error bound. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization of +C the matrix Ac = A - G*X (if TRANA = 'N') or Ac = A - X*G +C (if TRANA = 'T' or 'C') is supplied on entry, as follows: +C = 'F': On entry, T and U (if LYAPUN = 'O') contain the +C factors from the real Schur factorization of the +C matrix Ac; +C = 'N': The Schur factorization of Ac will be computed +C and the factors will be stored in T and U (if +C LYAPUN = 'O'). +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C UPLO CHARACTER*1 +C Specifies which part of the symmetric matrices Q and G is +C to be used, as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part. +C +C LYAPUN CHARACTER*1 +C Specifies whether or not the original Lyapunov equations +C should be solved in the iterative estimation process, +C as follows: +C = 'O': Solve the original Lyapunov equations, updating +C the right-hand sides and solutions with the +C matrix U, e.g., RHS <-- U'*RHS*U; +C = 'R': Solve reduced Lyapunov equations only, without +C updating the right-hand sides and solutions. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X, Q, and G. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of +C this array must contain the matrix A. +C If FACT = 'F' and LYAPUN = 'R', A is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= max(1,N), if FACT = 'N' or LYAPUN = 'O'; +C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. +C +C T (input or output) DOUBLE PRECISION array, dimension +C (LDT,N) +C If FACT = 'F', then T is an input argument and on entry, +C the leading N-by-N upper Hessenberg part of this array +C must contain the upper quasi-triangular matrix T in Schur +C canonical form from a Schur factorization of Ac (see +C argument FACT). +C If FACT = 'N', then T is an output argument and on exit, +C if INFO = 0 or INFO = N+1, the leading N-by-N upper +C Hessenberg part of this array contains the upper quasi- +C triangular matrix T in Schur canonical form from a Schur +C factorization of Ac (see argument FACT). +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= max(1,N). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,N) +C If LYAPUN = 'O' and FACT = 'F', then U is an input +C argument and on entry, the leading N-by-N part of this +C array must contain the orthogonal matrix U from a real +C Schur factorization of Ac (see argument FACT). +C If LYAPUN = 'O' and FACT = 'N', then U is an output +C argument and on exit, if INFO = 0 or INFO = N+1, it +C contains the orthogonal N-by-N matrix from a real Schur +C factorization of Ac (see argument FACT). +C If LYAPUN = 'R', the array U is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= 1, if LYAPUN = 'R'; +C LDU >= MAX(1,N), if LYAPUN = 'O'. +C +C G (input) DOUBLE PRECISION array, dimension (LDG,N) +C If UPLO = 'U', the leading N-by-N upper triangular part of +C this array must contain the upper triangular part of the +C matrix G. +C If UPLO = 'L', the leading N-by-N lower triangular part of +C this array must contain the lower triangular part of the +C matrix G. _ +C Matrix G should correspond to G in the "reduced" Riccati +C equation (with matrix T, instead of A), if LYAPUN = 'R'. +C See METHOD. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= max(1,N). +C +C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) +C If UPLO = 'U', the leading N-by-N upper triangular part of +C this array must contain the upper triangular part of the +C matrix Q. +C If UPLO = 'L', the leading N-by-N lower triangular part of +C this array must contain the lower triangular part of the +C matrix Q. _ +C Matrix Q should correspond to Q in the "reduced" Riccati +C equation (with matrix T, instead of A), if LYAPUN = 'R'. +C See METHOD. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= max(1,N). +C +C X (input) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array must contain the +C symmetric solution matrix of the original Riccati +C equation (with matrix A), if LYAPUN = 'O', or of the +C "reduced" Riccati equation (with matrix T), if +C LYAPUN = 'R'. See METHOD. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C SEP (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'B', the estimated quantity +C sep(op(Ac),-op(Ac)'). +C If N = 0, or X = 0, or JOB = 'E', SEP is not referenced. +C +C RCOND (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal +C condition number of the continuous-time Riccati equation. +C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. +C If JOB = 'E', RCOND is not referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'E' or JOB = 'B', an estimated forward error +C bound for the solution X. If XTRUE is the true solution, +C FERR bounds the magnitude of the largest entry in +C (X - XTRUE) divided by the magnitude of the largest entry +C in X. +C If N = 0 or X = 0, FERR is set to 0. +C If JOB = 'C', FERR is not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C Let LWA = N*N, if LYAPUN = 'O' and JOB = 'E' or 'B'; +C LWA = 0, otherwise. +C If FACT = 'N', then +C LDWORK = MAX(1, 5*N, 2*N*N), if JOB = 'C'; +C LDWORK = MAX(1, LWA + 5*N, 4*N*N ), if JOB = 'E', 'B'. +C If FACT = 'F', then +C LDWORK = MAX(1, 2*N*N), if JOB = 'C'; +C LDWORK = MAX(1, 4*N*N ), if JOB = 'E' or 'B'. +C For good performance, LDWORK must generally be larger. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, i <= N, the QR algorithm failed to +C complete the reduction of the matrix Ac to Schur +C canonical form (see LAPACK Library routine DGEES); +C on exit, the matrix T(i+1:N,i+1:N) contains the +C partially converged Schur form, and DWORK(i+1:N) and +C DWORK(N+i+1:2*N) contain the real and imaginary +C parts, respectively, of the converged eigenvalues; +C this error is unlikely to appear; +C = N+1: if the matrices T and -T' have common or very +C close eigenvalues; perturbed values were used to +C solve Lyapunov equations, but the matrix T, if given +C (for FACT = 'F'), is unchanged. +C +C METHOD +C +C The condition number of the Riccati equation is estimated as +C +C cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) + +C norm(Pi)*norm(G) ) / norm(X), +C +C where Omega, Theta and Pi are linear operators defined by +C +C Omega(W) = op(Ac)'*W + W*op(Ac), +C Theta(W) = inv(Omega(op(W)'*X + X*op(W))), +C Pi(W) = inv(Omega(X*W*X)), +C +C and Ac = A - G*X (if TRANA = 'N') or Ac = A - X*G (if TRANA = 'T' +C or 'C'). Note that the Riccati equation (1) is equivalent to +C _ _ _ _ _ _ +C op(T)'*X + X*op(T) + Q + X*G*X = 0, (2) +C _ _ _ +C where X = U'*X*U, Q = U'*Q*U, and G = U'*G*U, with U the +C orthogonal matrix reducing Ac to a real Schur form, T = U'*Ac*U. +C +C The routine estimates the quantities +C +C sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)), +C +C norm(Theta) and norm(Pi) using 1-norm condition estimator. +C +C The forward error bound is estimated using a practical error bound +C similar to the one proposed in [2]. +C +C REFERENCES +C +C [1] Ghavimi, A.R. and Laub, A.J. +C Backward error, sensitivity, and refinement of computed +C solutions of algebraic Riccati equations. +C Numerical Linear Algebra with Applications, vol. 2, pp. 29-49, +C 1995. +C +C [2] Higham, N.J. +C Perturbation theory and backward error for AX-XB=C. +C BIT, vol. 33, pp. 124-136, 1993. +C +C [3] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. +C DGRSVX and DMSRIC: Fortran 77 subroutines for solving +C continuous-time matrix algebraic Riccati equations with +C condition and accuracy estimates. +C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. +C Chemnitz, May 1998. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C The accuracy of the estimates obtained depends on the solution +C accuracy and on the properties of the 1-norm estimator. +C +C FURTHER COMMENTS +C +C The option LYAPUN = 'R' may occasionally produce slightly worse +C or better estimates, and it is much faster than the option 'O'. +C When SEP is computed and it is zero, the routine returns +C immediately, with RCOND and FERR (if requested) set to 0 and 1, +C respectively. In this case, the equation is singular. +C +C CONTRIBUTOR +C +C P.Hr. Petkov, Technical University of Sofia, December 1998. +C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. +C +C KEYWORDS +C +C Conditioning, error estimates, orthogonal transformation, +C real Schur form, Riccati equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, FOUR, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+0, HALF = 0.5D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO + INTEGER INFO, LDA, LDG, LDQ, LDT, LDU, LDWORK, LDX, N + DOUBLE PRECISION FERR, RCOND, SEP +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), DWORK( * ), G( LDG, * ), + $ Q( LDQ, * ), T( LDT, * ), U( LDU, * ), + $ X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL JOBB, JOBC, JOBE, LOWER, NEEDAC, NOFACT, + $ NOTRNA, UPDATE + CHARACTER LOUP, SJOB, TRANAT + INTEGER I, IABS, INFO2, IRES, ITMP, IXBS, J, JJ, JX, + $ KASE, LDW, LWA, NN, SDIM, WRKOPT + DOUBLE PRECISION ANORM, BIGNUM, DENOM, EPS, EPSN, EST, GNORM, + $ PINORM, QNORM, SCALE, SIG, TEMP, THNORM, TMAX, + $ XANORM, XNORM +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEES, DLACON, DLACPY, DSCAL, + $ DSYMM, DSYR2K, MA02ED, MB01RU, MB01UD, SB03MY, + $ SB03QX, SB03QY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + JOBC = LSAME( JOB, 'C' ) + JOBE = LSAME( JOB, 'E' ) + JOBB = LSAME( JOB, 'B' ) + NOFACT = LSAME( FACT, 'N' ) + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + UPDATE = LSAME( LYAPUN, 'O' ) +C + NEEDAC = UPDATE .AND. .NOT.JOBC +C + NN = N*N + IF( NEEDAC ) THEN + LWA = NN + ELSE + LWA = 0 + END IF +C + IF( NOFACT ) THEN + IF( JOBC ) THEN + LDW = MAX( 5*N, 2*NN ) + ELSE + LDW = MAX( LWA + 5*N, 4*NN ) + END IF + ELSE + IF( JOBC ) THEN + LDW = 2*NN + ELSE + LDW = 4*NN + END IF + END IF +C + INFO = 0 + IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN + INFO = -1 + ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. + $ LSAME( TRANA, 'C' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.1 .OR. + $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN + INFO = -12 + ELSE IF( LDG.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDWORK.LT.MAX( 1, LDW ) ) THEN + INFO = -24 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB02QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + IF( .NOT.JOBE ) + $ RCOND = ONE + IF( .NOT.JOBC ) + $ FERR = ZERO + DWORK( 1 ) = ONE + RETURN + END IF +C +C Compute the 1-norm of the matrix X. +C + XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK ) + IF( XNORM.EQ.ZERO ) THEN +C +C The solution is zero. +C + IF( .NOT.JOBE ) + $ RCOND = ZERO + IF( .NOT.JOBC ) + $ FERR = ZERO + DWORK( 1 ) = DBLE( N ) + RETURN + END IF +C +C Workspace usage. +C + IXBS = 0 + ITMP = IXBS + NN + IABS = ITMP + NN + IRES = IABS + NN +C +C Workspace: LWR, where +C LWR = N*N, if LYAPUN = 'O' and JOB = 'E' or 'B', or +C FACT = 'N', +C LWR = 0, otherwise. +C + IF( NEEDAC .OR. NOFACT ) THEN +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) + IF( NOTRNA ) THEN +C +C Compute Ac = A - G*X. +C + CALL DSYMM( 'Left', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, + $ DWORK, N ) + ELSE +C +C Compute Ac = A - X*G. +C + CALL DSYMM( 'Right', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, + $ DWORK, N ) + END IF +C + WRKOPT = DBLE( NN ) + IF( NOFACT ) + $ CALL DLACPY( 'Full', N, N, DWORK, N, T, LDT ) + ELSE + WRKOPT = DBLE( N ) + END IF +C + IF( NOFACT ) THEN +C +C Compute the Schur factorization of Ac, Ac = U*T*U'. +C Workspace: need LWA + 5*N; +C prefer larger; +C LWA = N*N, if LYAPUN = 'O' and JOB = 'E' or 'B'; +C LWA = 0, otherwise. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + IF( UPDATE ) THEN + SJOB = 'V' + ELSE + SJOB = 'N' + END IF + CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, + $ DWORK( LWA+1 ), DWORK( LWA+N+1 ), U, LDU, + $ DWORK( LWA+2*N+1 ), LDWORK-LWA-2*N, BWORK, INFO ) + IF( INFO.GT.0 ) THEN + IF( LWA.GT.0 ) + $ CALL DCOPY( 2*N, DWORK( LWA+1 ), 1, DWORK, 1 ) + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, INT( DWORK( LWA+2*N+1 ) ) + LWA + 2*N ) + END IF + IF( NEEDAC ) + $ CALL DLACPY( 'Full', N, N, DWORK, N, DWORK( IABS+1 ), N ) +C + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +C + IF( .NOT.JOBE ) THEN +C +C Estimate sep(op(Ac),-op(Ac)') = sep(op(T),-op(T)') and +C norm(Theta). +C Workspace LWA + 2*N*N. +C + CALL SB03QY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX, + $ SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) +C + WRKOPT = MAX( WRKOPT, LWA + 2*NN ) +C +C Return if the equation is singular. +C + IF( SEP.EQ.ZERO ) THEN + RCOND = ZERO + IF( JOBB ) + $ FERR = ONE + DWORK( 1 ) = DBLE( WRKOPT ) + RETURN + END IF +C +C Estimate norm(Pi). +C Workspace LWA + 2*N*N. +C + KASE = 0 +C +C REPEAT + 10 CONTINUE + CALL DLACON( NN, DWORK( ITMP+1 ), DWORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +C +C Select the triangular part of symmetric matrix to be used. +C + IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP+1 )) + $ .GE. + $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP+1 )) + $ ) THEN + LOUP = 'U' + ELSE + LOUP = 'L' + END IF +C +C Compute RHS = X*W*X. +C + CALL MB01RU( LOUP, 'No Transpose', N, N, ZERO, ONE, DWORK, + $ N, X, LDX, DWORK, N, DWORK( ITMP+1 ), NN, + $ INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) +C + IF( UPDATE ) THEN +C +C Transform the right-hand side: RHS := U'*RHS*U. +C + CALL MB01RU( LOUP, 'Transpose', N, N, ZERO, ONE, DWORK, + $ N, U, LDU, DWORK, N, DWORK( ITMP+1 ), NN, + $ INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) + END IF +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( LOUP, N, DWORK, N ) +C + IF( KASE.EQ.1 ) THEN +C +C Solve op(T)'*Y + Y*op(T) = scale*RHS. +C + CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 ) + ELSE +C +C Solve op(T)*W + W*op(T)' = scale*RHS. +C + CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 ) + END IF +C + IF( UPDATE ) THEN +C +C Transform back to obtain the solution: Z := U*Z*U', with +C Z = Y or Z = W. +C + CALL MB01RU( LOUP, 'No transpose', N, N, ZERO, ONE, + $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP+1 ), + $ NN, INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( LOUP, N, DWORK, N ) + END IF + GO TO 10 + END IF +C UNTIL KASE = 0 +C + IF( EST.LT.SCALE ) THEN + PINORM = EST / SCALE + ELSE + BIGNUM = ONE / DLAMCH( 'Safe minimum' ) + IF( EST.LT.SCALE*BIGNUM ) THEN + PINORM = EST / SCALE + ELSE + PINORM = BIGNUM + END IF + END IF +C +C Compute the 1-norm of A or T. +C + IF( UPDATE ) THEN + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) + ELSE + ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) + END IF +C +C Compute the 1-norms of the matrices Q and G. +C + QNORM = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) + GNORM = DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) +C +C Estimate the reciprocal condition number. +C + TMAX = MAX( SEP, XNORM, ANORM, GNORM ) + IF( TMAX.LE.ONE ) THEN + TEMP = SEP*XNORM + DENOM = QNORM + ( SEP*ANORM )*THNORM + + $ ( SEP*GNORM )*PINORM + ELSE + TEMP = ( SEP / TMAX )*( XNORM / TMAX ) + DENOM = ( ( ONE / TMAX )*( QNORM / TMAX ) ) + + $ ( ( SEP / TMAX )*( ANORM / TMAX ) )*THNORM + + $ ( ( SEP / TMAX )*( GNORM / TMAX ) )*PINORM + END IF + IF( TEMP.GE.DENOM ) THEN + RCOND = ONE + ELSE + RCOND = TEMP / DENOM + END IF + END IF +C + IF( .NOT.JOBC ) THEN +C +C Form a triangle of the residual matrix +C R = op(A)'*X + X*op(A) + Q - X*G*X, +C or _ _ _ _ _ _ +C R = op(T)'*X + X*op(T) + Q + X*G*X, +C exploiting the symmetry. +C Workspace 4*N*N. +C + IF( UPDATE ) THEN + CALL DLACPY( UPLO, N, N, Q, LDQ, DWORK( IRES+1 ), N ) + CALL DSYR2K( UPLO, TRANAT, N, N, ONE, A, LDA, X, LDX, ONE, + $ DWORK( IRES+1 ), N ) + SIG = -ONE + ELSE + CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, + $ DWORK( IRES+1 ), N, INFO2 ) + JJ = IRES + 1 + IF( LOWER ) THEN + DO 20 J = 1, N + CALL DAXPY( N-J+1, ONE, DWORK( JJ ), N, DWORK( JJ ), + $ 1 ) + CALL DAXPY( N-J+1, ONE, Q( J, J ), 1, DWORK( JJ ), 1 ) + JJ = JJ + N + 1 + 20 CONTINUE + ELSE + DO 30 J = 1, N + CALL DAXPY( J, ONE, DWORK( IRES+J ), N, DWORK( JJ ), + $ 1 ) + CALL DAXPY( J, ONE, Q( 1, J ), 1, DWORK( JJ ), 1 ) + JJ = JJ + N + 30 CONTINUE + END IF + SIG = ONE + END IF + CALL MB01RU( UPLO, TRANAT, N, N, ONE, SIG, DWORK( IRES+1 ), + $ N, X, LDX, G, LDG, DWORK( ITMP+1 ), NN, INFO2 ) +C +C Get the machine precision. +C + EPS = DLAMCH( 'Epsilon' ) + EPSN = EPS*DBLE( N + 4 ) + TEMP = EPS*FOUR +C +C Add to abs(R) a term that takes account of rounding errors in +C forming R: +C abs(R) := abs(R) + EPS*(4*abs(Q) + (n+4)*(abs(op(Ac))'*abs(X) +C + abs(X)*abs(op(Ac))) + 2*(n+1)*abs(X)*abs(G)*abs(X)), +C or _ _ +C abs(R) := abs(R) + EPS*(4*abs(Q) + (n+4)*(abs(op(T))'*abs(X) +C _ _ _ _ +C + abs(X)*abs(op(T))) + 2*(n+1)*abs(X)*abs(G)*abs(X)), +C where EPS is the machine precision. +C + DO 50 J = 1, N + DO 40 I = 1, N + DWORK( IXBS+(J-1)*N+I ) = ABS( X( I, J ) ) + 40 CONTINUE + 50 CONTINUE +C + IF( LOWER ) THEN + DO 70 J = 1, N + DO 60 I = J, N + DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( Q( I, J ) ) + + $ ABS( DWORK( IRES+(J-1)*N+I ) ) + 60 CONTINUE + 70 CONTINUE + ELSE + DO 90 J = 1, N + DO 80 I = 1, J + DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( Q( I, J ) ) + + $ ABS( DWORK( IRES+(J-1)*N+I ) ) + 80 CONTINUE + 90 CONTINUE + END IF +C + IF( UPDATE ) THEN +C + DO 110 J = 1, N + DO 100 I = 1, N + DWORK( IABS+(J-1)*N+I ) = + $ ABS( DWORK( IABS+(J-1)*N+I ) ) + 100 CONTINUE + 110 CONTINUE +C + CALL DSYR2K( UPLO, TRANAT, N, N, EPSN, DWORK( IABS+1 ), N, + $ DWORK( IXBS+1 ), N, ONE, DWORK( IRES+1 ), N ) + ELSE +C + DO 130 J = 1, N + DO 120 I = 1, MIN( J+1, N ) + DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) + 120 CONTINUE + 130 CONTINUE +C + CALL MB01UD( 'Left', TRANAT, N, N, EPSN, DWORK( IABS+1 ), N, + $ DWORK( IXBS+1), N, DWORK( ITMP+1 ), N, INFO2 ) + JJ = IRES + 1 + JX = ITMP + 1 + IF( LOWER ) THEN + DO 140 J = 1, N + CALL DAXPY( N-J+1, ONE, DWORK( JX ), N, DWORK( JX ), + $ 1 ) + CALL DAXPY( N-J+1, ONE, DWORK( JX ), 1, DWORK( JJ ), + $ 1 ) + JJ = JJ + N + 1 + JX = JX + N + 1 + 140 CONTINUE + ELSE + DO 150 J = 1, N + CALL DAXPY( J, ONE, DWORK( ITMP+J ), N, DWORK( JX ), + $ 1 ) + CALL DAXPY( J, ONE, DWORK( JX ), 1, DWORK( JJ ), 1 ) + JJ = JJ + N + JX = JX + N + 150 CONTINUE + END IF + END IF +C + IF( LOWER ) THEN + DO 170 J = 1, N + DO 160 I = J, N + DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) + 160 CONTINUE + 170 CONTINUE + ELSE + DO 190 J = 1, N + DO 180 I = 1, J + DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) + 180 CONTINUE + 190 CONTINUE + END IF +C + CALL MB01RU( UPLO, TRANA, N, N, ONE, EPS*DBLE( 2*( N + 1 ) ), + $ DWORK( IRES+1 ), N, DWORK( IXBS+1), N, + $ DWORK( IABS+1 ), N, DWORK( ITMP+1 ), NN, INFO2 ) +C + WRKOPT = MAX( WRKOPT, 4*NN ) +C +C Compute forward error bound, using matrix norm estimator. +C Workspace 4*N*N. +C + XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) +C + CALL SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, + $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK, IRES, + $ INFO ) + END IF +C + DWORK( 1 ) = DBLE( WRKOPT ) + RETURN +C +C *** Last line of SB02QD *** + END diff --git a/mex/sources/libslicot/SB02RD.f b/mex/sources/libslicot/SB02RD.f new file mode 100644 index 000000000..e4d14172f --- /dev/null +++ b/mex/sources/libslicot/SB02RD.f @@ -0,0 +1,1133 @@ + SUBROUTINE SB02RD( JOB, DICO, HINV, TRANA, UPLO, SCAL, SORT, FACT, + $ LYAPUN, N, A, LDA, T, LDT, V, LDV, G, LDG, Q, + $ LDQ, X, LDX, SEP, RCOND, FERR, WR, WI, S, LDS, + $ IWORK, DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X either the continuous-time algebraic Riccati +C equation +C -1 +C Q + op(A)'*X + X*op(A) - X*op(B)*R op(B)'*X = 0, (1) +C +C or the discrete-time algebraic Riccati equation +C -1 +C X = op(A)'*X*op(A) - op(A)'*X*op(B)*(R + op(B)'*X*op(B)) * +C op(B)'*X*op(A) + Q, (2) +C +C where op(M) = M or M' (M**T), A, op(B), Q, and R are N-by-N, +C N-by-M, N-by-N, and M-by-M matrices respectively, with Q symmetric +C and R symmetric nonsingular; X is an N-by-N symmetric matrix. +C -1 +C The matrix G = op(B)*R *op(B)' must be provided on input, instead +C of B and R, that is, the continuous-time equation +C +C Q + op(A)'*X + X*op(A) - X*G*X = 0, (3) +C +C or the discrete-time equation +C -1 +C Q + op(A)'*X*(I_n + G*X) *op(A) - X = 0, (4) +C +C are solved, where G is an N-by-N symmetric matrix. SLICOT Library +C routine SB02MT should be used to compute G, given B and R. SB02MT +C also enables to solve Riccati equations corresponding to optimal +C problems with coupling terms. +C +C The routine also returns the computed values of the closed-loop +C spectrum of the optimal system, i.e., the stable eigenvalues +C lambda(1),...,lambda(N) of the corresponding Hamiltonian or +C symplectic matrix associated to the optimal problem. It is assumed +C that the matrices A, G, and Q are such that the associated +C Hamiltonian or symplectic matrix has N stable eigenvalues, i.e., +C with negative real parts, in the continuous-time case, and with +C moduli less than one, in the discrete-time case. +C +C Optionally, estimates of the conditioning and error bound on the +C solution of the Riccati equation (3) or (4) are returned. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'X': Compute the solution only; +C = 'C': Compute the reciprocal condition number only; +C = 'E': Compute the error bound only; +C = 'A': Compute all: the solution, reciprocal condition +C number, and the error bound. +C +C DICO CHARACTER*1 +C Specifies the type of Riccati equation to be solved or +C analyzed, as follows: +C = 'C': Equation (3), continuous-time case; +C = 'D': Equation (4), discrete-time case. +C +C HINV CHARACTER*1 +C If DICO = 'D' and JOB = 'X' or JOB = 'A', specifies which +C symplectic matrix is to be constructed, as follows: +C = 'D': The matrix H in (6) (see METHOD) is constructed; +C = 'I': The inverse of the matrix H in (6) is constructed. +C HINV is not used if DICO = 'C', or JOB = 'C' or 'E'. +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C UPLO CHARACTER*1 +C Specifies which triangle of the matrices G and Q is +C stored, as follows: +C = 'U': Upper triangle is stored; +C = 'L': Lower triangle is stored. +C +C SCAL CHARACTER*1 +C If JOB = 'X' or JOB = 'A', specifies whether or not a +C scaling strategy should be used, as follows: +C = 'G': General scaling should be used; +C = 'N': No scaling should be used. +C SCAL is not used if JOB = 'C' or 'E'. +C +C SORT CHARACTER*1 +C If JOB = 'X' or JOB = 'A', specifies which eigenvalues +C should be obtained in the top of the Schur form, as +C follows: +C = 'S': Stable eigenvalues come first; +C = 'U': Unstable eigenvalues come first. +C SORT is not used if JOB = 'C' or 'E'. +C +C FACT CHARACTER*1 +C If JOB <> 'X', specifies whether or not a real Schur +C factorization of the closed-loop system matrix Ac is +C supplied on entry, as follows: +C = 'F': On entry, T and V contain the factors from a real +C Schur factorization of the matrix Ac; +C = 'N': A Schur factorization of Ac will be computed +C and the factors will be stored in T and V. +C For a continuous-time system, the matrix Ac is given by +C Ac = A - G*X, if TRANA = 'N', or +C Ac = A - X*G, if TRANA = 'T' or 'C', +C and for a discrete-time system, the matrix Ac is given by +C Ac = inv(I_n + G*X)*A, if TRANA = 'N', or +C Ac = A*inv(I_n + X*G), if TRANA = 'T' or 'C'. +C FACT is not used if JOB = 'X'. +C +C LYAPUN CHARACTER*1 +C If JOB <> 'X', specifies whether or not the original or +C "reduced" Lyapunov equations should be solved for +C estimating reciprocal condition number and/or the error +C bound, as follows: +C = 'O': Solve the original Lyapunov equations, updating +C the right-hand sides and solutions with the +C matrix V, e.g., X <-- V'*X*V; +C = 'R': Solve reduced Lyapunov equations only, without +C updating the right-hand sides and solutions. +C This means that a real Schur form T of Ac appears +C in the equations, instead of Ac. +C LYAPUN is not used if JOB = 'X'. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, Q, G, and X. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C If JOB = 'X' or JOB = 'A' or FACT = 'N' or LYAPUN = 'O', +C the leading N-by-N part of this array must contain the +C coefficient matrix A of the equation. +C If JOB = 'C' or 'E' and FACT = 'F' and LYAPUN = 'R', A is +C not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,N), if JOB = 'X' or JOB = 'A' or +C FACT = 'N' or LYAPUN = 'O'. +C LDA >= 1, otherwise. +C +C T (input or output) DOUBLE PRECISION array, dimension +C (LDT,N) +C If JOB <> 'X' and FACT = 'F', then T is an input argument +C and on entry, the leading N-by-N upper Hessenberg part of +C this array must contain the upper quasi-triangular matrix +C T in Schur canonical form from a Schur factorization of Ac +C (see argument FACT). +C If JOB <> 'X' and FACT = 'N', then T is an output argument +C and on exit, if INFO = 0 or INFO = 7, the leading N-by-N +C upper Hessenberg part of this array contains the upper +C quasi-triangular matrix T in Schur canonical form from a +C Schur factorization of Ac (see argument FACT). +C If JOB = 'X', the array T is not referenced. +C +C LDT INTEGER +C The leading dimension of the array T. +C LDT >= 1, if JOB = 'X'; +C LDT >= MAX(1,N), if JOB <> 'X'. +C +C V (input or output) DOUBLE PRECISION array, dimension +C (LDV,N) +C If JOB <> 'X' and FACT = 'F', then V is an input argument +C and on entry, the leading N-by-N part of this array must +C contain the orthogonal matrix V from a real Schur +C factorization of Ac (see argument FACT). +C If JOB <> 'X' and FACT = 'N', then V is an output argument +C and on exit, if INFO = 0 or INFO = 7, the leading N-by-N +C part of this array contains the orthogonal N-by-N matrix +C from a real Schur factorization of Ac (see argument FACT). +C If JOB = 'X', the array V is not referenced. +C +C LDV INTEGER +C The leading dimension of the array V. +C LDV >= 1, if JOB = 'X'; +C LDV >= MAX(1,N), if JOB <> 'X'. +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) +C On entry, the leading N-by-N upper triangular part (if +C UPLO = 'U') or lower triangular part (if UPLO = 'L') of +C this array must contain the upper triangular part or lower +C triangular part, respectively, of the symmetric matrix G. +C On exit, if JOB = 'X' and DICO = 'D', or JOB <> 'X' and +C LYAPUN = 'R', the leading N-by-N part of this array +C contains the symmetric matrix G fully stored. +C If JOB <> 'X' and LYAPUN = 'R', this array is modified +C internally, but restored on exit. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, the leading N-by-N upper triangular part (if +C UPLO = 'U') or lower triangular part (if UPLO = 'L') of +C this array must contain the upper triangular part or lower +C triangular part, respectively, of the symmetric matrix Q. +C On exit, if JOB = 'X' and DICO = 'D', or JOB <> 'X' and +C LYAPUN = 'R', the leading N-by-N part of this array +C contains the symmetric matrix Q fully stored. +C If JOB <> 'X' and LYAPUN = 'R', this array is modified +C internally, but restored on exit. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= MAX(1,N). +C +C X (input or output) DOUBLE PRECISION array, dimension +C (LDX,N) +C If JOB = 'C' or JOB = 'E', then X is an input argument +C and on entry, the leading N-by-N part of this array must +C contain the symmetric solution matrix of the algebraic +C Riccati equation. If LYAPUN = 'R', this array is modified +C internally, but restored on exit; however, it could differ +C from the input matrix at the round-off error level. +C If JOB = 'X' or JOB = 'A', then X is an output argument +C and on exit, if INFO = 0 or INFO >= 6, the leading N-by-N +C part of this array contains the symmetric solution matrix +C X of the algebraic Riccati equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= MAX(1,N). +C +C SEP (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'A', and INFO = 0 or INFO = 7, the +C estimated quantity +C sep(op(Ac),-op(Ac)'), if DICO = 'C', or +C sepd(op(Ac),op(Ac)'), if DICO = 'D'. (See METHOD.) +C If JOB = 'C' or JOB = 'A' and X = 0, or JOB = 'E', SEP is +C not referenced. +C If JOB = 'X', and INFO = 0, INFO = 5 or INFO = 7, +C SEP contains the scaling factor used, which should +C multiply the (2,1) submatrix of U to recover X from the +C first N columns of U (see METHOD). If SCAL = 'N', SEP is +C set to 1. +C +C RCOND (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'A', and INFO = 0 or INFO = 7, an +C estimate of the reciprocal condition number of the +C algebraic Riccati equation. +C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. +C If JOB = 'X', or JOB = 'E', RCOND is not referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = 7, an +C estimated forward error bound for the solution X. If XTRUE +C is the true solution, FERR bounds the magnitude of the +C largest entry in (X - XTRUE) divided by the magnitude of +C the largest entry in X. +C If N = 0 or X = 0, FERR is set to 0. +C If JOB = 'X', or JOB = 'C', FERR is not referenced. +C +C WR (output) DOUBLE PRECISION array, dimension (2*N) +C WI (output) DOUBLE PRECISION array, dimension (2*N) +C If JOB = 'X' or JOB = 'A', and INFO = 0 or INFO >= 5, +C these arrays contain the real and imaginary parts, +C respectively, of the eigenvalues of the 2N-by-2N matrix S, +C ordered as specified by SORT (except for the case +C HINV = 'D', when the order is opposite to that specified +C by SORT). The leading N elements of these arrays contain +C the closed-loop spectrum of the system matrix Ac (see +C argument FACT). Specifically, +C lambda(k) = WR(k) + j*WI(k), for k = 1,2,...,N. +C If JOB = 'C' or JOB = 'E', these arrays are not +C referenced. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) +C If JOB = 'X' or JOB = 'A', and INFO = 0 or INFO >= 5, the +C leading 2N-by-2N part of this array contains the ordered +C real Schur form S of the (scaled, if SCAL = 'G') +C Hamiltonian or symplectic matrix H. That is, +C +C ( S S ) +C ( 11 12 ) +C S = ( ), +C ( 0 S ) +C ( 22 ) +C +C where S , S and S are N-by-N matrices. +C 11 12 22 +C If JOB = 'C' or JOB = 'E', this array is not referenced. +C +C LDS INTEGER +C The leading dimension of the array S. +C LDS >= MAX(1,2*N), if JOB = 'X' or JOB = 'A'; +C LDS >= 1, if JOB = 'C' or JOB = 'E'. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK >= 2*N, if JOB = 'X'; +C LIWORK >= N*N, if JOB = 'C' or JOB = 'E'; +C LIWORK >= MAX(2*N,N*N), if JOB = 'A'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, or INFO = 7, DWORK(1) returns the +C optimal value of LDWORK. If INFO = 0, or INFO >= 5, and +C JOB = 'X', or JOB = 'A', then DWORK(2) returns an estimate +C RCONDU of the reciprocal of the condition number (in the +C 1-norm) of the N-th order system of algebraic equations +C from which the solution matrix X is obtained, and DWORK(3) +C returns the reciprocal pivot growth factor for the LU +C factorization of the coefficient matrix of that system +C (see SLICOT Library routine MB02PD); if DWORK(3) is much +C less than 1, then the computed X and RCONDU could be +C unreliable. +C If DICO = 'D', and JOB = 'X', or JOB = 'A', then DWORK(4) +C returns the reciprocal condition number RCONDA of the +C given matrix A, and DWORK(5) returns the reciprocal pivot +C growth factor for A or for its leading columns, if A is +C singular (see SLICOT Library routine MB02PD); if DWORK(5) +C is much less than 1, then the computed S and RCONDA could +C be unreliable. +C On exit, if INFO = 0, or INFO >= 4, and JOB = 'X', the +C elements DWORK(6:5+4*N*N) contain the 2*N-by-2*N +C transformation matrix U which reduced the Hamiltonian or +C symplectic matrix H to the ordered real Schur form S. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 5+MAX(1,4*N*N+8*N), if JOB = 'X' or JOB = 'A'; +C This may also be used for JOB = 'C' or JOB = 'E', but +C exact bounds are as follows: +C LDWORK >= 5 + MAX(1,LWS,LWE) + LWN, where +C LWS = 0, if FACT = 'F' or LYAPUN = 'R'; +C = 5*N, if FACT = 'N' and LYAPUN = 'O' and +C DICO = 'C' and JOB = 'C'; +C = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and +C DICO = 'C' and JOB = 'E'; +C = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and +C DICO = 'D'; +C LWE = 2*N*N, if DICO = 'C' and JOB = 'C'; +C = 4*N*N, if DICO = 'C' and JOB = 'E'; +C = MAX(3,2*N*N) + N*N, if DICO = 'D' and JOB = 'C'; +C = MAX(3,2*N*N) + 2*N*N, if DICO = 'D' and JOB = 'E'; +C LWN = 0, if LYAPUN = 'O' or JOB = 'C'; +C = 2*N, if LYAPUN = 'R' and DICO = 'C' and JOB = 'E'; +C = 3*N, if LYAPUN = 'R' and DICO = 'D' and JOB = 'E'. +C For optimum performance LDWORK should sometimes be larger. +C +C BWORK LOGICAL array, dimension (LBWORK) +C LBWORK >= 2*N, if JOB = 'X' or JOB = 'A'; +C LBWORK >= 1, if JOB = 'C' or JOB = 'E', and +C FACT = 'N' and LYAPUN = 'R'; +C LBWORK >= 0, otherwise. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if matrix A is (numerically) singular in discrete- +C time case; +C = 2: if the Hamiltonian or symplectic matrix H cannot be +C reduced to real Schur form; +C = 3: if the real Schur form of the Hamiltonian or +C symplectic matrix H cannot be appropriately ordered; +C = 4: if the Hamiltonian or symplectic matrix H has less +C than N stable eigenvalues; +C = 5: if the N-th order system of linear algebraic +C equations, from which the solution matrix X would +C be obtained, is singular to working precision; +C = 6: if the QR algorithm failed to complete the reduction +C of the matrix Ac to Schur canonical form, T; +C = 7: if T and -T' have some almost equal eigenvalues, if +C DICO = 'C', or T has almost reciprocal eigenvalues, +C if DICO = 'D'; perturbed values were used to solve +C Lyapunov equations, but the matrix T, if given (for +C FACT = 'F'), is unchanged. (This is a warning +C indicator.) +C +C METHOD +C +C The method used is the Schur vector approach proposed by Laub [1], +C but with an optional scaling, which enhances the numerical +C stability [6]. It is assumed that [A,B] is a stabilizable pair +C (where for (3) or (4), B is any matrix such that B*B' = G with +C rank(B) = rank(G)), and [E,A] is a detectable pair, where E is any +C matrix such that E*E' = Q with rank(E) = rank(Q). Under these +C assumptions, any of the algebraic Riccati equations (1)-(4) is +C known to have a unique non-negative definite solution. See [2]. +C Now consider the 2N-by-2N Hamiltonian or symplectic matrix +C +C ( op(A) -G ) +C H = ( ), (5) +C ( -Q -op(A)' ), +C +C for continuous-time equation, and +C -1 -1 +C ( op(A) op(A) *G ) +C H = ( -1 -1 ), (6) +C ( Q*op(A) op(A)' + Q*op(A) *G ) +C +C for discrete-time equation, respectively, where +C -1 +C G = op(B)*R *op(B)'. +C The assumptions guarantee that H in (5) has no pure imaginary +C eigenvalues, and H in (6) has no eigenvalues on the unit circle. +C If Y is an N-by-N matrix then there exists an orthogonal matrix U +C such that U'*Y*U is an upper quasi-triangular matrix. Moreover, U +C can be chosen so that the 2-by-2 and 1-by-1 diagonal blocks +C (corresponding to the complex conjugate eigenvalues and real +C eigenvalues respectively) appear in any desired order. This is the +C ordered real Schur form. Thus, we can find an orthogonal +C similarity transformation U which puts (5) or (6) in ordered real +C Schur form +C +C U'*H*U = S = (S(1,1) S(1,2)) +C ( 0 S(2,2)) +C +C where S(i,j) is an N-by-N matrix and the eigenvalues of S(1,1) +C have negative real parts in case of (5), or moduli greater than +C one in case of (6). If U is conformably partitioned into four +C N-by-N blocks +C +C U = (U(1,1) U(1,2)) +C (U(2,1) U(2,2)) +C +C with respect to the assumptions we then have +C (a) U(1,1) is invertible and X = U(2,1)*inv(U(1,1)) solves (1), +C (2), (3), or (4) with X = X' and non-negative definite; +C (b) the eigenvalues of S(1,1) (if DICO = 'C') or S(2,2) (if +C DICO = 'D') are equal to the eigenvalues of optimal system +C (the 'closed-loop' spectrum). +C +C [A,B] is stabilizable if there exists a matrix F such that (A-BF) +C is stable. [E,A] is detectable if [A',E'] is stabilizable. +C +C The condition number of a Riccati equation is estimated as +C +C cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) + +C norm(Pi)*norm(G) ) / norm(X), +C +C where Omega, Theta and Pi are linear operators defined by +C +C Omega(W) = op(Ac)'*W + W*op(Ac), +C Theta(W) = inv(Omega(op(W)'*X + X*op(W))), +C Pi(W) = inv(Omega(X*W*X)), +C +C in the continuous-time case, and +C +C Omega(W) = op(Ac)'*W*op(Ac) - W, +C Theta(W) = inv(Omega(op(W)'*X*op(Ac) + op(Ac)'X*op(W))), +C Pi(W) = inv(Omega(op(Ac)'*X*W*X*op(Ac))), +C +C in the discrete-time case, and Ac has been defined (see argument +C FACT). Details are given in the comments of SLICOT Library +C routines SB02QD and SB02SD. +C +C The routine estimates the quantities +C +C sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)), +C sepd(op(Ac),op(Ac)') = 1 / norm(inv(Omega)), +C +C norm(Theta) and norm(Pi) using 1-norm condition estimator. +C +C The forward error bound is estimated using a practical error bound +C similar to the one proposed in [5]. +C +C REFERENCES +C +C [1] Laub, A.J. +C A Schur Method for Solving Algebraic Riccati equations. +C IEEE Trans. Auto. Contr., AC-24, pp. 913-921, 1979. +C +C [2] Wonham, W.M. +C On a matrix Riccati equation of stochastic control. +C SIAM J. Contr., 6, pp. 681-697, 1968. +C +C [3] Sima, V. +C Algorithms for Linear-Quadratic Optimization. +C Pure and Applied Mathematics: A Series of Monographs and +C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. +C +C [4] Ghavimi, A.R. and Laub, A.J. +C Backward error, sensitivity, and refinement of computed +C solutions of algebraic Riccati equations. +C Numerical Linear Algebra with Applications, vol. 2, pp. 29-49, +C 1995. +C +C [5] Higham, N.J. +C Perturbation theory and backward error for AX-XB=C. +C BIT, vol. 33, pp. 124-136, 1993. +C +C [6] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. +C DGRSVX and DMSRIC: Fortran 77 subroutines for solving +C continuous-time matrix algebraic Riccati equations with +C condition and accuracy estimates. +C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. +C Chemnitz, May 1998. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. The solution accuracy +C can be controlled by the output parameter FERR. +C +C FURTHER COMMENTS +C +C To obtain a stabilizing solution of the algebraic Riccati +C equation for DICO = 'D', set SORT = 'U', if HINV = 'D', or set +C SORT = 'S', if HINV = 'I'. +C +C The routine can also compute the anti-stabilizing solutions of +C the algebraic Riccati equations, by specifying +C SORT = 'U' if DICO = 'D' and HINV = 'I', or DICO = 'C', or +C SORT = 'S' if DICO = 'D' and HINV = 'D'. +C +C Usually, the combinations HINV = 'D' and SORT = 'U', or HINV = 'I' +C and SORT = 'U', for stabilizing and anti-stabilizing solutions, +C respectively, will be faster then the other combinations [3]. +C +C The option LYAPUN = 'R' may produce slightly worse or better +C estimates, and it is faster than the option 'O'. +C +C This routine is a functionally extended and more accurate +C version of the SLICOT Library routine SB02MD. Transposed problems +C can be dealt with as well. Iterative refinement is used whenever +C useful to solve linear algebraic systems. Condition numbers and +C error bounds on the solutions are optionally provided. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001, +C Dec. 2002, Oct. 2004. +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, discrete-time system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, FACT, HINV, JOB, LYAPUN, SCAL, SORT, + $ TRANA, UPLO + INTEGER INFO, LDA, LDG, LDQ, LDS, LDT, LDV, LDWORK, LDX, + $ N + DOUBLE PRECISION FERR, RCOND, SEP +C .. Array Arguments .. + LOGICAL BWORK(*) + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), + $ S(LDS,*), T(LDT,*), V(LDV,*), WI(*), WR(*), + $ X(LDX,*) +C .. Local Scalars .. + LOGICAL COLEQU, DISCR, JBXA, JOBA, JOBC, JOBE, JOBX, + $ LHINV, LSCAL, LSCL, LSORT, LUPLO, NOFACT, + $ NOTRNA, ROWEQU, UPDATE + CHARACTER EQUED, JOBS, LOFACT, LOUP, TRANAT + INTEGER I, IERR, IU, IW, IWB, IWC, IWF, IWI, IWR, LDW, + $ LWE, LWN, LWS, N2, NN, NP1, NROT + DOUBLE PRECISION GNORM, QNORM, PIVOTA, PIVOTU, RCONDA, RCONDU, + $ WRKOPT +C .. External Functions .. + LOGICAL LSAME, SB02MR, SB02MS, SB02MV, SB02MW + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02MR, SB02MS, + $ SB02MV, SB02MW +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEES, DGESV, DLACPY, DLASCL, + $ DLASET, DSCAL, DSWAP, DSYMM, MA02AD, MA02ED, + $ MB01RU, MB01SD, MB02PD, SB02QD, SB02RU, SB02SD, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C .. Executable Statements .. +C +C Decode the input parameters. +C + N2 = N + N + NN = N*N + NP1 = N + 1 + INFO = 0 + JOBA = LSAME( JOB, 'A' ) + JOBC = LSAME( JOB, 'C' ) + JOBE = LSAME( JOB, 'E' ) + JOBX = LSAME( JOB, 'X' ) + NOFACT = LSAME( FACT, 'N' ) + NOTRNA = LSAME( TRANA, 'N' ) + DISCR = LSAME( DICO, 'D' ) + LUPLO = LSAME( UPLO, 'U' ) + LSCAL = LSAME( SCAL, 'G' ) + LSORT = LSAME( SORT, 'S' ) + UPDATE = LSAME( LYAPUN, 'O' ) + JBXA = JOBX .OR. JOBA + LHINV = .FALSE. + IF ( DISCR .AND. JBXA ) + $ LHINV = LSAME( HINV, 'D' ) +C +C Test the input scalar arguments. +C + IF( .NOT.( JBXA .OR. JOBC .OR. JOBE ) ) THEN + INFO = -1 + ELSE IF( .NOT.( DISCR .OR. LSAME( DICO, 'C' ) ) ) THEN + INFO = -2 + ELSE IF( DISCR .AND. JBXA ) THEN + IF( .NOT.( LHINV .OR. LSAME( HINV, 'I' ) ) ) + $ INFO = -3 + END IF + IF( INFO.EQ.0 ) THEN + IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. + $ LSAME( TRANA, 'C' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT.( LUPLO .OR. LSAME( UPLO, 'L' ) ) ) + $ THEN + INFO = -5 + ELSE IF( JBXA ) THEN + IF( .NOT.( LSCAL .OR. LSAME( SCAL, 'N' ) ) ) THEN + INFO = -6 + ELSE IF( .NOT.( LSORT .OR. LSAME( SORT, 'U' ) ) ) THEN + INFO = -7 + END IF + END IF + IF( INFO.EQ.0 .AND. .NOT.JOBX ) THEN + IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN + INFO = -8 + ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN + INFO = -9 + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( N.LT.0 ) THEN + INFO = -10 + ELSE IF( LDA.LT.1 .OR. ( ( JBXA .OR. NOFACT .OR. UPDATE ) + $ .AND. LDA.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDT.LT.1 .OR. ( .NOT. JOBX .AND. LDT.LT.N ) ) THEN + INFO = -14 + ELSE IF( LDV.LT.1 .OR. ( .NOT. JOBX .AND. LDV.LT.N ) ) THEN + INFO = -16 + ELSE IF( LDG.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -20 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -22 + ELSE IF( LDS.LT.1 .OR. ( JBXA .AND. LDS.LT.N2 ) ) THEN + INFO = -29 + ELSE + IF( JBXA ) THEN + IF( LDWORK.LT.5 + MAX( 1, 4*NN + 8*N ) ) + $ INFO = -32 + ELSE + IF( NOFACT .AND. UPDATE ) THEN + IF( .NOT.DISCR .AND. JOBC ) THEN + LWS = 5*N + ELSE + LWS = 5*N + NN + END IF + ELSE + LWS = 0 + END IF + IF( DISCR ) THEN + IF( JOBC ) THEN + LWE = MAX( 3, 2*NN) + NN + ELSE + LWE = MAX( 3, 2*NN) + 2*NN + END IF + ELSE + IF( JOBC ) THEN + LWE = 2*NN + ELSE + LWE = 4*NN + END IF + END IF + IF( UPDATE .OR. JOBC ) THEN + LWN = 0 + ELSE + IF( DISCR ) THEN + LWN = 3*N + ELSE + LWN = 2*N + END IF + END IF + IF( LDWORK.LT.5 + MAX( 1, LWS, LWE ) + LWN ) + $ INFO = -32 + END IF + END IF + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB02RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + IF( JOBX ) + $ SEP = ONE + IF( JOBC .OR. JOBA ) + $ RCOND = ONE + IF( JOBE .OR. JOBA ) + $ FERR = ZERO + DWORK(1) = ONE + DWORK(2) = ONE + DWORK(3) = ONE + IF ( DISCR ) THEN + DWORK(4) = ONE + DWORK(5) = ONE + END IF + RETURN + END IF +C + IF ( JBXA ) THEN +C +C Compute the solution matrix X. +C +C Initialise the Hamiltonian or symplectic matrix associated with +C the problem. +C Workspace: need 0 if DICO = 'C'; +C 6*N, if DICO = 'D'. +C + CALL SB02RU( DICO, HINV, TRANA, UPLO, N, A, LDA, G, LDG, Q, + $ LDQ, S, LDS, IWORK, DWORK, LDWORK, IERR ) +C + IF ( IERR.NE.0 ) THEN + INFO = 1 + IF ( DISCR ) THEN + DWORK(4) = DWORK(1) + DWORK(5) = DWORK(2) + END IF + RETURN + END IF +C + IF ( DISCR ) THEN + WRKOPT = 6*N + RCONDA = DWORK(1) + PIVOTA = DWORK(2) + ELSE + WRKOPT = 0 + END IF +C + IF ( LSCAL ) THEN +C +C Scale the Hamiltonian or symplectic matrix S, using the +C square roots of the norms of the matrices Q and G. +C + QNORM = SQRT( DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) ) + GNORM = SQRT( DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) ) +C + LSCL = QNORM.GT.GNORM .AND. GNORM.GT.ZERO + IF( LSCL ) THEN + CALL DLASCL( 'G', 0, 0, QNORM, GNORM, N, N, S(NP1,1), + $ LDS, IERR ) + CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, S(1,NP1), + $ LDS, IERR ) + END IF + ELSE + LSCL = .FALSE. + END IF +C +C Find the ordered Schur factorization of S, S = U*H*U'. +C Workspace: need 5 + 4*N*N + 6*N; +C prefer larger. +C + IU = 6 + IW = IU + 4*NN + LDW = LDWORK - IW + 1 + IF ( .NOT.DISCR ) THEN + IF ( LSORT ) THEN + CALL DGEES( 'Vectors', 'Sorted', SB02MV, N2, S, LDS, + $ NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW, + $ BWORK, IERR ) + ELSE + CALL DGEES( 'Vectors', 'Sorted', SB02MR, N2, S, LDS, + $ NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW, + $ BWORK, IERR ) + END IF + ELSE + IF ( LSORT ) THEN + CALL DGEES( 'Vectors', 'Sorted', SB02MW, N2, S, LDS, + $ NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW, + $ BWORK, IERR ) + ELSE + CALL DGEES( 'Vectors', 'Sorted', SB02MS, N2, S, LDS, + $ NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW, + $ BWORK, IERR ) + END IF + IF ( LHINV ) THEN + CALL DSWAP( N, WR, 1, WR(NP1), 1 ) + CALL DSWAP( N, WI, 1, WI(NP1), 1 ) + END IF + END IF + IF ( IERR.GT.N2 ) THEN + INFO = 3 + ELSE IF ( IERR.GT.0 ) THEN + INFO = 2 + ELSE IF ( NROT.NE.N ) THEN + INFO = 4 + END IF + IF ( INFO.NE.0 ) THEN + IF ( DISCR ) THEN + DWORK(4) = RCONDA + DWORK(5) = PIVOTA + END IF + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(IW) + DBLE( IW - 1 ) ) +C +C Compute the solution of X*U(1,1) = U(2,1) using +C LU factorization and iterative refinement. The (2,1) block of S +C is used as a workspace for factoring U(1,1). +C Workspace: need 5 + 4*N*N + 8*N. +C +C First transpose U(2,1) in-situ. +C + DO 20 I = 1, N - 1 + CALL DSWAP( N-I, DWORK(IU+N+I*(N2+1)-1), N2, + $ DWORK(IU+N+(I-1)*(N2+1)+1), 1 ) + 20 CONTINUE +C + IWR = IW + IWC = IWR + N + IWF = IWC + N + IWB = IWF + N + IW = IWB + N +C + CALL MB02PD( 'Equilibrate', 'Transpose', N, N, DWORK(IU), N2, + $ S(NP1,1), LDS, IWORK, EQUED, DWORK(IWR), + $ DWORK(IWC), DWORK(IU+N), N2, X, LDX, RCONDU, + $ DWORK(IWF), DWORK(IWB), IWORK(NP1), DWORK(IW), + $ IERR ) + IF( JOBX ) THEN +C +C Restore U(2,1) back in-situ. +C + DO 40 I = 1, N - 1 + CALL DSWAP( N-I, DWORK(IU+N+I*(N2+1)-1), N2, + $ DWORK(IU+N+(I-1)*(N2+1)+1), 1 ) + 40 CONTINUE +C + IF( .NOT.LSAME( EQUED, 'N' ) ) THEN +C +C Undo the equilibration of U(1,1) and U(2,1). +C + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) +C + IF( ROWEQU ) THEN +C + DO 60 I = 1, N + DWORK(IWR+I-1) = ONE / DWORK(IWR+I-1) + 60 CONTINUE +C + CALL MB01SD( 'Row scaling', N, N, DWORK(IU), N2, + $ DWORK(IWR), DWORK(IWC) ) + END IF +C + IF( COLEQU ) THEN +C + DO 80 I = 1, N + DWORK(IWC+I-1) = ONE / DWORK(IWC+I-1) + 80 CONTINUE +C + CALL MB01SD( 'Column scaling', N, N, DWORK(IU), N2, + $ DWORK(IWR), DWORK(IWC) ) + CALL MB01SD( 'Column scaling', N, N, DWORK(IU+N), N2, + $ DWORK(IWR), DWORK(IWC) ) + END IF + END IF +C +C Set S(2,1) to zero. +C + CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) + END IF +C + PIVOTU = DWORK(IW) +C + IF ( IERR.GT.0 ) THEN +C +C Singular matrix. Set INFO and DWORK for error return. +C + INFO = 5 + GO TO 160 + END IF +C +C Make sure the solution matrix X is symmetric. +C + DO 100 I = 1, N - 1 + CALL DAXPY( N-I, ONE, X(I,I+1), LDX, X(I+1,I), 1 ) + CALL DSCAL( N-I, HALF, X(I+1,I), 1 ) + CALL DCOPY( N-I, X(I+1,I), 1, X(I,I+1), LDX ) + 100 CONTINUE +C + IF( LSCAL ) THEN +C +C Undo scaling for the solution matrix. +C + IF( LSCL ) + $ CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, X, LDX, + $ IERR ) + END IF + END IF +C + IF ( .NOT.JOBX ) THEN + IF ( .NOT.JOBA ) + $ WRKOPT = 0 +C +C Estimate the conditioning and compute an error bound on the +C solution of the algebraic Riccati equation. +C + IW = 6 + LOFACT = FACT + IF ( NOFACT .AND. .NOT.UPDATE ) THEN +C +C Compute Ac and its Schur factorization. +C + IF ( DISCR ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(IW), N ) + CALL DSYMM( 'Left', UPLO, N, N, ONE, G, LDG, X, LDX, + $ ONE, DWORK(IW), N ) + IF ( NOTRNA ) THEN +C +C Compute Ac = inv(I_n + G*X)*A. +C + CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) + CALL DGESV( N, N, DWORK(IW), N, IWORK, T, LDT, IERR ) + ELSE +C +C Compute Ac = A*inv(I_n + X*G). +C + CALL MA02AD( 'Full', N, N, A, LDA, T, LDT ) + CALL DGESV( N, N, DWORK(IW), N, IWORK, T, LDT, IERR ) + DO 120 I = 2, N + CALL DSWAP( I-1, T(1,I), 1, T(I,1), LDT ) + 120 CONTINUE + END IF +C + ELSE +C + CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) + IF ( NOTRNA ) THEN +C +C Compute Ac = A - G*X. +C + CALL DSYMM( 'Left', UPLO, N, N, -ONE, G, LDG, X, LDX, + $ ONE, T, LDT ) + ELSE +C +C Compute Ac = A - X*G. +C + CALL DSYMM( 'Right', UPLO, N, N, -ONE, G, LDG, X, LDX, + $ ONE, T, LDT ) + END IF + END IF +C +C Compute the Schur factorization of Ac, Ac = V*T*V'. +C Workspace: need 5 + 5*N. +C prefer larger. +C + IWR = IW + IWI = IWR + N + IW = IWI + N + LDW = LDWORK - IW + 1 +C + CALL DGEES( 'Vectors', 'Not ordered', SB02MS, N, T, LDT, + $ NROT, DWORK(IWR), DWORK(IWI), V, LDV, DWORK(IW), + $ LDW, BWORK, IERR ) +C + IF( IERR.NE.0 ) THEN + INFO = 6 + GO TO 160 + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(IW) + DBLE( IW - 1 ) ) + LOFACT = 'F' + IW = 6 + END IF +C + IF ( .NOT.UPDATE ) THEN +C +C Update G, Q, and X using the orthogonal matrix V. +C + TRANAT = 'T' +C +C Save the diagonal elements of G and Q. +C + CALL DCOPY( N, G, LDG+1, DWORK(IW), 1 ) + CALL DCOPY( N, Q, LDQ+1, DWORK(IW+N), 1 ) + IW = IW + N2 +C + IF ( JOBA ) + $ CALL DLACPY( 'Full', N, N, X, LDX, S(NP1,1), LDS ) + CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX, V, LDV, + $ X, LDX, DWORK(IW), NN, IERR ) + CALL DSCAL( N, HALF, X, LDX+1 ) + CALL MA02ED( UPLO, N, X, LDX ) + IF( .NOT.DISCR ) THEN + CALL MA02ED( UPLO, N, G, LDG ) + CALL MA02ED( UPLO, N, Q, LDQ ) + END IF + CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, G, LDG, V, LDV, + $ G, LDG, DWORK(IW), NN, IERR ) + CALL DSCAL( N, HALF, G, LDG+1 ) + CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, Q, LDQ, V, LDV, + $ Q, LDQ, DWORK(IW), NN, IERR ) + CALL DSCAL( N, HALF, Q, LDQ+1 ) + END IF +C +C Estimate the conditioning and/or the error bound. +C Workspace: 5 + MAX(1,LWS,LWE) + LWN, where +C +C LWS = 0, if FACT = 'F' or LYAPUN = 'R'; +C = 5*N, if FACT = 'N' and LYAPUN = 'O' and DICO = 'C' +C and JOB = 'C'; +C = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and DICO = 'C' +C and (JOB = 'E' or JOB = 'A'); +C = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and +C DICO = 'D'; +C LWE = 2*N*N, if DICO = 'C' and JOB = 'C'; +C = 4*N*N, if DICO = 'C' and (JOB = 'E' or +C JOB = 'A'); +C = MAX(3,2*N*N) + N*N, if DICO = 'D' and JOB = 'C'; +C = MAX(3,2*N*N) + 2*N*N, if DICO = 'D' and (JOB = 'E' or +C JOB = 'A'); +C LWN = 0, if LYAPUN = 'O' or JOB = 'C'; +C = 2*N, if LYAPUN = 'R' and DICO = 'C' and (JOB = 'E' or +C JOB = 'A'); +C = 3*N, if LYAPUN = 'R' and DICO = 'D' and (JOB = 'E' or +C JOB = 'A'). +C + LDW = LDWORK - IW + 1 + IF ( JOBA ) THEN + JOBS = 'B' + ELSE + JOBS = JOB + END IF +C + IF ( DISCR ) THEN + CALL SB02SD( JOBS, LOFACT, TRANA, UPLO, LYAPUN, N, A, LDA, + $ T, LDT, V, LDV, G, LDG, Q, LDQ, X, LDX, SEP, + $ RCOND, FERR, IWORK, DWORK(IW), LDW, IERR ) + ELSE + CALL SB02QD( JOBS, LOFACT, TRANA, UPLO, LYAPUN, N, A, LDA, + $ T, LDT, V, LDV, G, LDG, Q, LDQ, X, LDX, SEP, + $ RCOND, FERR, IWORK, DWORK(IW), LDW, IERR ) + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(IW) + DBLE( IW - 1 ) ) + IF( IERR.EQ.NP1 ) THEN + INFO = 7 + ELSE IF( IERR.GT.0 ) THEN + INFO = 6 + GO TO 160 + END IF +C + IF ( .NOT.UPDATE ) THEN +C +C Restore X, G, and Q and set S(2,1) to zero, if needed. +C + IF ( JOBA ) THEN + CALL DLACPY( 'Full', N, N, S(NP1,1), LDS, X, LDX ) + CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) + ELSE + CALL MB01RU( UPLO, TRANA, N, N, ZERO, ONE, X, LDX, V, + $ LDV, X, LDX, DWORK(IW), NN, IERR ) + CALL DSCAL( N, HALF, X, LDX+1 ) + CALL MA02ED( UPLO, N, X, LDX ) + END IF + IF ( LUPLO ) THEN + LOUP = 'L' + ELSE + LOUP = 'U' + END IF +C + IW = 6 + CALL DCOPY( N, DWORK(IW), 1, G, LDG+1 ) + CALL MA02ED( LOUP, N, G, LDG ) + CALL DCOPY( N, DWORK(IW+N), 1, Q, LDQ+1 ) + CALL MA02ED( LOUP, N, Q, LDQ ) + END IF +C + END IF +C +C Set the optimal workspace and other details. +C + DWORK(1) = WRKOPT + 160 CONTINUE + IF( JBXA ) THEN + DWORK(2) = RCONDU + DWORK(3) = PIVOTU + IF ( DISCR ) THEN + DWORK(4) = RCONDA + DWORK(5) = PIVOTA + END IF + IF( JOBX ) THEN + IF ( LSCL ) THEN + SEP = QNORM / GNORM + ELSE + SEP = ONE + END IF + END IF + END IF +C + RETURN +C *** Last line of SB02RD *** + END diff --git a/mex/sources/libslicot/SB02RU.f b/mex/sources/libslicot/SB02RU.f new file mode 100644 index 000000000..947d18148 --- /dev/null +++ b/mex/sources/libslicot/SB02RU.f @@ -0,0 +1,508 @@ + SUBROUTINE SB02RU( DICO, HINV, TRANA, UPLO, N, A, LDA, G, LDG, Q, + $ LDQ, S, LDS, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the 2n-by-2n Hamiltonian or symplectic matrix S +C associated to the linear-quadratic optimization problem, used to +C solve the continuous- or discrete-time algebraic Riccati equation, +C respectively. +C +C For a continuous-time problem, S is defined by +C +C ( op(A) -G ) +C S = ( ), (1) +C ( -Q -op(A)' ) +C +C and for a discrete-time problem by +C +C -1 -1 +C ( op(A) op(A) *G ) +C S = ( -1 -1 ), (2) +C ( Q*op(A) op(A)' + Q*op(A) *G ) +C +C or +C -T -T +C ( op(A) + G*op(A) *Q -G*op(A) ) +C S = ( -T -T ), (3) +C ( -op(A) *Q op(A) ) +C +C where op(A) = A or A' (A**T), A, G, and Q are n-by-n matrices, +C with G and Q symmetric. Matrix A must be nonsingular in the +C discrete-time case. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system as follows: +C = 'C': Continuous-time system; +C = 'D': Discrete-time system. +C +C HINV CHARACTER*1 +C If DICO = 'D', specifies which of the matrices (2) or (3) +C is constructed, as follows: +C = 'D': The matrix S in (2) is constructed; +C = 'I': The (inverse) matrix S in (3) is constructed. +C HINV is not referenced if DICO = 'C'. +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C UPLO CHARACTER*1 +C Specifies which triangle of the matrices G and Q is +C stored, as follows: +C = 'U': Upper triangle is stored; +C = 'L': Lower triangle is stored. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, G, and Q. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) +C On entry, the leading N-by-N upper triangular part (if +C UPLO = 'U') or lower triangular part (if UPLO = 'L') of +C this array must contain the upper triangular part or lower +C triangular part, respectively, of the symmetric matrix G. +C On exit, if DICO = 'D', the leading N-by-N part of this +C array contains the symmetric matrix G fully stored. +C If DICO = 'C', this array is not modified on exit, and the +C strictly lower triangular part (if UPLO = 'U') or strictly +C upper triangular part (if UPLO = 'L') is not referenced. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, the leading N-by-N upper triangular part (if +C UPLO = 'U') or lower triangular part (if UPLO = 'L') of +C this array must contain the upper triangular part or lower +C triangular part, respectively, of the symmetric matrix Q. +C On exit, if DICO = 'D', the leading N-by-N part of this +C array contains the symmetric matrix Q fully stored. +C If DICO = 'C', this array is not modified on exit, and the +C strictly lower triangular part (if UPLO = 'U') or strictly +C upper triangular part (if UPLO = 'L') is not referenced. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= MAX(1,N). +C +C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) +C If INFO = 0, the leading 2N-by-2N part of this array +C contains the Hamiltonian or symplectic matrix of the +C problem. +C +C LDS INTEGER +C The leading dimension of the array S. LDS >= MAX(1,2*N). +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), where +C LIWORK >= 0, if DICO = 'C'; +C LIWORK >= 2*N, if DICO = 'D'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if DICO = 'D', DWORK(1) returns the reciprocal +C condition number RCOND of the given matrix A, and +C DWORK(2) returns the reciprocal pivot growth factor +C norm(A)/norm(U) (see SLICOT Library routine MB02PD). +C If DWORK(2) is much less than 1, then the computed S +C and RCOND could be unreliable. If 0 < INFO <= N, then +C DWORK(2) contains the reciprocal pivot growth factor for +C the leading INFO columns of A. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 0, if DICO = 'C'; +C LDWORK >= MAX(2,6*N), if DICO = 'D'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = i: if the leading i-by-i (1 <= i <= N) upper triangular +C submatrix of A is singular in discrete-time case; +C = N+1: if matrix A is numerically singular in discrete- +C time case. +C +C METHOD +C +C For a continuous-time problem, the 2n-by-2n Hamiltonian matrix (1) +C is constructed. +C For a discrete-time problem, the 2n-by-2n symplectic matrix (2) or +C (3) - the inverse of the matrix in (2) - is constructed. +C +C NUMERICAL ASPECTS +C +C The discrete-time case needs the inverse of the matrix A, hence +C the routine should not be used when A is ill-conditioned. +C 3 +C The algorithm requires 0(n ) floating point operations in the +C discrete-time case. +C +C FURTHER COMMENTS +C +C This routine is a functionally extended and with improved accuracy +C version of the SLICOT Library routine SB02MU. Transposed problems +C can be dealt with as well. The LU factorization of op(A) (with +C no equilibration) and iterative refinement are used for solving +C the various linear algebraic systems involved. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, discrete-time system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, HINV, TRANA, UPLO + INTEGER INFO, LDA, LDG, LDQ, LDS, LDWORK, N +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), + $ S(LDS,*) +C .. Local Scalars .. + CHARACTER EQUED, TRANAT + LOGICAL DISCR, LHINV, LUPLO, NOTRNA + INTEGER I, J, N2, NJ, NP1 + DOUBLE PRECISION PIVOTG, RCOND, RCONDA, TEMP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLACPY, DLASET, DSWAP, MA02AD, + $ MA02ED, MB02PD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + N2 = N + N + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + LUPLO = LSAME( UPLO, 'U' ) + NOTRNA = LSAME( TRANA, 'N' ) + IF( DISCR ) + $ LHINV = LSAME( HINV, 'D' ) +C +C Test the input scalar arguments. +C + IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN + INFO = -1 + ELSE IF( DISCR ) THEN + IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) ) + $ INFO = -2 + ELSE IF( INFO.EQ.0 ) THEN + IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) + $ .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -3 + ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDG.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN + INFO = -13 + ELSE IF( ( LDWORK.LT.0 ) .OR. + $ ( DISCR .AND. LDWORK.LT.MAX( 2, 6*N ) ) ) THEN + INFO = -16 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB02RU', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + IF ( DISCR ) THEN + DWORK(1) = ONE + DWORK(2) = ONE + END IF + RETURN + END IF +C +C The code tries to exploit data locality as much as possible, +C assuming that LDS is greater than LDA, LDQ, and/or LDG. +C + IF ( .NOT.DISCR ) THEN +C +C Continuous-time case: Construct Hamiltonian matrix column-wise. +C +C Copy op(A) in S(1:N,1:N), and construct full Q +C in S(N+1:2*N,1:N) and change the sign. +C + DO 100 J = 1, N + IF ( NOTRNA ) THEN + CALL DCOPY( N, A(1,J), 1, S(1,J), 1 ) + ELSE + CALL DCOPY( N, A(J,1), LDA, S(1,J), 1 ) + END IF +C + IF ( LUPLO ) THEN +C + DO 20 I = 1, J + S(N+I,J) = -Q(I,J) + 20 CONTINUE +C + DO 40 I = J + 1, N + S(N+I,J) = -Q(J,I) + 40 CONTINUE +C + ELSE +C + DO 60 I = 1, J - 1 + S(N+I,J) = -Q(J,I) + 60 CONTINUE +C + DO 80 I = J, N + S(N+I,J) = -Q(I,J) + 80 CONTINUE +C + END IF + 100 CONTINUE +C +C Construct full G in S(1:N,N+1:2*N) and change the sign, and +C construct -op(A)' in S(N+1:2*N,N+1:2*N). +C + DO 240 J = 1, N + NJ = N + J + IF ( LUPLO ) THEN +C + DO 120 I = 1, J + S(I,NJ) = -G(I,J) + 120 CONTINUE +C + DO 140 I = J + 1, N + S(I,NJ) = -G(J,I) + 140 CONTINUE +C + ELSE +C + DO 160 I = 1, J - 1 + S(I,NJ) = -G(J,I) + 160 CONTINUE +C + DO 180 I = J, N + S(I,NJ) = -G(I,J) + 180 CONTINUE +C + END IF +C + IF ( NOTRNA ) THEN +C + DO 200 I = 1, N + S(N+I,NJ) = -A(J,I) + 200 CONTINUE +C + ELSE +C + DO 220 I = 1, N + S(N+I,NJ) = -A(I,J) + 220 CONTINUE +C + END IF + 240 CONTINUE +C + ELSE +C +C Discrete-time case: Construct the symplectic matrix (2) or (3). +C +C Fill in the remaining triangles of the symmetric matrices Q +C and G. +C + CALL MA02ED( UPLO, N, Q, LDQ ) + CALL MA02ED( UPLO, N, G, LDG ) +C +C Prepare the construction of S in (2) or (3). +C + NP1 = N + 1 + IF ( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +C +C Solve op(A)'*X = Q in S(N+1:2*N,1:N), using the LU +C factorization of op(A), obtained in S(1:N,1:N), and +C iterative refinement. No equilibration of A is used. +C Workspace: 6*N. +C + CALL MB02PD( 'No equilibration', TRANAT, N, N, A, LDA, S, + $ LDS, IWORK, EQUED, DWORK, DWORK, Q, LDQ, + $ S(NP1,1), LDS, RCOND, DWORK, DWORK(NP1), + $ IWORK(NP1), DWORK(N2+1), INFO ) +C +C Return if the matrix is exactly singular or singular to +C working precision. +C + IF( INFO.GT.0 ) THEN + DWORK(1) = RCOND + DWORK(2) = DWORK(N2+1) + RETURN + END IF +C + RCONDA = RCOND + PIVOTG = DWORK(N2+1) +C + IF ( LHINV ) THEN +C +C Complete the construction of S in (2). +C +C Transpose X in-situ. +C + DO 260 J = 1, N - 1 + CALL DSWAP( N-J, S(NP1+J,J), 1, S(N+J,J+1), LDS ) + 260 CONTINUE +C +C Solve op(A)*X = I_n in S(N+1:2*N,N+1:2*N), using the LU +C factorization of op(A), computed in S(1:N,1:N), and +C iterative refinement. +C + CALL DLASET( 'Full', N, N, ZERO, ONE, S(1,NP1), LDS ) + CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK, + $ EQUED, DWORK, DWORK, S(1,NP1), LDS, S(NP1,NP1), + $ LDS, RCOND, DWORK, DWORK(NP1), IWORK(NP1), + $ DWORK(N2+1), INFO ) +C +C Solve op(A)*X = G in S(1:N,N+1:2*N), using the LU +C factorization of op(A), computed in S(1:N,1:N), and +C iterative refinement. +C + CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK, + $ EQUED, DWORK, DWORK, G, LDG, S(1,NP1), LDS, + $ RCOND, DWORK, DWORK(NP1), IWORK(NP1), + $ DWORK(N2+1), INFO ) +C +C -1 +C Copy op(A) from S(N+1:2*N,N+1:2*N) in S(1:N,1:N). +C + CALL DLACPY( 'Full', N, N, S(NP1,NP1), LDS, S, LDS ) +C +C -1 +C Compute op(A)' + Q*op(A) *G in S(N+1:2*N,N+1:2*N). +C + IF ( NOTRNA ) THEN + CALL MA02AD( 'Full', N, N, A, LDA, S(NP1,NP1), LDS ) + ELSE + CALL DLACPY( 'Full', N, N, A, LDA, S(NP1,NP1), LDS ) + END IF + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, + $ Q, LDQ, S(1,NP1), LDS, ONE, S(NP1,NP1), LDS ) +C + ELSE +C +C Complete the construction of S in (3). +C +C Change the sign of X. +C + DO 300 J = 1, N +C + DO 280 I = NP1, N2 + S(I,J) = -S(I,J) + 280 CONTINUE +C + 300 CONTINUE +C +C Solve op(A)'*X = I_n in S(N+1:2*N,N+1:2*N), using the LU +C factorization of op(A), computed in S(1:N,1:N), and +C iterative refinement. +C + CALL DLASET( 'Full', N, N, ZERO, ONE, S(1,NP1), LDS ) + CALL MB02PD( 'Factored', TRANAT, N, N, A, LDA, S, LDS, + $ IWORK, EQUED, DWORK, DWORK, S(1,NP1), LDS, + $ S(NP1,NP1), LDS, RCOND, DWORK, DWORK(NP1), + $ IWORK(NP1), DWORK(N2+1), INFO ) +C +C Solve op(A)*X' = -G in S(1:N,N+1:2*N), using the LU +C factorization of op(A), obtained in S(1:N,1:N), and +C iterative refinement. +C + CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK, + $ EQUED, DWORK, DWORK, G, LDG, S(1,NP1), LDS, + $ RCOND, DWORK, DWORK(NP1), IWORK(NP1), + $ DWORK(N2+1), INFO ) +C +C Change the sign of X and transpose it in-situ. +C + DO 340 J = NP1, N2 +C + DO 320 I = 1, N + TEMP = -S(I,J) + S(I,J) = -S(J-N,I+N) + S(J-N,I+N) = TEMP + 320 CONTINUE +C + 340 CONTINUE +C -T +C Compute op(A) + G*op(A) *Q in S(1:N,1:N). +C + IF ( NOTRNA ) THEN + CALL DLACPY( 'Full', N, N, A, LDA, S, LDS ) + ELSE + CALL MA02AD( 'Full', N, N, A, LDA, S, LDS ) + END IF + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, -ONE, + $ G, LDG, S(NP1,1), LDS, ONE, S, LDS ) +C + END IF + DWORK(1) = RCONDA + DWORK(2) = PIVOTG + END IF + RETURN +C +C *** Last line of SB02RU *** + END diff --git a/mex/sources/libslicot/SB02SD.f b/mex/sources/libslicot/SB02SD.f new file mode 100644 index 000000000..81685c3b6 --- /dev/null +++ b/mex/sources/libslicot/SB02SD.f @@ -0,0 +1,859 @@ + SUBROUTINE SB02SD( JOB, FACT, TRANA, UPLO, LYAPUN, N, A, LDA, T, + $ LDT, U, LDU, G, LDG, Q, LDQ, X, LDX, SEPD, + $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the conditioning and compute an error bound on the +C solution of the real discrete-time matrix algebraic Riccati +C equation (see FURTHER COMMENTS) +C -1 +C X = op(A)'*X*(I_n + G*X) *op(A) + Q, (1) +C +C where op(A) = A or A' (A**T) and Q, G are symmetric (Q = Q**T, +C G = G**T). The matrices A, Q and G are N-by-N and the solution X +C is N-by-N. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'C': Compute the reciprocal condition number only; +C = 'E': Compute the error bound only; +C = 'B': Compute both the reciprocal condition number and +C the error bound. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization of +C the matrix Ac = inv(I_n + G*X)*A (if TRANA = 'N'), or +C Ac = A*inv(I_n + X*G) (if TRANA = 'T' or 'C'), is supplied +C on entry, as follows: +C = 'F': On entry, T and U (if LYAPUN = 'O') contain the +C factors from the real Schur factorization of the +C matrix Ac; +C = 'N': The Schur factorization of Ac will be computed +C and the factors will be stored in T and U (if +C LYAPUN = 'O'). +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C UPLO CHARACTER*1 +C Specifies which part of the symmetric matrices Q and G is +C to be used, as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part. +C +C LYAPUN CHARACTER*1 +C Specifies whether or not the original Lyapunov equations +C should be solved in the iterative estimation process, +C as follows: +C = 'O': Solve the original Lyapunov equations, updating +C the right-hand sides and solutions with the +C matrix U, e.g., RHS <-- U'*RHS*U; +C = 'R': Solve reduced Lyapunov equations only, without +C updating the right-hand sides and solutions. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X, Q, and G. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of +C this array must contain the matrix A. +C If FACT = 'F' and LYAPUN = 'R', A is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= max(1,N), if FACT = 'N' or LYAPUN = 'O'; +C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. +C +C T (input or output) DOUBLE PRECISION array, dimension +C (LDT,N) +C If FACT = 'F', then T is an input argument and on entry, +C the leading N-by-N upper Hessenberg part of this array +C must contain the upper quasi-triangular matrix T in Schur +C canonical form from a Schur factorization of Ac (see +C argument FACT). +C If FACT = 'N', then T is an output argument and on exit, +C if INFO = 0 or INFO = N+1, the leading N-by-N upper +C Hessenberg part of this array contains the upper quasi- +C triangular matrix T in Schur canonical form from a Schur +C factorization of Ac (see argument FACT). +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= max(1,N). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,N) +C If LYAPUN = 'O' and FACT = 'F', then U is an input +C argument and on entry, the leading N-by-N part of this +C array must contain the orthogonal matrix U from a real +C Schur factorization of Ac (see argument FACT). +C If LYAPUN = 'O' and FACT = 'N', then U is an output +C argument and on exit, if INFO = 0 or INFO = N+1, it +C contains the orthogonal N-by-N matrix from a real Schur +C factorization of Ac (see argument FACT). +C If LYAPUN = 'R', the array U is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= 1, if LYAPUN = 'R'; +C LDU >= MAX(1,N), if LYAPUN = 'O'. +C +C G (input) DOUBLE PRECISION array, dimension (LDG,N) +C If UPLO = 'U', the leading N-by-N upper triangular part of +C this array must contain the upper triangular part of the +C matrix G. +C If UPLO = 'L', the leading N-by-N lower triangular part of +C this array must contain the lower triangular part of the +C matrix G. _ +C Matrix G should correspond to G in the "reduced" Riccati +C equation (with matrix T, instead of A), if LYAPUN = 'R'. +C See METHOD. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= max(1,N). +C +C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) +C If UPLO = 'U', the leading N-by-N upper triangular part of +C this array must contain the upper triangular part of the +C matrix Q. +C If UPLO = 'L', the leading N-by-N lower triangular part of +C this array must contain the lower triangular part of the +C matrix Q. _ +C Matrix Q should correspond to Q in the "reduced" Riccati +C equation (with matrix T, instead of A), if LYAPUN = 'R'. +C See METHOD. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= max(1,N). +C +C X (input) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array must contain the +C symmetric solution matrix of the original Riccati +C equation (with matrix A), if LYAPUN = 'O', or of the +C "reduced" Riccati equation (with matrix T), if +C LYAPUN = 'R'. See METHOD. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C SEPD (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'B', the estimated quantity +C sepd(op(Ac),op(Ac)'). +C If N = 0, or X = 0, or JOB = 'E', SEPD is not referenced. +C +C RCOND (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal +C condition number of the discrete-time Riccati equation. +C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. +C If JOB = 'E', RCOND is not referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'E' or JOB = 'B', an estimated forward error +C bound for the solution X. If XTRUE is the true solution, +C FERR bounds the magnitude of the largest entry in +C (X - XTRUE) divided by the magnitude of the largest entry +C in X. +C If N = 0 or X = 0, FERR is set to 0. +C If JOB = 'C', FERR is not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C Let LWA = N*N, if LYAPUN = 'O'; +C LWA = 0, otherwise, +C and LWN = N, if LYAPUN = 'R' and JOB = 'E' or 'B'; +C LWN = 0, otherwise. +C If FACT = 'N', then +C LDWORK = MAX(LWA + 5*N, MAX(3,2*N*N) + N*N), +C if JOB = 'C'; +C LDWORK = MAX(LWA + 5*N, MAX(3,2*N*N) + 2*N*N + LWN), +C if JOB = 'E' or 'B'. +C If FACT = 'F', then +C LDWORK = MAX(3,2*N*N) + N*N, if JOB = 'C'; +C LDWORK = MAX(3,2*N*N) + 2*N*N + LWN, +C if JOB = 'E' or 'B'. +C For good performance, LDWORK must generally be larger. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, i <= N, the QR algorithm failed to +C complete the reduction of the matrix Ac to Schur +C canonical form (see LAPACK Library routine DGEES); +C on exit, the matrix T(i+1:N,i+1:N) contains the +C partially converged Schur form, and DWORK(i+1:N) and +C DWORK(N+i+1:2*N) contain the real and imaginary +C parts, respectively, of the converged eigenvalues; +C this error is unlikely to appear; +C = N+1: if T has almost reciprocal eigenvalues; perturbed +C values were used to solve Lyapunov equations, but +C the matrix T, if given (for FACT = 'F'), is +C unchanged. +C +C METHOD +C +C The condition number of the Riccati equation is estimated as +C +C cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) + +C norm(Pi)*norm(G) ) / norm(X), +C +C where Omega, Theta and Pi are linear operators defined by +C +C Omega(W) = op(Ac)'*W*op(Ac) - W, +C Theta(W) = inv(Omega(op(W)'*X*op(Ac) + op(Ac)'X*op(W))), +C Pi(W) = inv(Omega(op(Ac)'*X*W*X*op(Ac))), +C +C and Ac = inv(I_n + G*X)*A (if TRANA = 'N'), or +C Ac = A*inv(I_n + X*G) (if TRANA = 'T' or 'C'). +C +C Note that the Riccati equation (1) is equivalent to +C +C X = op(Ac)'*X*op(Ac) + op(Ac)'*X*G*X*op(Ac) + Q, (2) +C +C and to +C _ _ _ _ _ _ +C X = op(T)'*X*op(T) + op(T)'*X*G*X*op(T) + Q, (3) +C _ _ _ +C where X = U'*X*U, Q = U'*Q*U, and G = U'*G*U, with U the +C orthogonal matrix reducing Ac to a real Schur form, T = U'*Ac*U. +C +C The routine estimates the quantities +C +C sepd(op(Ac),op(Ac)') = 1 / norm(inv(Omega)), +C +C norm(Theta) and norm(Pi) using 1-norm condition estimator. +C +C The forward error bound is estimated using a practical error bound +C similar to the one proposed in [2]. +C +C REFERENCES +C +C [1] Ghavimi, A.R. and Laub, A.J. +C Backward error, sensitivity, and refinement of computed +C solutions of algebraic Riccati equations. +C Numerical Linear Algebra with Applications, vol. 2, pp. 29-49, +C 1995. +C +C [2] Higham, N.J. +C Perturbation theory and backward error for AX-XB=C. +C BIT, vol. 33, pp. 124-136, 1993. +C +C [3] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. +C DGRSVX and DMSRIC: Fortran 77 subroutines for solving +C continuous-time matrix algebraic Riccati equations with +C condition and accuracy estimates. +C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. +C Chemnitz, May 1998. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C The accuracy of the estimates obtained depends on the solution +C accuracy and on the properties of the 1-norm estimator. +C +C FURTHER COMMENTS +C +C The option LYAPUN = 'R' may occasionally produce slightly worse +C or better estimates, and it is much faster than the option 'O'. +C When SEPD is computed and it is zero, the routine returns +C immediately, with RCOND and FERR (if requested) set to 0 and 1, +C respectively. In this case, the equation is singular. +C +C Let B be an N-by-M matrix (if TRANA = 'N') or an M-by-N matrix +C (if TRANA = 'T' or 'C'), let R be an M-by-M symmetric positive +C definite matrix (R = R**T), and denote G = op(B)*inv(R)*op(B)'. +C Then, the Riccati equation (1) is equivalent to the standard +C discrete-time matrix algebraic Riccati equation +C +C X = op(A)'*X*op(A) - (4) +C -1 +C op(A)'*X*op(B)*(R + op(B)'*X*op(B)) *op(B)'*X*op(A) + Q. +C +C By symmetry, the equation (1) is also equivalent to +C -1 +C X = op(A)'*(I_n + X*G) *X*op(A) + Q. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, and +C P.Hr. Petkov, Technical University of Sofia, March 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. +C +C KEYWORDS +C +C Conditioning, error estimates, orthogonal transformation, +C real Schur form, Riccati equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, FOUR, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+0, HALF = 0.5D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO + INTEGER INFO, LDA, LDG, LDQ, LDT, LDU, LDWORK, LDX, N + DOUBLE PRECISION FERR, RCOND, SEPD +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), DWORK( * ), G( LDG, * ), + $ Q( LDQ, * ), T( LDT, * ), U( LDU, * ), + $ X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL JOBB, JOBC, JOBE, LOWER, NEEDAC, NOFACT, + $ NOTRNA, UPDATE + CHARACTER LOUP, SJOB, TRANAT + INTEGER I, IABS, INFO2, IRES, IWRK, IXBS, IXMA, J, JJ, + $ KASE, LDW, LWA, LWR, NN, SDIM, WRKOPT + DOUBLE PRECISION ANORM, BIGNUM, DENOM, EPS, EPSN, EPST, EST, + $ GNORM, PINORM, QNORM, SCALE, TEMP, THNORM, + $ TMAX, XANORM, XNORM +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEES, DGEMM, DGESV, DLACON, + $ DLACPY, DLASET, DSCAL, DSWAP, DSYMM, MA02ED, + $ MB01RU, MB01RX, MB01RY, MB01UD, SB03MX, SB03SX, + $ SB03SY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + JOBC = LSAME( JOB, 'C' ) + JOBE = LSAME( JOB, 'E' ) + JOBB = LSAME( JOB, 'B' ) + NOFACT = LSAME( FACT, 'N' ) + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + UPDATE = LSAME( LYAPUN, 'O' ) +C + NEEDAC = UPDATE .AND. .NOT.JOBC +C + NN = N*N + IF( UPDATE ) THEN + LWA = NN + ELSE + LWA = 0 + END IF +C + IF( JOBC ) THEN + LDW = MAX( 3, 2*NN ) + NN + ELSE + LDW = MAX( 3, 2*NN ) + 2*NN + IF( .NOT.UPDATE ) + $ LDW = LDW + N + END IF + IF( NOFACT ) + $ LDW = MAX( LWA + 5*N, LDW ) +C + INFO = 0 + IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN + INFO = -1 + ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. + $ LSAME( TRANA, 'C' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.1 .OR. + $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN + INFO = -12 + ELSE IF( LDG.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDWORK.LT.LDW ) THEN + INFO = -24 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB02SD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + IF( .NOT.JOBE ) + $ RCOND = ONE + IF( .NOT.JOBC ) + $ FERR = ZERO + DWORK( 1 ) = ONE + RETURN + END IF +C +C Compute the 1-norm of the matrix X. +C + XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK ) + IF( XNORM.EQ.ZERO ) THEN +C +C The solution is zero. +C + IF( .NOT.JOBE ) + $ RCOND = ZERO + IF( .NOT.JOBC ) + $ FERR = ZERO + DWORK( 1 ) = DBLE( N ) + RETURN + END IF +C +C Workspace usage. +C + IRES = 0 + IXBS = IRES + NN + IXMA = MAX( 3, 2*NN ) + IABS = IXMA + NN + IWRK = IABS + NN +C +C Workspace: LWK, where +C LWK = 2*N*N, if LYAPUN = 'O', or FACT = 'N', +C LWK = N, otherwise. +C + IF( UPDATE .OR. NOFACT ) THEN +C + CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK( IXBS+1 ), N ) + CALL DSYMM( 'Left', UPLO, N, N, ONE, G, LDG, X, LDX, ONE, + $ DWORK( IXBS+1 ), N ) + IF( NOTRNA ) THEN +C -1 +C Compute Ac = (I_n + G*X) *A. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) + CALL DGESV( N, N, DWORK( IXBS+1 ), N, IWORK, DWORK, N, + $ INFO2 ) + ELSE +C -1 +C Compute Ac = A*(I_n + X*G) . +C + DO 10 J = 1, N + CALL DCOPY( N, A( 1, J ), 1, DWORK( J ), N ) + 10 CONTINUE + CALL DGESV( N, N, DWORK( IXBS+1 ), N, IWORK, DWORK, N, + $ INFO2 ) + DO 20 J = 2, N + CALL DSWAP( J-1, DWORK( (J-1)*N+1 ), 1, DWORK( J ), N ) + 20 CONTINUE + END IF +C + WRKOPT = DBLE( 2*NN ) + IF( NOFACT ) + $ CALL DLACPY( 'Full', N, N, DWORK, N, T, LDT ) + ELSE + WRKOPT = DBLE( N ) + END IF +C + IF( NOFACT ) THEN +C +C Compute the Schur factorization of Ac, Ac = U*T*U'. +C Workspace: need LWA + 5*N; +C prefer larger; +C LWA = N*N, if LYAPUN = 'O'; +C LWA = 0, otherwise. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + IF( UPDATE ) THEN + SJOB = 'V' + ELSE + SJOB = 'N' + END IF + CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, + $ DWORK( LWA+1 ), DWORK( LWA+N+1 ), U, LDU, + $ DWORK( LWA+2*N+1 ), LDWORK-LWA-2*N, BWORK, INFO ) + IF( INFO.GT.0 ) THEN + IF( LWA.GT.0 ) + $ CALL DCOPY( 2*N, DWORK( LWA+1 ), 1, DWORK, 1 ) + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, INT( DWORK( LWA+2*N+1 ) ) + LWA + 2*N ) + END IF + IF( NEEDAC ) THEN + CALL DLACPY( 'Full', N, N, DWORK, N, DWORK( IABS+1 ), N ) + LWR = NN + ELSE + LWR = 0 + END IF +C + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +C _ +C Compute X*op(Ac) or X*op(T). +C + IF( UPDATE ) THEN + CALL DGEMM( 'NoTranspose', TRANA, N, N, N, ONE, X, LDX, DWORK, + $ N, ZERO, DWORK( IXMA+1 ), N ) + ELSE + CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, + $ DWORK( IXMA+1 ), N, INFO2 ) + END IF +C + IF( .NOT.JOBE ) THEN +C +C Estimate sepd(op(Ac),op(Ac)') = sepd(op(T),op(T)') and +C norm(Theta). +C Workspace LWR + MAX(3,2*N*N) + N*N, where +C LWR = N*N, if LYAPUN = 'O' and JOB = 'B', +C LWR = 0, otherwise. +C + CALL SB03SY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, + $ DWORK( IXMA+1 ), N, SEPD, THNORM, IWORK, DWORK, + $ IXMA, INFO ) +C + WRKOPT = MAX( WRKOPT, LWR + MAX( 3, 2*NN ) + NN ) +C +C Return if the equation is singular. +C + IF( SEPD.EQ.ZERO ) THEN + RCOND = ZERO + IF( JOBB ) + $ FERR = ONE + DWORK( 1 ) = DBLE( WRKOPT ) + RETURN + END IF +C +C Estimate norm(Pi). +C Workspace LWR + MAX(3,2*N*N) + N*N. +C + KASE = 0 +C +C REPEAT + 30 CONTINUE + CALL DLACON( NN, DWORK( IXBS+1 ), DWORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +C +C Select the triangular part of symmetric matrix to be used. +C + IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( IXBS+1 )) + $ .GE. + $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( IXBS+1 )) + $ ) THEN + LOUP = 'U' + ELSE + LOUP = 'L' + END IF +C _ _ +C Compute RHS = op(Ac)'*X*W*X*op(Ac) or op(T)'*X*W*X*op(T). +C + CALL MB01RU( LOUP, TRANAT, N, N, ZERO, ONE, DWORK, N, + $ DWORK( IXMA+1 ), N, DWORK, N, DWORK( IXBS+1 ), + $ NN, INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) +C + IF( UPDATE ) THEN +C +C Transform the right-hand side: RHS := U'*RHS*U. +C + CALL MB01RU( LOUP, 'Transpose', N, N, ZERO, ONE, DWORK, + $ N, U, LDU, DWORK, N, DWORK( IXBS+1 ), NN, + $ INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) + END IF +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( LOUP, N, DWORK, N ) +C + IF( KASE.EQ.1 ) THEN +C +C Solve op(T)'*Y*op(T) - Y = scale*RHS. +C + CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE, + $ DWORK( IXBS+1 ), INFO2 ) + ELSE +C +C Solve op(T)*W*op(T)' - W = scale*RHS. +C + CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE, + $ DWORK( IXBS+1 ), INFO2 ) + END IF +C + IF( UPDATE ) THEN +C +C Transform back to obtain the solution: Z := U*Z*U', with +C Z = Y or Z = W. +C + CALL MB01RU( LOUP, 'No transpose', N, N, ZERO, ONE, + $ DWORK, N, U, LDU, DWORK, N, DWORK( IXBS+1 ), + $ NN, INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( LOUP, N, DWORK, N ) + END IF + GO TO 30 + END IF +C UNTIL KASE = 0 +C + IF( EST.LT.SCALE ) THEN + PINORM = EST / SCALE + ELSE + BIGNUM = ONE / DLAMCH( 'Safe minimum' ) + IF( EST.LT.SCALE*BIGNUM ) THEN + PINORM = EST / SCALE + ELSE + PINORM = BIGNUM + END IF + END IF +C +C Compute the 1-norm of A or T. +C + IF( UPDATE ) THEN + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) + ELSE + ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) + END IF +C +C Compute the 1-norms of the matrices Q and G. +C + QNORM = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) + GNORM = DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) +C +C Estimate the reciprocal condition number. +C + TMAX = MAX( SEPD, XNORM, ANORM, GNORM ) + IF( TMAX.LE.ONE ) THEN + TEMP = SEPD*XNORM + DENOM = QNORM + ( SEPD*ANORM )*THNORM + + $ ( SEPD*GNORM )*PINORM + ELSE + TEMP = ( SEPD / TMAX )*( XNORM / TMAX ) + DENOM = ( ( ONE / TMAX )*( QNORM / TMAX ) ) + + $ ( ( SEPD / TMAX )*( ANORM / TMAX ) )*THNORM + + $ ( ( SEPD / TMAX )*( GNORM / TMAX ) )*PINORM + END IF + IF( TEMP.GE.DENOM ) THEN + RCOND = ONE + ELSE + RCOND = TEMP / DENOM + END IF + END IF +C + IF( .NOT.JOBC ) THEN +C +C Form a triangle of the residual matrix +C R = op(Ac)'*X*op(Ac) + op(Ac)'*X*G*X*op(Ac) + Q - X, +C or _ _ _ _ _ _ +C R = op(T)'*X*op(T) + op(T)'*X*G*X*op(T) + Q - X, +C exploiting the symmetry. Actually, the equivalent formula +C R = op(A)'*X*op(Ac) + Q - X +C is used in the first case. +C Workspace MAX(3,2*N*N) + 2*N*N, if LYAPUN = 'O'; +C MAX(3,2*N*N) + 2*N*N + N, if LYAPUN = 'R'. +C + CALL DLACPY( UPLO, N, N, Q, LDQ, DWORK( IRES+1 ), N ) + JJ = IRES + 1 + IF( LOWER ) THEN + DO 40 J = 1, N + CALL DAXPY( N-J+1, -ONE, X( J, J ), 1, DWORK( JJ ), 1 ) + JJ = JJ + N + 1 + 40 CONTINUE + ELSE + DO 50 J = 1, N + CALL DAXPY( J, -ONE, X( 1, J ), 1, DWORK( JJ ), 1 ) + JJ = JJ + N + 50 CONTINUE + END IF +C + IF( UPDATE ) THEN + CALL MB01RX( 'Left', UPLO, TRANAT, N, N, ONE, ONE, + $ DWORK( IRES+1 ), N, A, LDA, DWORK( IXMA+1 ), N, + $ INFO2 ) + ELSE + CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, ONE, + $ DWORK( IRES+1 ), N, T, LDT, DWORK( IXMA+1 ), N, + $ DWORK( IWRK+1 ), INFO2 ) + CALL DSYMM( 'Left', UPLO, N, N, ONE, G, LDG, + $ DWORK( IXMA+1 ), N, ZERO, DWORK( IXBS+1 ), N ) + CALL MB01RX( 'Left', UPLO, 'Transpose', N, N, ONE, ONE, + $ DWORK( IRES+1 ), N, DWORK( IXMA+1 ), N, + $ DWORK( IXBS+1 ), N, INFO2 ) + END IF +C +C Get the machine precision. +C + EPS = DLAMCH( 'Epsilon' ) + EPSN = EPS*DBLE( N + 4 ) + EPST = EPS*DBLE( 2*( N + 1 ) ) + TEMP = EPS*FOUR +C +C Add to abs(R) a term that takes account of rounding errors in +C forming R: +C abs(R) := abs(R) + EPS*(4*abs(Q) + 4*abs(X) + +C (n+4)*abs(op(Ac))'*abs(X)*abs(op(Ac)) + 2*(n+1)* +C abs(op(Ac))'*abs(X)*abs(G)*abs(X)*abs(op(Ac))), +C or _ _ +C abs(R) := abs(R) + EPS*(4*abs(Q) + 4*abs(X) + +C _ +C (n+4)*abs(op(T))'*abs(X)*abs(op(T)) + +C _ _ _ +C 2*(n+1)*abs(op(T))'*abs(X)*abs(G)*abs(X)*abs(op(T))), +C where EPS is the machine precision. +C + DO 70 J = 1, N + DO 60 I = 1, N + DWORK( IXBS+(J-1)*N+I ) = ABS( X( I, J ) ) + 60 CONTINUE + 70 CONTINUE +C + IF( LOWER ) THEN + DO 90 J = 1, N + DO 80 I = J, N + DWORK( IRES+(J-1)*N+I ) = TEMP*( ABS( Q( I, J ) ) + + $ ABS( X( I, J ) ) ) + + $ ABS( DWORK( IRES+(J-1)*N+I ) ) + 80 CONTINUE + 90 CONTINUE + ELSE + DO 110 J = 1, N + DO 100 I = 1, J + DWORK( IRES+(J-1)*N+I ) = TEMP*( ABS( Q( I, J ) ) + + $ ABS( X( I, J ) ) ) + + $ ABS( DWORK( IRES+(J-1)*N+I ) ) + 100 CONTINUE + 110 CONTINUE + END IF +C + IF( UPDATE ) THEN +C + DO 130 J = 1, N + DO 120 I = 1, N + DWORK( IABS+(J-1)*N+I ) = + $ ABS( DWORK( IABS+(J-1)*N+I ) ) + 120 CONTINUE + 130 CONTINUE +C + CALL DGEMM( 'NoTranspose', TRANA, N, N, N, ONE, + $ DWORK( IXBS+1 ), N, DWORK( IABS+1 ), N, ZERO, + $ DWORK( IXMA+1 ), N ) + CALL MB01RX( 'Left', UPLO, TRANAT, N, N, ONE, EPSN, + $ DWORK( IRES+1 ), N, DWORK( IABS+1 ), N, + $ DWORK( IXMA+1 ), N, INFO2 ) + ELSE +C + DO 150 J = 1, N + DO 140 I = 1, MIN( J+1, N ) + DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) + 140 CONTINUE + 150 CONTINUE +C + CALL MB01UD( 'Right', TRANA, N, N, ONE, DWORK( IABS+1 ), N, + $ DWORK( IXBS+1 ), N, DWORK( IXMA+1 ), N, INFO2 ) + CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPSN, + $ DWORK( IRES+1 ), N, DWORK( IABS+1 ), N, + $ DWORK( IXMA+1 ), N, DWORK( IWRK+1 ), INFO2 ) + END IF +C + IF( LOWER ) THEN + DO 170 J = 1, N + DO 160 I = J, N + DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) + 160 CONTINUE + 170 CONTINUE + ELSE + DO 190 J = 1, N + DO 180 I = 1, J + DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) + 180 CONTINUE + 190 CONTINUE + END IF +C + IF( UPDATE ) THEN + CALL MB01RU( UPLO, TRANAT, N, N, ONE, EPST, DWORK( IRES+1 ), + $ N, DWORK( IXMA+1 ), N, DWORK( IABS+1 ), N, + $ DWORK( IXBS+1 ), NN, INFO2 ) + WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + 2*NN ) + ELSE + CALL DSYMM( 'Left', UPLO, N, N, ONE, DWORK( IABS+1 ), N, + $ DWORK( IXMA+1 ), N, ZERO, DWORK( IXBS+1 ), N ) + CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPST, + $ DWORK( IRES+1 ), N, DWORK( IXMA+1 ), N, + $ DWORK( IXBS+1 ), N, DWORK( IWRK+1 ), INFO2 ) + WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + 2*NN + N ) + END IF +C +C Compute forward error bound, using matrix norm estimator. +C Workspace MAX(3,2*N*N) + N*N. +C + XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) +C + CALL SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, + $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK( IXBS+1 ), + $ IXMA, INFO ) + END IF +C + DWORK( 1 ) = DBLE( WRKOPT ) + RETURN +C +C *** Last line of SB02SD *** + END diff --git a/mex/sources/libslicot/SB03MD.f b/mex/sources/libslicot/SB03MD.f new file mode 100644 index 000000000..986998155 --- /dev/null +++ b/mex/sources/libslicot/SB03MD.f @@ -0,0 +1,556 @@ + SUBROUTINE SB03MD( DICO, JOB, FACT, TRANA, N, A, LDA, U, LDU, C, + $ LDC, SCALE, SEP, FERR, WR, WI, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X either the real continuous-time Lyapunov equation +C +C op(A)'*X + X*op(A) = scale*C (1) +C +C or the real discrete-time Lyapunov equation +C +C op(A)'*X*op(A) - X = scale*C (2) +C +C and/or estimate an associated condition number, called separation, +C where op(A) = A or A' (A**T) and C is symmetric (C = C'). +C (A' denotes the transpose of the matrix A.) A is N-by-N, the right +C hand side C and the solution X are N-by-N, and scale is an output +C scale factor, set less than or equal to 1 to avoid overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the equation from which X is to be determined +C as follows: +C = 'C': Equation (1), continuous-time case; +C = 'D': Equation (2), discrete-time case. +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'X': Compute the solution only; +C = 'S': Compute the separation only; +C = 'B': Compute both the solution and the separation. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, A and U contain the factors from the +C real Schur factorization of the matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in A and U. +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X, and C. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. If FACT = 'F', then A contains +C an upper quasi-triangular matrix in Schur canonical form; +C the elements below the upper Hessenberg part of the +C array A are not referenced. +C On exit, if INFO = 0 or INFO = N+1, the leading N-by-N +C upper Hessenberg part of this array contains the upper +C quasi-triangular matrix in Schur canonical form from the +C Schur factorization of A. The contents of array A is not +C modified if FACT = 'F'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,N) +C If FACT = 'F', then U is an input argument and on entry +C the leading N-by-N part of this array must contain the +C orthogonal matrix U of the real Schur factorization of A. +C If FACT = 'N', then U is an output argument and on exit, +C if INFO = 0 or INFO = N+1, it contains the orthogonal +C N-by-N matrix from the real Schur factorization of A. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry with JOB = 'X' or 'B', the leading N-by-N part of +C this array must contain the symmetric matrix C. +C On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1, +C the leading N-by-N part of C has been overwritten by the +C symmetric solution matrix X. +C If JOB = 'S', C is not referenced. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= 1, if JOB = 'S'; +C LDC >= MAX(1,N), otherwise. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C SEP (output) DOUBLE PRECISION +C If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1, SEP +C contains the estimated separation of the matrices op(A) +C and -op(A)', if DICO = 'C' or of op(A) and op(A)', if +C DICO = 'D'. +C If JOB = 'X' or N = 0, SEP is not referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains an +C estimated forward error bound for the solution X. +C If XTRUE is the true solution, FERR bounds the relative +C error in the computed solution, measured in the Frobenius +C norm: norm(X - XTRUE)/norm(XTRUE). +C If JOB = 'X' or JOB = 'S', FERR is not referenced. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI +C contain the real and imaginary parts, respectively, of +C the eigenvalues of A. +C If FACT = 'F', WR and WI are not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C This array is not referenced if JOB = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 1, and +C If JOB = 'X' then +C If FACT = 'F', LDWORK >= N*N, for DICO = 'C'; +C LDWORK >= MAX(N*N, 2*N), for DICO = 'D'; +C If FACT = 'N', LDWORK >= MAX(N*N, 3*N). +C If JOB = 'S' or JOB = 'B' then +C If FACT = 'F', LDWORK >= 2*N*N, for DICO = 'C'; +C LDWORK >= 2*N*N + 2*N, for DICO = 'D'. +C If FACT = 'N', LDWORK >= MAX(2*N*N, 3*N), DICO = 'C'; +C LDWORK >= 2*N*N + 2*N, for DICO = 'D'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, the QR algorithm failed to compute all +C the eigenvalues (see LAPACK Library routine DGEES); +C elements i+1:n of WR and WI contain eigenvalues +C which have converged, and A contains the partially +C converged Schur form; +C = N+1: if DICO = 'C', and the matrices A and -A' have +C common or very close eigenvalues, or +C if DICO = 'D', and matrix A has almost reciprocal +C eigenvalues (that is, lambda(i) = 1/lambda(j) for +C some i and j, where lambda(i) and lambda(j) are +C eigenvalues of A and i <> j); perturbed values were +C used to solve the equation (but the matrix A is +C unchanged). +C +C METHOD +C +C The Schur factorization of a square matrix A is given by +C +C A = U*S*U' +C +C where U is orthogonal and S is block upper triangular with 1-by-1 +C and 2-by-2 blocks on its diagonal, these blocks corresponding to +C the eigenvalues of A, the 2-by-2 blocks being complex conjugate +C pairs. This factorization is obtained by numerically stable +C methods: first A is reduced to upper Hessenberg form (if FACT = +C 'N') by means of Householder transformations and then the +C QR Algorithm is applied to reduce the Hessenberg form to S, the +C transformation matrices being accumulated at each step to give U. +C If A has already been factorized prior to calling the routine +C however, then the factors U and S may be supplied and the initial +C factorization omitted. +C _ _ +C If we now put C = U'CU and X = UXU' equations (1) and (2) (see +C PURPOSE) become (for TRANS = 'N') +C _ _ _ +C S'X + XS = C, (3) +C and +C _ _ _ +C S'XS - X = C, (4) +C +C respectively. Partition S, C and X as +C _ _ _ _ +C (s s') (c c') (x x') +C ( 11 ) _ ( 11 ) _ ( 11 ) +C S = ( ), C = ( ), X = ( ) +C ( ) ( _ ) ( _ ) +C ( 0 S ) ( c C ) ( x X ) +C 1 1 1 +C _ _ +C where s , c and x are either scalars or 2-by-2 matrices and s, +C 11 11 11 +C _ _ +C c and x are either (N-1) element vectors or matrices with two +C columns. Equations (3) and (4) can then be re-written as +C _ _ _ +C s' x + x s = c (3.1) +C 11 11 11 11 11 +C +C _ _ _ _ +C S'x + xs = c - sx (3.2) +C 1 11 11 +C +C _ _ +C S'X + X S = C - (sx' + xs') (3.3) +C 1 1 1 1 1 +C and +C _ _ _ +C s' x s - x = c (4.1) +C 11 11 11 11 11 +C +C _ _ _ _ +C S'xs - x = c - sx s (4.2) +C 1 11 11 11 +C +C _ _ _ +C S'X S - X = C - sx s' - [s(S'x)' + (S'x)s'] (4.3) +C 1 1 1 1 1 11 1 1 +C _ +C respectively. If DICO = 'C' ['D'], then once x has been +C 11 +C found from equation (3.1) [(4.1)], equation (3.2) [(4.2)] can be +C _ +C solved by forward substitution for x and then equation (3.3) +C [(4.3)] is of the same form as (3) [(4)] but of the order (N-1) or +C (N-2) depending upon whether s is 1-by-1 or 2-by-2. +C 11 +C _ _ +C When s is 2-by-2 then x and c will be 1-by-2 matrices and s, +C 11 11 11 +C _ _ +C x and c are matrices with two columns. In this case, equation +C (3.1) [(4.1)] defines the three equations in the unknown elements +C _ +C of x and equation (3.2) [(4.2)] can then be solved by forward +C 11 _ +C substitution, a row of x being found at each step. +C +C REFERENCES +C +C [1] Barraud, A.Y. T +C A numerical algorithm to solve A XA - X = Q. +C IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977. +C +C [2] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [3] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-325, 1982. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C If DICO = 'C', SEP is defined as the separation of op(A) and +C -op(A)': +C +C sep( op(A), -op(A)' ) = sigma_min( T ) +C +C and if DICO = 'D', SEP is defined as +C +C sep( op(A), op(A)' ) = sigma_min( T ) +C +C where sigma_min(T) is the smallest singular value of the +C N*N-by-N*N matrix +C +C T = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) ) (DICO = 'C'), +C +C T = kprod( op(A)', op(A)' ) - I(N**2) (DICO = 'D'). +C +C I(x) is an x-by-x identity matrix, and kprod denotes the Kronecker +C product. The program estimates sigma_min(T) by the reciprocal of +C an estimate of the 1-norm of inverse(T). The true reciprocal +C 1-norm of inverse(T) cannot differ from sigma_min(T) by more +C than a factor of N. +C +C When SEP is small, small changes in A, C can cause large changes +C in the solution of the equation. An approximate bound on the +C maximum relative error in the computed solution is +C +C EPS * norm(A) / SEP (DICO = 'C'), +C +C EPS * norm(A)**2 / SEP (DICO = 'D'), +C +C where EPS is the machine precision. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, July 1997. +C Supersedes Release 2.0 routine SB03AD by Control Systems Research +C Group, Kingston Polytechnic, United Kingdom. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, FACT, JOB, TRANA + INTEGER INFO, LDA, LDC, LDU, LDWORK, N + DOUBLE PRECISION FERR, SCALE, SEP +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), + $ U( LDU, * ), WI( * ), WR( * ) +C .. Local Scalars .. + LOGICAL CONT, NOFACT, NOTA, WANTBH, WANTSP, WANTX + CHARACTER NOTRA, NTRNST, TRANST, UPLO + INTEGER I, IERR, KASE, LWA, MINWRK, NN, NN2, SDIM + DOUBLE PRECISION EPS, EST, SCALEF +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAMCH, DLANHS + EXTERNAL DLAMCH, DLANHS, LSAME, SELECT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DLACON, MB01RD, SB03MX, SB03MY, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + CONT = LSAME( DICO, 'C' ) + WANTX = LSAME( JOB, 'X' ) + WANTSP = LSAME( JOB, 'S' ) + WANTBH = LSAME( JOB, 'B' ) + NOFACT = LSAME( FACT, 'N' ) + NOTA = LSAME( TRANA, 'N' ) + NN = N*N + NN2 = 2*NN +C + INFO = 0 + IF( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN + INFO = -1 + ELSE IF( .NOT.WANTBH .AND. .NOT.WANTSP .AND. .NOT.WANTX ) THEN + INFO = -2 + ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -3 + ELSE IF( .NOT.NOTA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. + $ .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( WANTSP .AND. LDC.LT.1 .OR. + $ .NOT.WANTSP .AND. LDC.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE + IF ( WANTX ) THEN + IF ( NOFACT ) THEN + MINWRK = MAX( NN, 3*N ) + ELSE IF ( CONT ) THEN + MINWRK = NN + ELSE + MINWRK = MAX( NN, 2*N ) + END IF + ELSE + IF ( CONT ) THEN + IF ( NOFACT ) THEN + MINWRK = MAX( NN2, 3*N ) + ELSE + MINWRK = NN2 + END IF + ELSE + MINWRK = NN2 + 2*N + END IF + END IF + IF( LDWORK.LT.MAX( 1, MINWRK ) ) + $ INFO = -19 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB03MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + SCALE = ONE + IF( WANTBH ) + $ FERR = ZERO + DWORK(1) = ONE + RETURN + END IF +C + LWA = 0 +C + IF( NOFACT ) THEN +C +C Compute the Schur factorization of A. +C Workspace: need 3*N; +C prefer larger. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + IF( INFO.GT.0 ) + $ RETURN + LWA = INT( DWORK( 1 ) ) + END IF +C + IF( .NOT.WANTSP ) THEN +C +C Transform the right-hand side. +C Workspace: N*N. +C + NTRNST = 'N' + TRANST = 'T' + UPLO = 'U' + CALL MB01RD( UPLO, TRANST, N, N, ZERO, ONE, C, LDC, U, LDU, C, + $ LDC, DWORK, LDWORK, INFO ) +C + DO 10 I = 2, N + CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) + 10 CONTINUE +C + LWA = MAX( LWA, NN ) +C +C Solve the transformed equation. +C Workspace for DICO = 'D': 2*N. +C + IF ( CONT ) THEN + CALL SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) + ELSE + CALL SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) + END IF + IF( INFO.GT.0 ) + $ INFO = N + 1 +C +C Transform back the solution. +C Workspace: N*N. +C + CALL MB01RD( UPLO, NTRNST, N, N, ZERO, ONE, C, LDC, U, LDU, C, + $ LDC, DWORK, LDWORK, IERR ) +C + DO 20 I = 2, N + CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) + 20 CONTINUE +C + END IF +C + IF( .NOT.WANTX ) THEN +C +C Estimate the separation. +C Workspace: 2*N*N for DICO = 'C'; +C 2*N*N + 2*N for DICO = 'D'. +C + IF( NOTA ) THEN + NOTRA = 'T' + ELSE + NOTRA = 'N' + END IF +C + EST = ZERO + KASE = 0 +C REPEAT + 30 CONTINUE + CALL DLACON( NN, DWORK(NN+1), DWORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.1 ) THEN + IF( CONT ) THEN + CALL SB03MY( TRANA, N, A, LDA, DWORK, N, SCALEF, + $ IERR ) + ELSE + CALL SB03MX( TRANA, N, A, LDA, DWORK, N, SCALEF, + $ DWORK(NN2+1), IERR ) + END IF + ELSE + IF( CONT ) THEN + CALL SB03MY( NOTRA, N, A, LDA, DWORK, N, SCALEF, + $ IERR ) + ELSE + CALL SB03MX( NOTRA, N, A, LDA, DWORK, N, SCALEF, + $ DWORK(NN2+1), IERR ) + END IF + END IF + GO TO 30 + END IF +C UNTIL KASE = 0 +C + SEP = SCALEF / EST +C + IF( WANTBH ) THEN +C +C Get the machine precision. +C + EPS = DLAMCH( 'P' ) +C +C Compute the estimate of the relative error. +C + IF ( CONT ) THEN + FERR = EPS*DLANHS( 'Frobenius', N, A, LDA, DWORK )/SEP + ELSE + FERR = EPS*DLANHS( 'Frobenius', N, A, LDA, DWORK )**2/SEP + END IF + END IF + END IF +C + DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) ) + RETURN +C *** Last line of SB03MD *** + END diff --git a/mex/sources/libslicot/SB03MU.f b/mex/sources/libslicot/SB03MU.f new file mode 100644 index 000000000..69ddd7429 --- /dev/null +++ b/mex/sources/libslicot/SB03MU.f @@ -0,0 +1,467 @@ + SUBROUTINE SB03MU( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, + $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for the N1-by-N2 matrix X, 1 <= N1,N2 <= 2, in +C +C ISGN*op(TL)*X*op(TR) - X = SCALE*B, +C +C where TL is N1-by-N1, TR is N2-by-N2, B is N1-by-N2, and ISGN = 1 +C or -1. op(T) = T or T', where T' denotes the transpose of T. +C +C ARGUMENTS +C +C Mode Parameters +C +C LTRANL LOGICAL +C Specifies the form of op(TL) to be used, as follows: +C = .FALSE.: op(TL) = TL, +C = .TRUE. : op(TL) = TL'. +C +C LTRANR LOGICAL +C Specifies the form of op(TR) to be used, as follows: +C = .FALSE.: op(TR) = TR, +C = .TRUE. : op(TR) = TR'. +C +C ISGN INTEGER +C Specifies the sign of the equation as described before. +C ISGN may only be 1 or -1. +C +C Input/Output Parameters +C +C N1 (input) INTEGER +C The order of matrix TL. N1 may only be 0, 1 or 2. +C +C N2 (input) INTEGER +C The order of matrix TR. N2 may only be 0, 1 or 2. +C +C TL (input) DOUBLE PRECISION array, dimension (LDTL,2) +C The leading N1-by-N1 part of this array must contain the +C matrix TL. +C +C LDTL INTEGER +C The leading dimension of array TL. LDTL >= MAX(1,N1). +C +C TR (input) DOUBLE PRECISION array, dimension (LDTR,2) +C The leading N2-by-N2 part of this array must contain the +C matrix TR. +C +C LDTR INTEGER +C The leading dimension of array TR. LDTR >= MAX(1,N2). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,2) +C The leading N1-by-N2 part of this array must contain the +C right-hand side of the equation. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N1). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor. SCALE is chosen less than or equal to 1 +C to prevent the solution overflowing. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N2) +C The leading N1-by-N2 part of this array contains the +C solution of the equation. +C Note that X may be identified with B in the calling +C statement. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= MAX(1,N1). +C +C XNORM (output) DOUBLE PRECISION +C The infinity-norm of the solution. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if TL and TR have almost reciprocal eigenvalues, so +C TL or TR is perturbed to get a nonsingular equation. +C +C NOTE: In the interests of speed, this routine does not +C check the inputs for errors. +C +C METHOD +C +C The equivalent linear algebraic system of equations is formed and +C solved using Gaussian elimination with complete pivoting. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C The algorithm is stable and reliable, since Gaussian elimination +C with complete pivoting is used. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Based on DLASD2 by P. Petkov, Tech. University of Sofia, September +C 1993. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. +C +C KEYWORDS +C +C Discrete-time system, Sylvester equation, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, HALF, EIGHT + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, + $ TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) +C .. +C .. Scalar Arguments .. + LOGICAL LTRANL, LTRANR + INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 + DOUBLE PRECISION SCALE, XNORM +C .. +C .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), + $ X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL BSWAP, XSWAP + INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K + DOUBLE PRECISION BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, + $ TEMP, U11, U12, U22, XMAX +C .. +C .. Local Arrays .. + LOGICAL BSWPIV( 4 ), XSWPIV( 4 ) + INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), + $ LOCU22( 4 ) + DOUBLE PRECISION BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 ) +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, IDAMAX +C .. +C .. External Subroutines .. + EXTERNAL DSWAP +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. +C .. Data statements .. + DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , + $ LOCU22 / 4, 3, 2, 1 / + DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. / + DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. / +C .. +C .. Executable Statements .. +C +C Do not check the input parameters for errors. +C + INFO = 0 + SCALE = ONE +C +C Quick return if possible. +C + IF( N1.EQ.0 .OR. N2.EQ.0 ) THEN + XNORM = ZERO + RETURN + END IF +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + SGN = ISGN +C + K = N1 + N1 + N2 - 2 + GO TO ( 10, 20, 30, 50 )K +C +C 1-by-1: SGN*TL11*X*TR11 - X = B11. +C + 10 CONTINUE + TAU1 = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE + BET = ABS( TAU1 ) + IF( BET.LE.SMLNUM ) THEN + TAU1 = SMLNUM + BET = SMLNUM + INFO = 1 + END IF +C + GAM = ABS( B( 1, 1 ) ) + IF( SMLNUM*GAM.GT.BET ) + $ SCALE = ONE / GAM +C + X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 + XNORM = ABS( X( 1, 1 ) ) + RETURN +C +C 1-by-2: +C ISGN*TL11*[X11 X12]*op[TR11 TR12] = [B11 B12]. +C [TR21 TR22] +C + 20 CONTINUE +C + SMIN = MAX( MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), + $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) + $ *ABS( TL( 1, 1 ) )*EPS, + $ SMLNUM ) + TMP( 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE + TMP( 4 ) = SGN*TL( 1, 1 )*TR( 2, 2 ) - ONE + IF( LTRANR ) THEN + TMP( 2 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) + TMP( 3 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) + ELSE + TMP( 2 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) + TMP( 3 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 1, 2 ) + GO TO 40 +C +C 2-by-1: +C ISGN*op[TL11 TL12]*[X11]*TR11 = [B11]. +C [TL21 TL22] [X21] [B21] +C + 30 CONTINUE + SMIN = MAX( MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), + $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) + $ *ABS( TR( 1, 1 ) )*EPS, + $ SMLNUM ) + TMP( 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE + TMP( 4 ) = SGN*TL( 2, 2 )*TR( 1, 1 ) - ONE + IF( LTRANL ) THEN + TMP( 2 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) + TMP( 3 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) + ELSE + TMP( 2 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) + TMP( 3 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 2, 1 ) + 40 CONTINUE +C +C Solve 2-by-2 system using complete pivoting. +C Set pivots less than SMIN to SMIN. +C + IPIV = IDAMAX( 4, TMP, 1 ) + U11 = TMP( IPIV ) + IF( ABS( U11 ).LE.SMIN ) THEN + INFO = 1 + U11 = SMIN + END IF + U12 = TMP( LOCU12( IPIV ) ) + L21 = TMP( LOCL21( IPIV ) ) / U11 + U22 = TMP( LOCU22( IPIV ) ) - U12*L21 + XSWAP = XSWPIV( IPIV ) + BSWAP = BSWPIV( IPIV ) + IF( ABS( U22 ).LE.SMIN ) THEN + INFO = 1 + U22 = SMIN + END IF + IF( BSWAP ) THEN + TEMP = BTMP( 2 ) + BTMP( 2 ) = BTMP( 1 ) - L21*TEMP + BTMP( 1 ) = TEMP + ELSE + BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 ) + END IF + IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. + $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN + SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + END IF + X2( 2 ) = BTMP( 2 ) / U22 + X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 ) + IF( XSWAP ) THEN + TEMP = X2( 2 ) + X2( 2 ) = X2( 1 ) + X2( 1 ) = TEMP + END IF + X( 1, 1 ) = X2( 1 ) + IF( N1.EQ.1 ) THEN + X( 1, 2 ) = X2( 2 ) + XNORM = ABS( X2( 1 ) ) + ABS( X2( 2 ) ) + ELSE + X( 2, 1 ) = X2( 2 ) + XNORM = MAX( ABS( X2( 1 ) ), ABS( X2( 2 ) ) ) + END IF + RETURN +C +C 2-by-2: +C ISGN*op[TL11 TL12]*[X11 X12]*op[TR11 TR12]-[X11 X12] = [B11 B12]. +C [TL21 TL22] [X21 X22] [TR21 TR22] [X21 X22] [B21 B22] +C +C Solve equivalent 4-by-4 system using complete pivoting. +C Set pivots less than SMIN to SMIN. +C + 50 CONTINUE + SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), + $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) + SMIN = MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), + $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )*SMIN + SMIN = MAX( EPS*SMIN, SMLNUM ) + T16( 1, 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE + T16( 2, 2 ) = SGN*TL( 2, 2 )*TR( 1, 1 ) - ONE + T16( 3, 3 ) = SGN*TL( 1, 1 )*TR( 2, 2 ) - ONE + T16( 4, 4 ) = SGN*TL( 2, 2 )*TR( 2, 2 ) - ONE + IF( LTRANL ) THEN + T16( 1, 2 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) + T16( 2, 1 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) + T16( 3, 4 ) = SGN*TL( 2, 1 )*TR( 2, 2 ) + T16( 4, 3 ) = SGN*TL( 1, 2 )*TR( 2, 2 ) + ELSE + T16( 1, 2 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) + T16( 2, 1 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) + T16( 3, 4 ) = SGN*TL( 1, 2 )*TR( 2, 2 ) + T16( 4, 3 ) = SGN*TL( 2, 1 )*TR( 2, 2 ) + END IF + IF( LTRANR ) THEN + T16( 1, 3 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) + T16( 2, 4 ) = SGN*TL( 2, 2 )*TR( 1, 2 ) + T16( 3, 1 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) + T16( 4, 2 ) = SGN*TL( 2, 2 )*TR( 2, 1 ) + ELSE + T16( 1, 3 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) + T16( 2, 4 ) = SGN*TL( 2, 2 )*TR( 2, 1 ) + T16( 3, 1 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) + T16( 4, 2 ) = SGN*TL( 2, 2 )*TR( 1, 2 ) + END IF + IF( LTRANL .AND. LTRANR ) THEN + T16( 1, 4 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) + T16( 2, 3 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) + T16( 3, 2 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) + T16( 4, 1 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) + ELSE IF( LTRANL .AND. .NOT.LTRANR ) THEN + T16( 1, 4 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) + T16( 2, 3 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) + T16( 3, 2 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) + T16( 4, 1 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) + ELSE IF( .NOT.LTRANL .AND. LTRANR ) THEN + T16( 1, 4 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) + T16( 2, 3 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) + T16( 3, 2 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) + T16( 4, 1 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) + ELSE + T16( 1, 4 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) + T16( 2, 3 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) + T16( 3, 2 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) + T16( 4, 1 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 2, 1 ) + BTMP( 3 ) = B( 1, 2 ) + BTMP( 4 ) = B( 2, 2 ) +C +C Perform elimination +C + DO 100 I = 1, 3 + XMAX = ZERO +C + DO 70 IP = I, 4 +C + DO 60 JP = I, 4 + IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN + XMAX = ABS( T16( IP, JP ) ) + IPSV = IP + JPSV = JP + END IF + 60 CONTINUE +C + 70 CONTINUE +C + IF( IPSV.NE.I ) THEN + CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 ) + TEMP = BTMP( I ) + BTMP( I ) = BTMP( IPSV ) + BTMP( IPSV ) = TEMP + END IF + IF( JPSV.NE.I ) + $ CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 ) + JPIV( I ) = JPSV + IF( ABS( T16( I, I ) ).LT.SMIN ) THEN + INFO = 1 + T16( I, I ) = SMIN + END IF +C + DO 90 J = I + 1, 4 + T16( J, I ) = T16( J, I ) / T16( I, I ) + BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) +C + DO 80 K = I + 1, 4 + T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) + 80 CONTINUE +C + 90 CONTINUE +C + 100 CONTINUE +C + IF( ABS( T16( 4, 4 ) ).LT.SMIN ) + $ T16( 4, 4 ) = SMIN + IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN + SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), + $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), + $ ABS( BTMP( 4 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + BTMP( 3 ) = BTMP( 3 )*SCALE + BTMP( 4 ) = BTMP( 4 )*SCALE + END IF +C + DO 120 I = 1, 4 + K = 5 - I + TEMP = ONE / T16( K, K ) + TMP( K ) = BTMP( K )*TEMP +C + DO 110 J = K + 1, 4 + TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) + 110 CONTINUE +C + 120 CONTINUE +C + DO 130 I = 1, 3 + IF( JPIV( 4-I ).NE.4-I ) THEN + TEMP = TMP( 4-I ) + TMP( 4-I ) = TMP( JPIV( 4-I ) ) + TMP( JPIV( 4-I ) ) = TEMP + END IF + 130 CONTINUE +C + X( 1, 1 ) = TMP( 1 ) + X( 2, 1 ) = TMP( 2 ) + X( 1, 2 ) = TMP( 3 ) + X( 2, 2 ) = TMP( 4 ) + XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 3 ) ), + $ ABS( TMP( 2 ) ) + ABS( TMP( 4 ) ) ) +C + RETURN +C *** Last line of SB03MU *** + END diff --git a/mex/sources/libslicot/SB03MV.f b/mex/sources/libslicot/SB03MV.f new file mode 100644 index 000000000..30dcc6af0 --- /dev/null +++ b/mex/sources/libslicot/SB03MV.f @@ -0,0 +1,295 @@ + SUBROUTINE SB03MV( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX, + $ XNORM, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for the 2-by-2 symmetric matrix X in +C +C op(T)'*X*op(T) - X = SCALE*B, +C +C where T is 2-by-2, B is symmetric 2-by-2, and op(T) = T or T', +C where T' denotes the transpose of T. +C +C ARGUMENTS +C +C Mode Parameters +C +C LTRAN LOGICAL +C Specifies the form of op(T) to be used, as follows: +C = .FALSE.: op(T) = T, +C = .TRUE. : op(T) = T'. +C +C LUPPER LOGICAL +C Specifies which triangle of the matrix B is used, and +C which triangle of the matrix X is computed, as follows: +C = .TRUE. : The upper triangular part; +C = .FALSE.: The lower triangular part. +C +C Input/Output Parameters +C +C T (input) DOUBLE PRECISION array, dimension (LDT,2) +C The leading 2-by-2 part of this array must contain the +C matrix T. +C +C LDT INTEGER +C The leading dimension of array T. LDT >= 2. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,2) +C On entry with LUPPER = .TRUE., the leading 2-by-2 upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix B and the strictly +C lower triangular part of B is not referenced. +C On entry with LUPPER = .FALSE., the leading 2-by-2 lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix B and the strictly +C upper triangular part of B is not referenced. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= 2. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor. SCALE is chosen less than or equal to 1 +C to prevent the solution overflowing. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,2) +C On exit with LUPPER = .TRUE., the leading 2-by-2 upper +C triangular part of this array contains the upper +C triangular part of the symmetric solution matrix X and the +C strictly lower triangular part of X is not referenced. +C On exit with LUPPER = .FALSE., the leading 2-by-2 lower +C triangular part of this array contains the lower +C triangular part of the symmetric solution matrix X and the +C strictly upper triangular part of X is not referenced. +C Note that X may be identified with B in the calling +C statement. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= 2. +C +C XNORM (output) DOUBLE PRECISION +C The infinity-norm of the solution. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if T has almost reciprocal eigenvalues, so T +C is perturbed to get a nonsingular equation. +C +C NOTE: In the interests of speed, this routine does not +C check the inputs for errors. +C +C METHOD +C +C The equivalent linear algebraic system of equations is formed and +C solved using Gaussian elimination with complete pivoting. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C The algorithm is stable and reliable, since Gaussian elimination +C with complete pivoting is used. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Based on DLALD2 by P. Petkov, Tech. University of Sofia, September +C 1993. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Discrete-time system, Lyapunov equation, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, FOUR + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+0 ) +C .. +C .. Scalar Arguments .. + LOGICAL LTRAN, LUPPER + INTEGER INFO, LDB, LDT, LDX + DOUBLE PRECISION SCALE, XNORM +C .. +C .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), T( LDT, * ), X( LDX, * ) +C .. +C .. Local Scalars .. + INTEGER I, IP, IPSV, J, JP, JPSV, K + DOUBLE PRECISION EPS, SMIN, SMLNUM, TEMP, XMAX +C .. +C .. Local Arrays .. + INTEGER JPIV( 3 ) + DOUBLE PRECISION BTMP( 3 ), T9( 3, 3 ), TMP( 3 ) +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DSWAP +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. +C .. Executable Statements .. +C +C Do not check the input parameters for errors. +C + INFO = 0 +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS +C +C Solve equivalent 3-by-3 system using complete pivoting. +C Set pivots less than SMIN to SMIN. +C + SMIN = MAX( ABS( T( 1, 1 ) ), ABS( T( 1, 2 ) ), + $ ABS( T( 2, 1 ) ), ABS( T( 2, 2 ) ) ) + SMIN = MAX( EPS*SMIN, SMLNUM ) + T9( 1, 1 ) = T( 1, 1 )*T( 1, 1 ) - ONE + T9( 2, 2 ) = T( 1, 1 )*T( 2, 2 ) + T( 1, 2 )*T( 2, 1 ) - ONE + T9( 3, 3 ) = T( 2, 2 )*T( 2, 2 ) - ONE + IF( LTRAN ) THEN + T9( 1, 2 ) = T( 1, 1 )*T( 1, 2 ) + T( 1, 1 )*T( 1, 2 ) + T9( 1, 3 ) = T( 1, 2 )*T( 1, 2 ) + T9( 2, 1 ) = T( 1, 1 )*T( 2, 1 ) + T9( 2, 3 ) = T( 1, 2 )*T( 2, 2 ) + T9( 3, 1 ) = T( 2, 1 )*T( 2, 1 ) + T9( 3, 2 ) = T( 2, 1 )*T( 2, 2 ) + T( 2, 1 )*T( 2, 2 ) + ELSE + T9( 1, 2 ) = T( 1, 1 )*T( 2, 1 ) + T( 1, 1 )*T( 2, 1 ) + T9( 1, 3 ) = T( 2, 1 )*T( 2, 1 ) + T9( 2, 1 ) = T( 1, 1 )*T( 1, 2 ) + T9( 2, 3 ) = T( 2, 1 )*T( 2, 2 ) + T9( 3, 1 ) = T( 1, 2 )*T( 1, 2 ) + T9( 3, 2 ) = T( 1, 2 )*T( 2, 2 ) + T( 1, 2 )*T( 2, 2 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + IF ( LUPPER ) THEN + BTMP( 2 ) = B( 1, 2 ) + ELSE + BTMP( 2 ) = B( 2, 1 ) + END IF + BTMP( 3 ) = B( 2, 2 ) +C +C Perform elimination. +C + DO 50 I = 1, 2 + XMAX = ZERO +C + DO 20 IP = I, 3 +C + DO 10 JP = I, 3 + IF( ABS( T9( IP, JP ) ).GE.XMAX ) THEN + XMAX = ABS( T9( IP, JP ) ) + IPSV = IP + JPSV = JP + END IF + 10 CONTINUE +C + 20 CONTINUE +C + IF( IPSV.NE.I ) THEN + CALL DSWAP( 3, T9( IPSV, 1 ), 3, T9( I, 1 ), 3 ) + TEMP = BTMP( I ) + BTMP( I ) = BTMP( IPSV ) + BTMP( IPSV ) = TEMP + END IF + IF( JPSV.NE.I ) + $ CALL DSWAP( 3, T9( 1, JPSV ), 1, T9( 1, I ), 1 ) + JPIV( I ) = JPSV + IF( ABS( T9( I, I ) ).LT.SMIN ) THEN + INFO = 1 + T9( I, I ) = SMIN + END IF +C + DO 40 J = I + 1, 3 + T9( J, I ) = T9( J, I ) / T9( I, I ) + BTMP( J ) = BTMP( J ) - T9( J, I )*BTMP( I ) +C + DO 30 K = I + 1, 3 + T9( J, K ) = T9( J, K ) - T9( J, I )*T9( I, K ) + 30 CONTINUE +C + 40 CONTINUE +C + 50 CONTINUE +C + IF( ABS( T9( 3, 3 ) ).LT.SMIN ) + $ T9( 3, 3 ) = SMIN + SCALE = ONE + IF( ( FOUR*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T9( 1, 1 ) ) .OR. + $ ( FOUR*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T9( 2, 2 ) ) .OR. + $ ( FOUR*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T9( 3, 3 ) ) ) THEN + SCALE = ( ONE / FOUR ) / MAX( ABS( BTMP( 1 ) ), + $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + BTMP( 3 ) = BTMP( 3 )*SCALE + END IF +C + DO 70 I = 1, 3 + K = 4 - I + TEMP = ONE / T9( K, K ) + TMP( K ) = BTMP( K )*TEMP +C + DO 60 J = K + 1, 3 + TMP( K ) = TMP( K ) - ( TEMP*T9( K, J ) )*TMP( J ) + 60 CONTINUE +C + 70 CONTINUE +C + DO 80 I = 1, 2 + IF( JPIV( 3-I ).NE.3-I ) THEN + TEMP = TMP( 3-I ) + TMP( 3-I ) = TMP( JPIV( 3-I ) ) + TMP( JPIV( 3-I ) ) = TEMP + END IF + 80 CONTINUE +C + X( 1, 1 ) = TMP( 1 ) + IF ( LUPPER ) THEN + X( 1, 2 ) = TMP( 2 ) + ELSE + X( 2, 1 ) = TMP( 2 ) + END IF + X( 2, 2 ) = TMP( 3 ) + XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 2 ) ), + $ ABS( TMP( 2 ) ) + ABS( TMP( 3 ) ) ) +C + RETURN +C *** Last line of SB03MV *** + END diff --git a/mex/sources/libslicot/SB03MW.f b/mex/sources/libslicot/SB03MW.f new file mode 100644 index 000000000..8a0a51202 --- /dev/null +++ b/mex/sources/libslicot/SB03MW.f @@ -0,0 +1,293 @@ + SUBROUTINE SB03MW( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX, + $ XNORM, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for the 2-by-2 symmetric matrix X in +C +C op(T)'*X + X*op(T) = SCALE*B, +C +C where T is 2-by-2, B is symmetric 2-by-2, and op(T) = T or T', +C where T' denotes the transpose of T. +C +C ARGUMENTS +C +C Mode Parameters +C +C LTRAN LOGICAL +C Specifies the form of op(T) to be used, as follows: +C = .FALSE.: op(T) = T, +C = .TRUE. : op(T) = T'. +C +C LUPPER LOGICAL +C Specifies which triangle of the matrix B is used, and +C which triangle of the matrix X is computed, as follows: +C = .TRUE. : The upper triangular part; +C = .FALSE.: The lower triangular part. +C +C Input/Output Parameters +C +C T (input) DOUBLE PRECISION array, dimension (LDT,2) +C The leading 2-by-2 part of this array must contain the +C matrix T. +C +C LDT INTEGER +C The leading dimension of array T. LDT >= 2. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,2) +C On entry with LUPPER = .TRUE., the leading 2-by-2 upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix B and the strictly +C lower triangular part of B is not referenced. +C On entry with LUPPER = .FALSE., the leading 2-by-2 lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix B and the strictly +C upper triangular part of B is not referenced. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= 2. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor. SCALE is chosen less than or equal to 1 +C to prevent the solution overflowing. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,2) +C On exit with LUPPER = .TRUE., the leading 2-by-2 upper +C triangular part of this array contains the upper +C triangular part of the symmetric solution matrix X and the +C strictly lower triangular part of X is not referenced. +C On exit with LUPPER = .FALSE., the leading 2-by-2 lower +C triangular part of this array contains the lower +C triangular part of the symmetric solution matrix X and the +C strictly upper triangular part of X is not referenced. +C Note that X may be identified with B in the calling +C statement. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= 2. +C +C XNORM (output) DOUBLE PRECISION +C The infinity-norm of the solution. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if T and -T have too close eigenvalues, so T +C is perturbed to get a nonsingular equation. +C +C NOTE: In the interests of speed, this routine does not +C check the inputs for errors. +C +C METHOD +C +C The equivalent linear algebraic system of equations is formed and +C solved using Gaussian elimination with complete pivoting. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C The algorithm is stable and reliable, since Gaussian elimination +C with complete pivoting is used. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Based on DLALY2 by P. Petkov, Tech. University of Sofia, September +C 1993. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Continuous-time system, Lyapunov equation, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, FOUR + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+0 ) +C .. +C .. Scalar Arguments .. + LOGICAL LTRAN, LUPPER + INTEGER INFO, LDB, LDT, LDX + DOUBLE PRECISION SCALE, XNORM +C .. +C .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), T( LDT, * ), X( LDX, * ) +C .. +C .. Local Scalars .. + INTEGER I, IP, IPSV, J, JP, JPSV, K + DOUBLE PRECISION EPS, SMIN, SMLNUM, TEMP, XMAX +C .. +C .. Local Arrays .. + INTEGER JPIV( 3 ) + DOUBLE PRECISION BTMP( 3 ), T9( 3, 3 ), TMP( 3 ) +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DSWAP +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. +C .. Executable Statements .. +C +C Do not check the input parameters for errors +C + INFO = 0 +C +C Set constants to control overflow +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS +C +C Solve equivalent 3-by-3 system using complete pivoting. +C Set pivots less than SMIN to SMIN. +C + SMIN = MAX( MAX( ABS( T( 1, 1 ) ), ABS( T( 1, 2 ) ), + $ ABS( T( 2, 1 ) ), ABS( T( 2, 2 ) ) )*EPS, + $ SMLNUM ) + T9( 1, 3 ) = ZERO + T9( 3, 1 ) = ZERO + T9( 1, 1 ) = T( 1, 1 ) + T9( 2, 2 ) = T( 1, 1 ) + T( 2, 2 ) + T9( 3, 3 ) = T( 2, 2 ) + IF( LTRAN ) THEN + T9( 1, 2 ) = T( 1, 2 ) + T9( 2, 1 ) = T( 2, 1 ) + T9( 2, 3 ) = T( 1, 2 ) + T9( 3, 2 ) = T( 2, 1 ) + ELSE + T9( 1, 2 ) = T( 2, 1 ) + T9( 2, 1 ) = T( 1, 2 ) + T9( 2, 3 ) = T( 2, 1 ) + T9( 3, 2 ) = T( 1, 2 ) + END IF + BTMP( 1 ) = B( 1, 1 )/TWO + IF ( LUPPER ) THEN + BTMP( 2 ) = B( 1, 2 ) + ELSE + BTMP( 2 ) = B( 2, 1 ) + END IF + BTMP( 3 ) = B( 2, 2 )/TWO +C +C Perform elimination +C + DO 50 I = 1, 2 + XMAX = ZERO +C + DO 20 IP = I, 3 +C + DO 10 JP = I, 3 + IF( ABS( T9( IP, JP ) ).GE.XMAX ) THEN + XMAX = ABS( T9( IP, JP ) ) + IPSV = IP + JPSV = JP + END IF + 10 CONTINUE +C + 20 CONTINUE +C + IF( IPSV.NE.I ) THEN + CALL DSWAP( 3, T9( IPSV, 1 ), 3, T9( I, 1 ), 3 ) + TEMP = BTMP( I ) + BTMP( I ) = BTMP( IPSV ) + BTMP( IPSV ) = TEMP + END IF + IF( JPSV.NE.I ) + $ CALL DSWAP( 3, T9( 1, JPSV ), 1, T9( 1, I ), 1 ) + JPIV( I ) = JPSV + IF( ABS( T9( I, I ) ).LT.SMIN ) THEN + INFO = 1 + T9( I, I ) = SMIN + END IF +C + DO 40 J = I + 1, 3 + T9( J, I ) = T9( J, I ) / T9( I, I ) + BTMP( J ) = BTMP( J ) - T9( J, I )*BTMP( I ) +C + DO 30 K = I + 1, 3 + T9( J, K ) = T9( J, K ) - T9( J, I )*T9( I, K ) + 30 CONTINUE +C + 40 CONTINUE +C + 50 CONTINUE +C + IF( ABS( T9( 3, 3 ) ).LT.SMIN ) + $ T9( 3, 3 ) = SMIN + SCALE = ONE + IF( ( FOUR*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T9( 1, 1 ) ) .OR. + $ ( FOUR*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T9( 2, 2 ) ) .OR. + $ ( FOUR*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T9( 3, 3 ) ) ) THEN + SCALE = ( ONE / FOUR ) / MAX( ABS( BTMP( 1 ) ), + $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + BTMP( 3 ) = BTMP( 3 )*SCALE + END IF +C + DO 70 I = 1, 3 + K = 4 - I + TEMP = ONE / T9( K, K ) + TMP( K ) = BTMP( K )*TEMP +C + DO 60 J = K + 1, 3 + TMP( K ) = TMP( K ) - ( TEMP*T9( K, J ) )*TMP( J ) + 60 CONTINUE +C + 70 CONTINUE +C + DO 80 I = 1, 2 + IF( JPIV( 3-I ).NE.3-I ) THEN + TEMP = TMP( 3-I ) + TMP( 3-I ) = TMP( JPIV( 3-I ) ) + TMP( JPIV( 3-I ) ) = TEMP + END IF + 80 CONTINUE +C + X( 1, 1 ) = TMP( 1 ) + IF ( LUPPER ) THEN + X( 1, 2 ) = TMP( 2 ) + ELSE + X( 2, 1 ) = TMP( 2 ) + END IF + X( 2, 2 ) = TMP( 3 ) + XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 2 ) ), + $ ABS( TMP( 2 ) ) + ABS( TMP( 3 ) ) ) +C + RETURN +C *** Last line of SB03MW *** + END diff --git a/mex/sources/libslicot/SB03MX.f b/mex/sources/libslicot/SB03MX.f new file mode 100644 index 000000000..31b392998 --- /dev/null +++ b/mex/sources/libslicot/SB03MX.f @@ -0,0 +1,711 @@ + SUBROUTINE SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the real discrete Lyapunov matrix equation +C +C op(A)'*X*op(A) - X = scale*C +C +C where op(A) = A or A' (A**T), A is upper quasi-triangular and C is +C symmetric (C = C'). (A' denotes the transpose of the matrix A.) +C A is N-by-N, the right hand side C and the solution X are N-by-N, +C and scale is an output scale factor, set less than or equal to 1 +C to avoid overflow in X. The solution matrix X is overwritten +C onto C. +C +C A must be in Schur canonical form (as returned by LAPACK routines +C DGEES or DHSEQR), that is, block upper triangular with 1-by-1 and +C 2-by-2 diagonal blocks; each 2-by-2 diagonal block has its +C diagonal elements equal and its off-diagonal elements of opposite +C sign. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X, and C. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C upper quasi-triangular matrix A, in Schur canonical form. +C The part of A below the first sub-diagonal is not +C referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading N-by-N part of this array must +C contain the symmetric matrix C. +C On exit, if INFO >= 0, the leading N-by-N part of this +C array contains the symmetric solution matrix X. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if A has almost reciprocal eigenvalues; perturbed +C values were used to solve the equation (but the +C matrix A is unchanged). +C +C METHOD +C +C A discrete-time version of the Bartels-Stewart algorithm is used. +C A set of equivalent linear algebraic systems of equations of order +C at most four are formed and solved using Gaussian elimination with +C complete pivoting. +C +C REFERENCES +C +C [1] Barraud, A.Y. T +C A numerical algorithm to solve A XA - X = Q. +C IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977. +C +C [2] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Supersedes Release 2.0 routine SB03AZ by Control Systems Research +C Group, Kingston Polytechnic, United Kingdom, October 1982. +C Based on DTRLPD by P. Petkov, Tech. University of Sofia, September +C 1993. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C A. Varga, DLR Oberpfaffenhofen, March 2002. +C +C KEYWORDS +C +C Discrete-time system, Lyapunov equation, matrix algebra, real +C Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER TRANA + INTEGER INFO, LDA, LDC, N + DOUBLE PRECISION SCALE +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ) +C .. +C .. Local Scalars .. + LOGICAL NOTRNA, LUPPER + INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT, + $ MINK1N, MINK2N, MINL1N, MINL2N, NP1 + DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, P11, P12, P21, P22, + $ SCALOC, SMIN, SMLNUM, XNORM +C .. +C .. Local Arrays .. + DOUBLE PRECISION VEC( 2, 2 ), X( 2, 2 ) +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT, DLAMCH, DLANHS + EXTERNAL DDOT, DLAMCH, DLANHS, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DLABAD, DLALN2, DSCAL, DSYMV, SB03MV, SB04PX, + $ XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + NOTRNA = LSAME( TRANA, 'N' ) + LUPPER = .TRUE. +C + INFO = 0 + IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. + $ .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03MX', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM*DBLE( N*N ) / EPS + BIGNUM = ONE / SMLNUM +C + SMIN = MAX( SMLNUM, EPS*DLANHS( 'Max', N, A, LDA, DWORK ) ) + NP1 = N + 1 +C + IF( NOTRNA ) THEN +C +C Solve A'*X*A - X = scale*C. +C +C The (K,L)th block of X is determined starting from +C upper-left corner column by column by +C +C A(K,K)'*X(K,L)*A(L,L) - X(K,L) = C(K,L) - R(K,L), +C +C where +C K L-1 +C R(K,L) = SUM {A(I,K)'*SUM [X(I,J)*A(J,L)]} + +C I=1 J=1 +C +C K-1 +C {SUM [A(I,K)'*X(I,L)]}*A(L,L). +C I=1 +C +C Start column loop (index = L). +C L1 (L2): column index of the first (last) row of X(K,L). +C + LNEXT = 1 +C + DO 60 L = 1, N + IF( L.LT.LNEXT ) + $ GO TO 60 + L1 = L + L2 = L + IF( L.LT.N ) THEN + IF( A( L+1, L ).NE.ZERO ) + $ L2 = L2 + 1 + LNEXT = L2 + 1 + END IF +C +C Start row loop (index = K). +C K1 (K2): row index of the first (last) row of X(K,L). +C + DWORK( L1 ) = ZERO + DWORK( N+L1 ) = ZERO + CALL DSYMV( 'Lower', L1-1, ONE, C, LDC, A( 1, L1 ), 1, ZERO, + $ DWORK, 1 ) + CALL DSYMV( 'Lower', L1-1, ONE, C, LDC, A( 1, L2 ), 1, ZERO, + $ DWORK( NP1 ), 1 ) +C + KNEXT = L +C + DO 50 K = L, N + IF( K.LT.KNEXT ) + $ GO TO 50 + K1 = K + K2 = K + IF( K.LT.N ) THEN + IF( A( K+1, K ).NE.ZERO ) + $ K2 = K2 + 1 + KNEXT = K2 + 1 + END IF +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), + $ 1 ) +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + A( L1, L1 ) + $ *DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) ) + SCALOC = ONE +C + A11 = A( K1, K1 )*A( L1, L1 ) - ONE + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 10 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 10 CONTINUE +C + CALL DSCAL( N, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + IF( K1.NE.L1 ) THEN + C( L1, K1 ) = X( 1, 1 ) + END IF +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), + $ 1 ) + DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), + $ 1 ) +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + A( L1, L1 ) + $ *DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) ) +C + VEC( 2, 1 ) = C( K2, L1 ) - + $ ( DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + A( L1, L1 ) + $ *DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, A( L1, L1 ), + $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, ONE, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 20 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 20 CONTINUE +C + CALL DSCAL( N, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) + C( L1, K1 ) = X( 1, 1 ) + C( L1, K2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), + $ 1 ) + DWORK( N+K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ A( 1, L2 ), 1 ) + P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + + $ P11*A( L1, L1 ) + P12*A( L2, L1 ) ) +C + VEC( 2, 1 ) = C( K1, L2 ) - + $ ( DDOT( K1, A( 1, K1 ), 1, DWORK( NP1 ), 1 ) + + $ P11*A( L1, L2 ) + P12*A( L2, L2 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ), + $ A( L1, L1 ), LDA, ONE, ONE, VEC, 2, ONE, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 30 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 30 CONTINUE +C + CALL DSCAL( N, SCALOC, DWORK, 1 ) + CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) + C( L1, K1 ) = X( 1, 1 ) + C( L2, K1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), + $ 1 ) + DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), + $ 1 ) + DWORK( N+K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ A( 1, L2 ), 1 ) + DWORK( N+K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, + $ A( 1, L2 ), 1 ) + P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + + $ P11*A( L1, L1 ) + P12*A( L2, L1 ) ) +C + VEC( 1, 2 ) = C( K1, L2 ) - + $ ( DDOT( K2, A( 1, K1 ), 1, DWORK( NP1 ), 1 ) + + $ P11*A( L1, L2 ) + P12*A( L2, L2 ) ) +C + VEC( 2, 1 ) = C( K2, L1 ) - + $ ( DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + + $ P21*A( L1, L1 ) + P22*A( L2, L1 ) ) +C + VEC( 2, 2 ) = C( K2, L2 ) - + $ ( DDOT( K2, A( 1, K2 ), 1, DWORK( NP1 ), 1 ) + + $ P21*A( L1, L2 ) + P22*A( L2, L2 ) ) +C + IF( K1.EQ.L1 ) THEN + CALL SB03MV( .FALSE., LUPPER, A( K1, K1 ), LDA, + $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) + IF( LUPPER ) THEN + X( 2, 1 ) = X( 1, 2 ) + ELSE + X( 1, 2 ) = X( 2, 1 ) + END IF + ELSE + CALL SB04PX( .TRUE., .FALSE., -1, 2, 2, + $ A( K1, K1 ), LDA, A( L1, L1 ), LDA, + $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) + END IF + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 40 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 40 CONTINUE +C + CALL DSCAL( N, SCALOC, DWORK, 1 ) + CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + IF( K1.NE.L1 ) THEN + C( L1, K1 ) = X( 1, 1 ) + C( L2, K1 ) = X( 1, 2 ) + C( L1, K2 ) = X( 2, 1 ) + C( L2, K2 ) = X( 2, 2 ) + END IF + END IF +C + 50 CONTINUE +C + 60 CONTINUE +C + ELSE +C +C Solve A*X*A' - X = scale*C. +C +C The (K,L)th block of X is determined starting from +C bottom-right corner column by column by +C +C A(K,K)*X(K,L)*A(L,L)' - X(K,L) = C(K,L) - R(K,L), +C +C where +C +C N N +C R(K,L) = SUM {A(K,I)* SUM [X(I,J)*A(L,J)']} + +C I=K J=L+1 +C +C N +C { SUM [A(K,J)*X(J,L)]}*A(L,L)' +C J=K+1 +C +C Start column loop (index = L) +C L1 (L2): column index of the first (last) row of X(K,L) +C + LNEXT = N +C + DO 120 L = N, 1, -1 + IF( L.GT.LNEXT ) + $ GO TO 120 + L1 = L + L2 = L + IF( L.GT.1 ) THEN + IF( A( L, L-1 ).NE.ZERO ) THEN + L1 = L1 - 1 + DWORK( L1 ) = ZERO + DWORK( N+L1 ) = ZERO + END IF + LNEXT = L1 - 1 + END IF + MINL1N = MIN( L1+1, N ) + MINL2N = MIN( L2+1, N ) +C +C Start row loop (index = K) +C K1 (K2): row index of the first (last) row of X(K,L) +C + IF( L2.LT.N ) THEN + CALL DSYMV( 'Upper', N-L2, ONE, C( L2+1, L2+1 ), LDC, + $ A( L1, L2+1 ), LDA, ZERO, DWORK( L2+1 ), 1 ) + CALL DSYMV( 'Upper', N-L2, ONE, C( L2+1, L2+1 ), LDC, + $ A( L2, L2+1 ), LDA, ZERO, DWORK( NP1+L2 ), 1) + END IF +C + KNEXT = L +C + DO 110 K = L, 1, -1 + IF( K.GT.KNEXT ) + $ GO TO 110 + K1 = K + K2 = K + IF( K.GT.1 ) THEN + IF( A( K, K-1 ).NE.ZERO ) + $ K1 = K1 - 1 + KNEXT = K1 - 1 + END IF + MINK1N = MIN( K1+1, N ) + MINK2N = MIN( K2+1, N ) +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + DWORK( K1 ) = DDOT( N-L1, C( K1, MINL1N ), LDC, + $ A( L1, MINL1N ), LDA ) +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( N-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) + $ + DDOT( N-K1, A( K1, MINK1N ), LDA, + $ C( MINK1N, L1 ), 1 )*A( L1, L1 ) ) + SCALOC = ONE +C + A11 = A( K1, K1 )*A( L1, L1 ) - ONE + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 70 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 70 CONTINUE +C + CALL DSCAL( N, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + IF( K1.NE.L1 ) THEN + C( L1, K1 ) = X( 1, 1 ) + END IF +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + DWORK( K1 ) = DDOT( N-L1, C( K1, MINL1N ), LDC, + $ A( L1, MINL1N ), LDA ) + DWORK( K2 ) = DDOT( N-L1, C( K2, MINL1N ), LDC, + $ A( L1, MINL1N ), LDA ) +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) + $ + DDOT( N-K2, A( K1, MINK2N ), LDA, + $ C( MINK2N, L1 ), 1 )*A( L1, L1 ) ) +C + VEC( 2, 1 ) = C( K2, L1 ) - + $ ( DDOT( NP1-K1, A( K2, K1 ), LDA, DWORK( K1 ), 1 ) + $ + DDOT( N-K2, A( K2, MINK2N ), LDA, + $ C( MINK2N, L1 ), 1 )*A( L1, L1 ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, A( L1, L1 ), + $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, ONE, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 80 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 80 CONTINUE +C + CALL DSCAL( N, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) + C( L1, K1 ) = X( 1, 1 ) + C( L1, K2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + DWORK( K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L1, MINL2N ), LDA ) + DWORK( N+K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L2, MINL2N ), LDA ) + P11 = DDOT( N-K1, A( K1, MINK1N ), LDA, + $ C( MINK1N, L1 ), 1 ) + P12 = DDOT( N-K1, A( K1, MINK1N ), LDA, + $ C( MINK1N, L2 ), 1 ) +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) + $ + P11*A( L1, L1 ) + P12*A( L1, L2 ) ) +C + VEC( 2, 1 ) = C( K1, L2 ) - + $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( N+K1 ), 1) + $ + P11*A( L2, L1 ) + P12*A( L2, L2 ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ), + $ A( L1, L1 ), LDA, ONE, ONE, VEC, 2, ONE, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 90 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 90 CONTINUE +C + CALL DSCAL( N, SCALOC, DWORK, 1 ) + CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) + C( L1, K1 ) = X( 1, 1 ) + C( L2, K1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + DWORK( K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L1, MINL2N ), LDA ) + DWORK( K2 ) = DDOT( N-L2, C( K2, MINL2N ), LDC, + $ A( L1, MINL2N ), LDA ) + DWORK( N+K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L2, MINL2N ), LDA ) + DWORK( N+K2 ) = DDOT( N-L2, C( K2, MINL2N ), LDC, + $ A( L2, MINL2N ), LDA ) + P11 = DDOT( N-K2, A( K1, MINK2N ), LDA, + $ C( MINK2N, L1 ), 1 ) + P12 = DDOT( N-K2, A( K1, MINK2N ), LDA, + $ C( MINK2N, L2 ), 1 ) + P21 = DDOT( N-K2, A( K2, MINK2N ), LDA, + $ C( MINK2N, L1 ), 1 ) + P22 = DDOT( N-K2, A( K2, MINK2N ), LDA, + $ C( MINK2N, L2 ), 1 ) +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) + $ + P11*A( L1, L1 ) + P12*A( L1, L2 ) ) +C + VEC( 1, 2 ) = C( K1, L2 ) - + $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( N+K1 ), + $ 1) + P11*A( L2, L1 ) + P12*A( L2, L2 ) ) +C + VEC( 2, 1 ) = C( K2, L1 ) - + $ ( DDOT( NP1-K1, A( K2, K1 ), LDA, DWORK( K1 ), + $ 1) + P21*A( L1, L1 ) + P22*A( L1, L2 ) ) +C + VEC( 2, 2 ) = C( K2, L2 ) - + $ ( DDOT( NP1-K1, A( K2, K1 ), LDA, DWORK( N+K1 ), 1) + $ + P21*A( L2, L1 ) + P22*A( L2, L2 ) ) +C + IF( K1.EQ.L1 ) THEN + CALL SB03MV( .TRUE., LUPPER, A( K1, K1 ), LDA, VEC, + $ 2, SCALOC, X, 2, XNORM, IERR ) + IF( LUPPER ) THEN + X( 2, 1 ) = X( 1, 2 ) + ELSE + X( 1, 2 ) = X( 2, 1 ) + END IF + ELSE + CALL SB04PX( .FALSE., .TRUE., -1, 2, 2, + $ A( K1, K1 ), LDA, A( L1, L1 ), LDA, + $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) + END IF + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 100 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 100 CONTINUE +C + CALL DSCAL( N, SCALOC, DWORK, 1 ) + CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + IF( K1.NE.L1 ) THEN + C( L1, K1 ) = X( 1, 1 ) + C( L2, K1 ) = X( 1, 2 ) + C( L1, K2 ) = X( 2, 1 ) + C( L2, K2 ) = X( 2, 2 ) + END IF + END IF +C + 110 CONTINUE +C + 120 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB03MX *** + END diff --git a/mex/sources/libslicot/SB03MY.f b/mex/sources/libslicot/SB03MY.f new file mode 100644 index 000000000..6aa1642cd --- /dev/null +++ b/mex/sources/libslicot/SB03MY.f @@ -0,0 +1,613 @@ + SUBROUTINE SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the real Lyapunov matrix equation +C +C op(A)'*X + X*op(A) = scale*C +C +C where op(A) = A or A' (A**T), A is upper quasi-triangular and C is +C symmetric (C = C'). (A' denotes the transpose of the matrix A.) +C A is N-by-N, the right hand side C and the solution X are N-by-N, +C and scale is an output scale factor, set less than or equal to 1 +C to avoid overflow in X. The solution matrix X is overwritten +C onto C. +C +C A must be in Schur canonical form (as returned by LAPACK routines +C DGEES or DHSEQR), that is, block upper triangular with 1-by-1 and +C 2-by-2 diagonal blocks; each 2-by-2 diagonal block has its +C diagonal elements equal and its off-diagonal elements of opposite +C sign. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X, and C. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C upper quasi-triangular matrix A, in Schur canonical form. +C The part of A below the first sub-diagonal is not +C referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading N-by-N part of this array must +C contain the symmetric matrix C. +C On exit, if INFO >= 0, the leading N-by-N part of this +C array contains the symmetric solution matrix X. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if A and -A have common or very close eigenvalues; +C perturbed values were used to solve the equation +C (but the matrix A is unchanged). +C +C METHOD +C +C Bartels-Stewart algorithm is used. A set of equivalent linear +C algebraic systems of equations of order at most four are formed +C and solved using Gaussian elimination with complete pivoting. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Supersedes Release 2.0 routine SB03AY by Control Systems Research +C Group, Kingston Polytechnic, United Kingdom, October 1982. +C Based on DTRLYP by P. Petkov, Tech. University of Sofia, September +C 1993. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. +C +C KEYWORDS +C +C Continuous-time system, Lyapunov equation, matrix algebra, real +C Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER TRANA + INTEGER INFO, LDA, LDC, N + DOUBLE PRECISION SCALE +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ) +C .. +C .. Local Scalars .. + LOGICAL NOTRNA, LUPPER + INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT, + $ MINK1N, MINK2N, MINL1N, MINL2N + DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, SCALOC, SMIN, + $ SMLNUM, XNORM +C .. +C .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT, DLAMCH, DLANHS + EXTERNAL DDOT, DLAMCH, DLANHS, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DLABAD, DLALN2, DLASY2, DSCAL, SB03MW, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + NOTRNA = LSAME( TRANA, 'N' ) + LUPPER = .TRUE. +C + INFO = 0 + IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. + $ .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03MY', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM*DBLE( N*N ) / EPS + BIGNUM = ONE / SMLNUM +C + SMIN = MAX( SMLNUM, EPS*DLANHS( 'Max', N, A, LDA, DUM ) ) +C + IF( NOTRNA ) THEN +C +C Solve A'*X + X*A = scale*C. +C +C The (K,L)th block of X is determined starting from +C upper-left corner column by column by +C +C A(K,K)'*X(K,L) + X(K,L)*A(L,L) = C(K,L) - R(K,L), +C +C where +C K-1 L-1 +C R(K,L) = SUM [A(I,K)'*X(I,L)] + SUM [X(K,J)*A(J,L)]. +C I=1 J=1 +C +C Start column loop (index = L). +C L1 (L2): column index of the first (last) row of X(K,L). +C + LNEXT = 1 +C + DO 60 L = 1, N + IF( L.LT.LNEXT ) + $ GO TO 60 + L1 = L + L2 = L + IF( L.LT.N ) THEN + IF( A( L+1, L ).NE.ZERO ) + $ L2 = L2 + 1 + LNEXT = L2 + 1 + END IF +C +C Start row loop (index = K). +C K1 (K2): row index of the first (last) row of X(K,L). +C + KNEXT = L +C + DO 50 K = L, N + IF( K.LT.KNEXT ) + $ GO TO 50 + K1 = K + K2 = K + IF( K.LT.N ) THEN + IF( A( K+1, K ).NE.ZERO ) + $ K2 = K2 + 1 + KNEXT = K2 + 1 + END IF +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) + SCALOC = ONE +C + A11 = A( K1, K1 ) + A( L1, L1 ) + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 10 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 10 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + IF( K1.NE.L1 ) THEN + C( L1, K1 ) = X( 1, 1 ) + END IF +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) +C + VEC( 2, 1 ) = C( K2, L1 ) - + $ ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + + $ DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), 1 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), + $ LDA, ONE, ONE, VEC, 2, -A( L1, L1 ), + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 20 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 20 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) + C( L1, K1 ) = X( 1, 1 ) + C( L1, K2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) +C + VEC( 2, 1 ) = C( K1, L2 ) - + $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L2 ), 1 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( L1, L1 ), + $ LDA, ONE, ONE, VEC, 2, -A( K1, K1 ), + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 30 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 30 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) + C( L1, K1 ) = X( 1, 1 ) + C( L2, K1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) +C + VEC( 1, 2 ) = C( K1, L2 ) - + $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L2 ), 1 ) ) +C + VEC( 2, 1 ) = C( K2, L1 ) - + $ ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + + $ DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), 1 ) ) +C + VEC( 2, 2 ) = C( K2, L2 ) - + $ ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) + + $ DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L2 ), 1 ) ) +C + IF( K1.EQ.L1 ) THEN + CALL SB03MW( .FALSE., LUPPER, A( K1, K1 ), LDA, + $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) + IF( LUPPER ) THEN + X( 2, 1 ) = X( 1, 2 ) + ELSE + X( 1, 2 ) = X( 2, 1 ) + END IF + ELSE + CALL DLASY2( .TRUE., .FALSE., 1, 2, 2, A( K1, K1 ), + $ LDA, A( L1, L1 ), LDA, VEC, 2, SCALOC, + $ X, 2, XNORM, IERR ) + END IF + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 40 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 40 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + IF( K1.NE.L1 ) THEN + C( L1, K1 ) = X( 1, 1 ) + C( L2, K1 ) = X( 1, 2 ) + C( L1, K2 ) = X( 2, 1 ) + C( L2, K2 ) = X( 2, 2 ) + END IF + END IF +C + 50 CONTINUE +C + 60 CONTINUE +C + ELSE +C +C Solve A*X + X*A' = scale*C. +C +C The (K,L)th block of X is determined starting from +C bottom-right corner column by column by +C +C A(K,K)*X(K,L) + X(K,L)*A(L,L)' = C(K,L) - R(K,L), +C +C where +C N N +C R(K,L) = SUM [A(K,I)*X(I,L)] + SUM [X(K,J)*A(L,J)']. +C I=K+1 J=L+1 +C +C Start column loop (index = L). +C L1 (L2): column index of the first (last) row of X(K,L). +C + LNEXT = N +C + DO 120 L = N, 1, -1 + IF( L.GT.LNEXT ) + $ GO TO 120 + L1 = L + L2 = L + IF( L.GT.1 ) THEN + IF( A( L, L-1 ).NE.ZERO ) + $ L1 = L1 - 1 + LNEXT = L1 - 1 + END IF + MINL1N = MIN( L1+1, N ) + MINL2N = MIN( L2+1, N ) +C +C Start row loop (index = K). +C K1 (K2): row index of the first (last) row of X(K,L). +C + KNEXT = L +C + DO 110 K = L, 1, -1 + IF( K.GT.KNEXT ) + $ GO TO 110 + K1 = K + K2 = K + IF( K.GT.1 ) THEN + IF( A( K, K-1 ).NE.ZERO ) + $ K1 = K1 - 1 + KNEXT = K1 - 1 + END IF + MINK1N = MIN( K1+1, N ) + MINK2N = MIN( K2+1, N ) +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( N-K1, A( K1, MINK1N ), LDA, + $ C( MINK1N, L1 ), 1 ) + + $ DDOT( N-L1, C( K1, MINL1N ), LDC, + $ A( L1, MINL1N ), LDA ) ) + SCALOC = ONE +C + A11 = A( K1, K1 ) + A( L1, L1 ) + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 70 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 70 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + IF( K1.NE.L1 ) THEN + C( L1, K1 ) = X( 1, 1 ) + END IF +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( N-K2, A( K1, MINK2N ), LDA, + $ C( MINK2N, L1 ), 1 ) + + $ DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L1, MINL2N ), LDA ) ) +C + VEC( 2, 1 ) = C( K2, L1 ) - + $ ( DDOT( N-K2, A( K2, MINK2N ), LDA, + $ C( MINK2N, L1 ), 1 ) + + $ DDOT( N-L2, C( K2, MINL2N ), LDC, + $ A( L1, MINL2N ), LDA ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), + $ LDA, ONE, ONE, VEC, 2, -A( L1, L1 ), + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 80 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 80 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) + C( L1, K1 ) = X( 1, 1 ) + C( L1, K2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( N-K1, A( K1, MINK1N ), LDA, + $ C( MINK1N, L1 ), 1 ) + + $ DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L1, MINL2N ), LDA ) ) +C + VEC( 2, 1 ) = C( K1, L2 ) - + $ ( DDOT( N-K1, A( K1, MINK1N ), LDA, + $ C( MINK1N, L2 ), 1 ) + + $ DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L2, MINL2N ), LDA ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( L1, L1 ), + $ LDA, ONE, ONE, VEC, 2, -A( K1, K1 ), + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 90 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 90 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) + C( L1, K1 ) = X( 1, 1 ) + C( L2, K1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + VEC( 1, 1 ) = C( K1, L1 ) - + $ ( DDOT( N-K2, A( K1, MINK2N ), LDA, + $ C( MINK2N, L1 ), 1 ) + + $ DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L1, MINL2N ), LDA ) ) +C + VEC( 1, 2 ) = C( K1, L2 ) - + $ ( DDOT( N-K2, A( K1, MINK2N ), LDA, + $ C( MINK2N, L2 ), 1 ) + + $ DDOT( N-L2, C( K1, MINL2N ), LDC, + $ A( L2, MINL2N ), LDA ) ) +C + VEC( 2, 1 ) = C( K2, L1 ) - + $ ( DDOT( N-K2, A( K2, MINK2N ), LDA, + $ C( MINK2N, L1 ), 1 ) + + $ DDOT( N-L2, C( K2, MINL2N ), LDC, + $ A( L1, MINL2N ), LDA ) ) +C + VEC( 2, 2 ) = C( K2, L2 ) - + $ ( DDOT( N-K2, A( K2, MINK2N ), LDA, + $ C( MINK2N, L2 ), 1 ) + + $ DDOT( N-L2, C( K2, MINL2N ), LDC, + $ A( L2, MINL2N ), LDA ) ) +C + IF( K1.EQ.L1 ) THEN + CALL SB03MW( .TRUE., LUPPER, A( K1, K1 ), LDA, VEC, + $ 2, SCALOC, X, 2, XNORM, IERR ) + IF( LUPPER ) THEN + X( 2, 1 ) = X( 1, 2 ) + ELSE + X( 1, 2 ) = X( 2, 1 ) + END IF + ELSE + CALL DLASY2( .FALSE., .TRUE., 1, 2, 2, A( K1, K1 ), + $ LDA, A( L1, L1 ), LDA, VEC, 2, SCALOC, + $ X, 2, XNORM, IERR ) + END IF + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 100 J = 1, N + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 100 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + IF( K1.NE.L1 ) THEN + C( L1, K1 ) = X( 1, 1 ) + C( L2, K1 ) = X( 1, 2 ) + C( L1, K2 ) = X( 2, 1 ) + C( L2, K2 ) = X( 2, 2 ) + END IF + END IF +C + 110 CONTINUE +C + 120 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB03MY *** + END diff --git a/mex/sources/libslicot/SB03OD.f b/mex/sources/libslicot/SB03OD.f new file mode 100644 index 000000000..0b93c7472 --- /dev/null +++ b/mex/sources/libslicot/SB03OD.f @@ -0,0 +1,662 @@ + SUBROUTINE SB03OD( DICO, FACT, TRANS, N, M, A, LDA, Q, LDQ, B, + $ LDB, SCALE, WR, WI, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X = op(U)'*op(U) either the stable non-negative +C definite continuous-time Lyapunov equation +C 2 +C op(A)'*X + X*op(A) = -scale *op(B)'*op(B) (1) +C +C or the convergent non-negative definite discrete-time Lyapunov +C equation +C 2 +C op(A)'*X*op(A) - X = -scale *op(B)'*op(B) (2) +C +C where op(K) = K or K' (i.e., the transpose of the matrix K), A is +C an N-by-N matrix, op(B) is an M-by-N matrix, U is an upper +C triangular matrix containing the Cholesky factor of the solution +C matrix X, X = op(U)'*op(U), and scale is an output scale factor, +C set less than or equal to 1 to avoid overflow in X. If matrix B +C has full rank then the solution matrix X will be positive-definite +C and hence the Cholesky factor U will be nonsingular, but if B is +C rank deficient then X may be only positive semi-definite and U +C will be singular. +C +C In the case of equation (1) the matrix A must be stable (that +C is, all the eigenvalues of A must have negative real parts), +C and for equation (2) the matrix A must be convergent (that is, +C all the eigenvalues of A must lie inside the unit circle). +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of Lyapunov equation to be solved as +C follows: +C = 'C': Equation (1), continuous-time case; +C = 'D': Equation (2), discrete-time case. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, A and Q contain the factors from the +C real Schur factorization of the matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in A and Q. +C +C TRANS CHARACTER*1 +C Specifies the form of op(K) to be used, as follows: +C = 'N': op(K) = K (No transpose); +C = 'T': op(K) = K**T (Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A and the number of columns in +C matrix op(B). N >= 0. +C +C M (input) INTEGER +C The number of rows in matrix op(B). M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. If FACT = 'F', then A contains +C an upper quasi-triangular matrix S in Schur canonical +C form; the elements below the upper Hessenberg part of the +C array A are not referenced. +C On exit, the leading N-by-N upper Hessenberg part of this +C array contains the upper quasi-triangular matrix S in +C Schur canonical form from the Shur factorization of A. +C The contents of array A is not modified if FACT = 'F'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C Q (input or output) DOUBLE PRECISION array, dimension +C (LDQ,N) +C On entry, if FACT = 'F', then the leading N-by-N part of +C this array must contain the orthogonal matrix Q of the +C Schur factorization of A. +C Otherwise, Q need not be set on entry. +C On exit, the leading N-by-N part of this array contains +C the orthogonal matrix Q of the Schur factorization of A. +C The contents of array Q is not modified if FACT = 'F'. +C +C LDQ INTEGER +C The leading dimension of array Q. LDQ >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C if TRANS = 'N', and dimension (LDB,max(M,N)), if +C TRANS = 'T'. +C On entry, if TRANS = 'N', the leading M-by-N part of this +C array must contain the coefficient matrix B of the +C equation. +C On entry, if TRANS = 'T', the leading N-by-M part of this +C array must contain the coefficient matrix B of the +C equation. +C On exit, the leading N-by-N part of this array contains +C the upper triangular Cholesky factor U of the solution +C matrix X of the problem, X = op(U)'*op(U). +C If M = 0 and N > 0, then U is set to zero. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,N,M), if TRANS = 'N'; +C LDB >= MAX(1,N), if TRANS = 'T'. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C If FACT = 'N', and INFO >= 0 and INFO <= 2, WR and WI +C contain the real and imaginary parts, respectively, of +C the eigenvalues of A. +C If FACT = 'F', WR and WI are not referenced. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, or INFO = 1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C If M > 0, LDWORK >= MAX(1,4*N + MIN(M,N)); +C If M = 0, LDWORK >= 1. +C For optimum performance LDWORK should sometimes be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the Lyapunov equation is (nearly) singular +C (warning indicator); +C if DICO = 'C' this means that while the matrix A +C (or the factor S) has computed eigenvalues with +C negative real parts, it is only just stable in the +C sense that small perturbations in A can make one or +C more of the eigenvalues have a non-negative real +C part; +C if DICO = 'D' this means that while the matrix A +C (or the factor S) has computed eigenvalues inside +C the unit circle, it is nevertheless only just +C convergent, in the sense that small perturbations +C in A can make one or more of the eigenvalues lie +C outside the unit circle; +C perturbed values were used to solve the equation; +C = 2: if FACT = 'N' and DICO = 'C', but the matrix A is +C not stable (that is, one or more of the eigenvalues +C of A has a non-negative real part), or DICO = 'D', +C but the matrix A is not convergent (that is, one or +C more of the eigenvalues of A lies outside the unit +C circle); however, A will still have been factored +C and the eigenvalues of A returned in WR and WI. +C = 3: if FACT = 'F' and DICO = 'C', but the Schur factor S +C supplied in the array A is not stable (that is, one +C or more of the eigenvalues of S has a non-negative +C real part), or DICO = 'D', but the Schur factor S +C supplied in the array A is not convergent (that is, +C one or more of the eigenvalues of S lies outside the +C unit circle); +C = 4: if FACT = 'F' and the Schur factor S supplied in +C the array A has two or more consecutive non-zero +C elements on the first sub-diagonal, so that there is +C a block larger than 2-by-2 on the diagonal; +C = 5: if FACT = 'F' and the Schur factor S supplied in +C the array A has a 2-by-2 diagonal block with real +C eigenvalues instead of a complex conjugate pair; +C = 6: if FACT = 'N' and the LAPACK Library routine DGEES +C has failed to converge. This failure is not likely +C to occur. The matrix B will be unaltered but A will +C be destroyed. +C +C METHOD +C +C The method used by the routine is based on the Bartels and Stewart +C method [1], except that it finds the upper triangular matrix U +C directly without first finding X and without the need to form the +C normal matrix op(B)'*op(B). +C +C The Schur factorization of a square matrix A is given by +C +C A = QSQ', +C +C where Q is orthogonal and S is an N-by-N block upper triangular +C matrix with 1-by-1 and 2-by-2 blocks on its diagonal (which +C correspond to the eigenvalues of A). If A has already been +C factored prior to calling the routine however, then the factors +C Q and S may be supplied and the initial factorization omitted. +C +C If TRANS = 'N', the matrix B is factored as (QR factorization) +C _ _ _ _ _ +C B = P ( R ), M >= N, B = P ( R Z ), M < N, +C ( 0 ) +C _ _ +C where P is an M-by-M orthogonal matrix and R is a square upper +C _ _ _ _ _ +C triangular matrix. Then, the matrix B = RQ, or B = ( R Z )Q (if +C M < N) is factored as +C _ _ +C B = P ( R ), M >= N, B = P ( R Z ), M < N. +C +C If TRANS = 'T', the matrix B is factored as (RQ factorization) +C _ +C _ _ ( Z ) _ +C B = ( 0 R ) P, M >= N, B = ( _ ) P, M < N, +C ( R ) +C _ _ +C where P is an M-by-M orthogonal matrix and R is a square upper +C _ _ _ _ _ +C triangular matrix. Then, the matrix B = Q'R, or B = Q'( Z' R' )' +C (if M < N) is factored as +C _ _ +C B = ( R ) P, M >= N, B = ( Z ) P, M < N. +C ( R ) +C +C These factorizations are utilised to either transform the +C continuous-time Lyapunov equation to the canonical form +C 2 +C op(S)'*op(V)'*op(V) + op(V)'*op(V)*op(S) = -scale *op(F)'*op(F), +C +C or the discrete-time Lyapunov equation to the canonical form +C 2 +C op(S)'*op(V)'*op(V)*op(S) - op(V)'*op(V) = -scale *op(F)'*op(F), +C +C where V and F are upper triangular, and +C +C F = R, M >= N, F = ( R Z ), M < N, if TRANS = 'N'; +C ( 0 0 ) +C +C F = R, M >= N, F = ( 0 Z ), M < N, if TRANS = 'T'. +C ( 0 R ) +C +C The transformed equation is then solved for V, from which U is +C obtained via the QR factorization of V*Q', if TRANS = 'N', or +C via the RQ factorization of Q*V, if TRANS = 'T'. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. +C Solution of the matrix equation A'X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-325, 1982. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C The Lyapunov equation may be very ill-conditioned. In particular, +C if A is only just stable (or convergent) then the Lyapunov +C equation will be ill-conditioned. A symptom of ill-conditioning +C is "large" elements in U relative to those of A and B, or a +C "small" value for scale. A condition estimate can be computed +C using SLICOT Library routine SB03MD. +C +C SB03OD routine can be also used for solving "unstable" Lyapunov +C equations, i.e., when matrix A has all eigenvalues with positive +C real parts, if DICO = 'C', or with moduli greater than one, +C if DICO = 'D'. Specifically, one may solve for X = op(U)'*op(U) +C either the continuous-time Lyapunov equation +C 2 +C op(A)'*X + X*op(A) = scale *op(B)'*op(B), (3) +C +C or the discrete-time Lyapunov equation +C 2 +C op(A)'*X*op(A) - X = scale *op(B)'*op(B), (4) +C +C provided, for equation (3), the given matrix A is replaced by -A, +C or, for equation (4), the given matrices A and B are replaced by +C inv(A) and B*inv(A), if TRANS = 'N' (or inv(A)*B, if TRANS = 'T'), +C respectively. Although the inversion generally can rise numerical +C problems, in case of equation (4) it is expected that the matrix A +C is enough well-conditioned, having only eigenvalues with moduli +C greater than 1. However, if A is ill-conditioned, it could be +C preferable to use the more general SLICOT Lyapunov solver SB03MD. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB03CD by Sven Hammarling, +C NAG Ltd, United Kingdom. +C +C REVISIONS +C +C Dec. 1997, April 1998, May 1998, May 1999, Oct. 2001 (V. Sima). +C March 2002 (A. Varga). +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, FACT, TRANS + INTEGER INFO, LDA, LDB, LDQ, LDWORK, M, N + DOUBLE PRECISION SCALE +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), Q(LDQ,*), WI(*), + $ WR(*) +C .. Local Scalars .. + LOGICAL CONT, LTRANS, NOFACT + INTEGER I, IFAIL, INFORM, ITAU, J, JWORK, K, L, MINMN, + $ NE, SDIM, WRKOPT + DOUBLE PRECISION EMAX, TEMP +C .. Local Arrays .. + LOGICAL BWORK(1) +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2, LSAME, SELECT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DGEQRF, DGERQF, + $ DLACPY, DLASET, DTRMM, SB03OU, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + CONT = LSAME( DICO, 'C' ) + NOFACT = LSAME( FACT, 'N' ) + LTRANS = LSAME( TRANS, 'T' ) + MINMN = MIN( M, N ) +C + INFO = 0 + IF( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LTRANS .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( ( LDB.LT.MAX( 1, N ) ) .OR. + $ ( LDB.LT.MAX( 1, N, M ) .AND. .NOT.LTRANS ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.1 .OR. ( M.GT.0 .AND. LDWORK.LT.4*N + MINMN ) ) + $ THEN + INFO = -16 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB03OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MINMN.EQ.0 ) THEN + IF( M.EQ.0 ) + $ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDB ) + SCALE = ONE + DWORK(1) = ONE + RETURN + END IF +C +C Start the solution. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF ( NOFACT ) THEN +C +C Find the Schur factorization of A, A = Q*S*Q'. +C Workspace: need 3*N; +C prefer larger. +C + CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, + $ WR, WI, Q, LDQ, DWORK, LDWORK, BWORK, INFORM ) + IF ( INFORM.NE.0 ) THEN + INFO = 6 + RETURN + END IF + WRKOPT = DWORK(1) +C +C Check the eigenvalues for stability. +C + IF ( CONT ) THEN + EMAX = WR(1) +C + DO 20 J = 2, N + IF ( WR(J).GT.EMAX ) + $ EMAX = WR(J) + 20 CONTINUE +C + ELSE + EMAX = DLAPY2( WR(1), WI(1) ) +C + DO 40 J = 2, N + TEMP = DLAPY2( WR(J), WI(J) ) + IF ( TEMP.GT.EMAX ) + $ EMAX = TEMP + 40 CONTINUE +C + END IF +C + IF ( ( CONT ) .AND. ( EMAX.GE.ZERO ) .OR. + $ ( .NOT.CONT ) .AND. ( EMAX.GE.ONE ) ) THEN + INFO = 2 + RETURN + END IF + ELSE + WRKOPT = 0 + END IF +C +C Perform the QR or RQ factorization of B, +C _ _ _ _ _ +C B = P ( R ), or B = P ( R Z ), if TRANS = 'N', or +C ( 0 ) +C _ +C _ _ ( Z ) _ +C B = ( 0 R ) P, or B = ( _ ) P, if TRANS = 'T'. +C ( R ) +C Workspace: need MIN(M,N) + N; +C prefer MIN(M,N) + N*NB. +C + ITAU = 1 + JWORK = ITAU + MINMN + IF ( LTRANS ) THEN + CALL DGERQF( N, M, B, LDB, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1, MINMN*N) + JWORK = ITAU +C +C Form in B +C _ _ _ _ _ _ +C B := Q'R, m >= n, B := Q'*( Z' R' )', m < n, with B an +C n-by-min(m,n) matrix. +C Use a BLAS 3 operation if enough workspace, and BLAS 2, +C _ +C otherwise: B is formed column by column. +C + IF ( LDWORK.GE.JWORK+MINMN*N-1 ) THEN + K = JWORK +C + DO 60 I = 1, MINMN + CALL DCOPY( N, Q(N-MINMN+I,1), LDQ, DWORK(K), 1 ) + K = K + N + 60 CONTINUE +C + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Non-unit', + $ N, MINMN, ONE, B(N-MINMN+1,M-MINMN+1), LDB, + $ DWORK(JWORK), N ) + IF ( M.LT.N ) + $ CALL DGEMM( 'Transpose', 'No transpose', N, M, N-M, + $ ONE, Q, LDQ, B, LDB, ONE, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, MINMN, DWORK(JWORK), N, B, LDB ) + ELSE + NE = N - MINMN +C + DO 80 J = 1, MINMN + NE = NE + 1 + CALL DCOPY( NE, B(1,M-MINMN+J), 1, DWORK(JWORK), 1 ) + CALL DGEMV( 'Transpose', NE, N, ONE, Q, LDQ, + $ DWORK(JWORK), 1, ZERO, B(1,J), 1 ) + 80 CONTINUE +C + END IF + ELSE + CALL DGEQRF( M, N, B, LDB, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1, MINMN*N) + JWORK = ITAU +C +C Form in B +C _ _ _ _ _ _ +C B := RQ, m >= n, B := ( R Z )*Q, m < n, with B an +C min(m,n)-by-n matrix. +C Use a BLAS 3 operation if enough workspace, and BLAS 2, +C _ +C otherwise: B is formed row by row. +C + IF ( LDWORK.GE.JWORK+MINMN*N-1 ) THEN + CALL DLACPY( 'Full', MINMN, N, Q, LDQ, DWORK(JWORK), MINMN ) + CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', + $ MINMN, N, ONE, B, LDB, DWORK(JWORK), MINMN ) + IF ( M.LT.N ) + $ CALL DGEMM( 'No transpose', 'No transpose', M, N, N-M, + $ ONE, B(1,M+1), LDB, Q(M+1,1), LDQ, ONE, + $ DWORK(JWORK), MINMN ) + CALL DLACPY( 'Full', MINMN, N, DWORK(JWORK), MINMN, B, LDB ) + ELSE + NE = MINMN + MAX( 0, N-M ) +C + DO 100 J = 1, MINMN + CALL DCOPY( NE, B(J,J), LDB, DWORK(JWORK), 1 ) + CALL DGEMV( 'Transpose', NE, N, ONE, Q(J,1), LDQ, + $ DWORK(JWORK), 1, ZERO, B(J,1), LDB ) + NE = NE - 1 + 100 CONTINUE +C + END IF + END IF + JWORK = ITAU + MINMN +C +C Solve for U the transformed Lyapunov equation +C 2 _ _ +C op(S)'*op(U)'*op(U) + op(U)'*op(U)*op(S) = -scale *op(B)'*op(B), +C +C or +C 2 _ _ +C op(S)'*op(U)'*op(U)*op(S) - op(U)'*op(U) = -scale *op(B)'*op(B) +C +C Workspace: need MIN(M,N) + 4*N; +C prefer larger. +C + CALL SB03OU( .NOT.CONT, LTRANS, N, MINMN, A, LDA, B, LDB, + $ DWORK(ITAU), B, LDB, SCALE, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + IF ( INFO.GT.1 ) THEN + INFO = INFO + 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + JWORK = ITAU +C +C Form U := U*Q' or U := Q*U in the array B. +C Use a BLAS 3 operation if enough workspace, and BLAS 2, otherwise. +C Workspace: need N; +C prefer N*N; +C + IF ( LDWORK.GE.JWORK+N*N-1 ) THEN + IF ( LTRANS ) THEN + CALL DLACPY( 'Full', N, N, Q, LDQ, DWORK(JWORK), N ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, + $ N, ONE, B, LDB, DWORK(JWORK), N ) + ELSE + K = JWORK +C + DO 120 I = 1, N + CALL DCOPY( N, Q(1,I), 1, DWORK(K), N ) + K = K + 1 + 120 CONTINUE +C + CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, + $ N, ONE, B, LDB, DWORK(JWORK), N ) + END IF + CALL DLACPY( 'Full', N, N, DWORK(JWORK), N, B, LDB ) + WRKOPT = MAX( WRKOPT, JWORK + N*N - 1 ) + ELSE + IF ( LTRANS ) THEN +C +C U is formed column by column ( U := Q*U ). +C + DO 140 I = 1, N + CALL DCOPY( I, B(1,I), 1, DWORK(JWORK), 1 ) + CALL DGEMV( 'No transpose', N, I, ONE, Q, LDQ, + $ DWORK(JWORK), 1, ZERO, B(1,I), 1 ) + 140 CONTINUE + ELSE +C +C U is formed row by row ( U' := Q*U' ). +C + DO 160 I = 1, N + CALL DCOPY( N-I+1, B(I,I), LDB, DWORK(JWORK), 1 ) + CALL DGEMV( 'No transpose', N, N-I+1, ONE, Q(1,I), LDQ, + $ DWORK(JWORK), 1, ZERO, B(I,1), LDB ) + 160 CONTINUE + END IF + END IF +C +C Lastly find the QR or RQ factorization of U, overwriting on B, +C to give the required Cholesky factor. +C Workspace: need 2*N; +C prefer N + N*NB; +C + JWORK = ITAU + N + IF ( LTRANS ) THEN + CALL DGERQF( N, N, B, LDB, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + ELSE + CALL DGEQRF( N, N, B, LDB, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Make the diagonal elements of U non-negative. +C + IF ( LTRANS ) THEN +C + DO 200 J = 1, N + IF ( B(J,J).LT.ZERO ) THEN +C + DO 180 I = 1, J + B(I,J) = -B(I,J) + 180 CONTINUE +C + END IF + 200 CONTINUE +C + ELSE + K = JWORK +C + DO 240 J = 1, N + DWORK(K) = B(J,J) + L = JWORK +C + DO 220 I = 1, J + IF ( DWORK(L).LT.ZERO ) B(I,J) = -B(I,J) + L = L + 1 + 220 CONTINUE +C + K = K + 1 + 240 CONTINUE + END IF +C + IF( N.GT.1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB ) +C +C Set the optimal workspace. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB03OD *** + END diff --git a/mex/sources/libslicot/SB03OR.f b/mex/sources/libslicot/SB03OR.f new file mode 100644 index 000000000..1094f26f5 --- /dev/null +++ b/mex/sources/libslicot/SB03OR.f @@ -0,0 +1,429 @@ + SUBROUTINE SB03OR( DISCR, LTRANS, N, M, S, LDS, A, LDA, C, LDC, + $ SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the solution of the Sylvester equations +C +C op(S)'*X + X*op(A) = scale*C, if DISCR = .FALSE. or +C +C op(S)'*X*op(A) - X = scale*C, if DISCR = .TRUE. +C +C where op(K) = K or K' (i.e., the transpose of the matrix K), S is +C an N-by-N block upper triangular matrix with one-by-one and +C two-by-two blocks on the diagonal, A is an M-by-M matrix (M = 1 or +C M = 2), X and C are each N-by-M matrices, and scale is an output +C scale factor, set less than or equal to 1 to avoid overflow in X. +C The solution X is overwritten on C. +C +C SB03OR is a service routine for the Lyapunov solver SB03OT. +C +C ARGUMENTS +C +C Mode Parameters +C +C DISCR LOGICAL +C Specifies the equation to be solved: +C = .FALSE.: op(S)'*X + X*op(A) = scale*C; +C = .TRUE. : op(S)'*X*op(A) - X = scale*C. +C +C LTRANS LOGICAL +C Specifies the form of op(K) to be used, as follows: +C = .FALSE.: op(K) = K (No transpose); +C = .TRUE. : op(K) = K**T (Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix S and also the number of rows of +C matrices X and C. N >= 0. +C +C M (input) INTEGER +C The order of the matrix A and also the number of columns +C of matrices X and C. M = 1 or M = 2. +C +C S (input) DOUBLE PRECISION array, dimension (LDS,N) +C The leading N-by-N upper Hessenberg part of the array S +C must contain the block upper triangular matrix. The +C elements below the upper Hessenberg part of the array S +C are not referenced. The array S must not contain +C diagonal blocks larger than two-by-two and the two-by-two +C blocks must only correspond to complex conjugate pairs of +C eigenvalues, not to real eigenvalues. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,N). +C +C A (input) DOUBLE PRECISION array, dimension (LDS,M) +C The leading M-by-M part of this array must contain a +C given matrix, where M = 1 or M = 2. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= M. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, C must contain an N-by-M matrix, where M = 1 or +C M = 2. +C On exit, C contains the N-by-M matrix X, the solution of +C the Sylvester equation. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if DISCR = .FALSE., and S and -A have common +C eigenvalues, or if DISCR = .TRUE., and S and A have +C eigenvalues whose product is equal to unity; +C a solution has been computed using slightly +C perturbed values. +C +C METHOD +C +C The LAPACK scheme for solving Sylvester equations is adapted. +C +C REFERENCES +C +C [1] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-325, 1982. +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0(N M) operations and is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Supersedes Release 2.0 routines SB03CW and SB03CX by +C Sven Hammarling, NAG Ltd, United Kingdom, Oct. 1986. +C Partly based on routine PLYAP4 by A. Varga, University of Bochum, +C May 1992. +C +C REVISIONS +C +C December 1997, April 1998, May 1999, April 2000. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + LOGICAL DISCR, LTRANS + INTEGER INFO, LDA, LDS, LDC, M, N + DOUBLE PRECISION SCALE +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), S( LDS, * ) +C .. Local Scalars .. + LOGICAL TBYT + INTEGER DL, INFOM, ISGN, J, L, L1, L2, L2P1, LNEXT + DOUBLE PRECISION G11, G12, G21, G22, SCALOC, XNORM +C .. +C .. Local Arrays .. + DOUBLE PRECISION AT( 2, 2 ), VEC( 2, 2 ), X( 2, 2 ) +C .. +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. +C .. External Subroutines .. + EXTERNAL DLASY2, DSCAL, SB04PX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( .NOT.( M.EQ.1 .OR. M.EQ.2 ) ) THEN + INFO = -4 + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.M ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB03OR', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + ISGN = 1 + TBYT = M.EQ.2 + INFOM = 0 +C +C Construct A'. +C + AT(1,1) = A(1,1) + IF ( TBYT ) THEN + AT(1,2) = A(2,1) + AT(2,1) = A(1,2) + AT(2,2) = A(2,2) + END IF +C + IF ( LTRANS ) THEN +C +C Start row loop (index = L). +C L1 (L2) : row index of the first (last) row of X(L). +C + LNEXT = N +C + DO 20 L = N, 1, -1 + IF( L.GT.LNEXT ) + $ GO TO 20 + L1 = L + L2 = L + IF( L.GT.1 ) THEN + IF( S( L, L-1 ).NE.ZERO ) + $ L1 = L1 - 1 + LNEXT = L1 - 1 + END IF + DL = L2 - L1 + 1 + L2P1 = MIN( L2+1, N ) +C + IF ( DISCR ) THEN +C +C Solve S*X*A' - X = scale*C. +C +C The L-th block of X is determined from +C +C S(L,L)*X(L)*A' - X(L) = C(L) - R(L), +C +C where +C +C N +C R(L) = SUM [S(L,J)*X(J)] * A' . +C J=L+1 +C + G11 = -DDOT( N-L2, S( L1, L2P1 ), LDS, C( L2P1, 1 ), 1 ) + IF ( TBYT ) THEN + G12 = -DDOT( N-L2, S( L1, L2P1 ), LDS, C( L2P1, 2 ), + $ 1 ) + VEC( 1, 1 ) = C( L1, 1 ) + G11*AT(1,1) + G12*AT(2,1) + VEC( 1, 2 ) = C( L1, 2 ) + G11*AT(1,2) + G12*AT(2,2) + ELSE + VEC (1, 1 ) = C( L1, 1 ) + G11*AT(1,1) + END IF + IF ( DL.NE.1 ) THEN + G21 = -DDOT( N-L2, S( L2, L2P1 ), LDS, C( L2P1, 1 ), + $ 1 ) + IF ( TBYT ) THEN + G22 = -DDOT( N-L2, S( L2, L2P1 ), LDS, + $ C( L2P1, 2 ), 1 ) + VEC( 2, 1 ) = C( L2, 1 ) + G21*AT(1,1) + + $ G22*AT(2,1) + VEC( 2, 2 ) = C( L2, 2 ) + G21*AT(1,2) + + $ G22*AT(2,2) + ELSE + VEC( 2, 1 ) = C( L2, 1 ) + G21*AT(1,1) + END IF + END IF + CALL SB04PX( .FALSE., .FALSE., -ISGN, DL, M, S( L1, L1 ), + $ LDS, AT, 2, VEC, 2, SCALOC, X, 2, XNORM, + $ INFO ) + ELSE +C +C Solve S*X + X*A' = scale*C. +C +C The L-th block of X is determined from +C +C S(L,L)*X(L) + X(L)*A' = C(L) - R(L), +C +C where +C N +C R(L) = SUM S(L,J)*X(J) . +C J=L+1 +C + VEC( 1, 1 ) = C( L1, 1 ) - + $ DDOT( N-L2, S( L1, L2P1 ), LDS, + $ C( L2P1, 1 ), 1 ) + IF ( TBYT ) + $ VEC( 1, 2 ) = C( L1, 2 ) - + $ DDOT( N-L2, S( L1, L2P1 ), LDS, + $ C( L2P1, 2 ), 1 ) +C + IF ( DL.NE.1 ) THEN + VEC( 2, 1 ) = C( L2, 1 ) - + $ DDOT( N-L2, S( L2, L2P1 ), LDS, + $ C( L2P1, 1 ), 1 ) + IF ( TBYT ) + $ VEC( 2, 2 ) = C( L2, 2 ) - + $ DDOT( N-L2, S( L2, L2P1 ), LDS, + $ C( L2P1, 2 ), 1 ) + END IF + CALL DLASY2( .FALSE., .FALSE., ISGN, DL, M, S( L1, L1 ), + $ LDS, AT, 2, VEC, 2, SCALOC, X, 2, XNORM, + $ INFO ) + END IF + INFOM = MAX( INFO, INFOM ) + IF ( SCALOC.NE.ONE ) THEN +C + DO 10 J = 1, M + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 10 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( L1, 1 ) = X( 1, 1 ) + IF ( TBYT ) C( L1, 2 ) = X( 1, 2 ) + IF ( DL.NE.1 ) THEN + C( L2, 1 ) = X( 2, 1 ) + IF ( TBYT ) C( L2, 2 ) = X( 2, 2 ) + END IF + 20 CONTINUE +C + ELSE +C +C Start row loop (index = L). +C L1 (L2) : row index of the first (last) row of X(L). +C + LNEXT = 1 +C + DO 40 L = 1, N + IF( L.LT.LNEXT ) + $ GO TO 40 + L1 = L + L2 = L + IF( L.LT.N ) THEN + IF( S( L+1, L ).NE.ZERO ) + $ L2 = L2 + 1 + LNEXT = L2 + 1 + END IF + DL = L2 - L1 + 1 +C + IF ( DISCR ) THEN +C +C Solve A'*X'*S - X' = scale*C'. +C +C The L-th block of X is determined from +C +C A'*X(L)'*S(L,L) - X(L)' = C(L)' - R(L), +C +C where +C +C L-1 +C R(L) = A' * SUM [X(J)'*S(J,L)] . +C J=1 +C + G11 = -DDOT( L1-1, C, 1, S( 1, L1 ), 1 ) + IF ( TBYT ) THEN + G21 = -DDOT( L1-1, C( 1, 2 ), 1, S( 1, L1 ), 1 ) + VEC( 1, 1 ) = C( L1, 1 ) + AT(1,1)*G11 + AT(1,2)*G21 + VEC( 2, 1 ) = C( L1, 2 ) + AT(2,1)*G11 + AT(2,2)*G21 + ELSE + VEC (1, 1 ) = C( L1, 1 ) + AT(1,1)*G11 + END IF + IF ( DL .NE. 1 ) THEN + G12 = -DDOT( L1-1, C, 1, S( 1, L2 ), 1 ) + IF ( TBYT ) THEN + G22 = -DDOT( L1-1, C( 1, 2 ), 1, S( 1, L2 ), 1 ) + VEC( 1, 2 ) = C( L2, 1 ) + AT(1,1)*G12 + + $ AT(1,2)*G22 + VEC( 2, 2 ) = C( L2, 2 ) + AT(2,1)*G12 + + $ AT(2,2)*G22 + ELSE + VEC( 1, 2 ) = C( L2, 1 ) + AT(1,1)*G12 + END IF + END IF + CALL SB04PX( .FALSE., .FALSE., -ISGN, M, DL, AT, 2, + $ S( L1, L1 ), LDS, VEC, 2, SCALOC, X, 2, + $ XNORM, INFO ) + ELSE +C +C Solve A'*X' + X'*S = scale*C'. +C +C The L-th block of X is determined from +C +C A'*X(L)' + X(L)'*S(L,L) = C(L)' - R(L), +C +C where +C L-1 +C R(L) = SUM [X(J)'*S(J,L)]. +C J=1 +C + VEC( 1, 1 ) = C( L1, 1 ) - + $ DDOT( L1-1, C, 1, S( 1, L1 ), 1 ) + IF ( TBYT ) + $ VEC( 2, 1 ) = C( L1, 2 ) - + $ DDOT( L1-1, C( 1, 2 ), 1, S( 1, L1 ), 1) +C + IF ( DL.NE.1 ) THEN + VEC( 1, 2 ) = C( L2, 1 ) - + $ DDOT( L1-1, C, 1, S( 1, L2 ), 1 ) + IF ( TBYT ) + $ VEC( 2, 2 ) = C( L2, 2 ) - + $ DDOT( L1-1, C( 1, 2 ), 1, S( 1, L2 ), 1) + END IF + CALL DLASY2( .FALSE., .FALSE., ISGN, M, DL, AT, 2, + $ S( L1, L1 ), LDS, VEC, 2, SCALOC, X, 2, + $ XNORM, INFO ) + END IF + INFOM = MAX( INFO, INFOM ) + IF ( SCALOC.NE.ONE ) THEN +C + DO 30 J = 1, M + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 30 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( L1, 1 ) = X( 1, 1 ) + IF ( TBYT ) C( L1, 2 ) = X( 2, 1 ) + IF ( DL.NE.1 ) THEN + C( L2, 1 ) = X( 1, 2 ) + IF ( TBYT ) C( L2, 2 ) = X( 2, 2 ) + END IF + 40 CONTINUE + END IF +C + INFO = INFOM + RETURN +C *** Last line of SB03OR *** + END diff --git a/mex/sources/libslicot/SB03OT.f b/mex/sources/libslicot/SB03OT.f new file mode 100644 index 000000000..92550bf56 --- /dev/null +++ b/mex/sources/libslicot/SB03OT.f @@ -0,0 +1,984 @@ + SUBROUTINE SB03OT( DISCR, LTRANS, N, S, LDS, R, LDR, SCALE, DWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X = op(U)'*op(U) either the stable non-negative +C definite continuous-time Lyapunov equation +C 2 +C op(S)'*X + X*op(S) = -scale *op(R)'*op(R) (1) +C +C or the convergent non-negative definite discrete-time Lyapunov +C equation +C 2 +C op(S)'*X*op(S) - X = -scale *op(R)'*op(R) (2) +C +C where op(K) = K or K' (i.e., the transpose of the matrix K), S is +C an N-by-N block upper triangular matrix with one-by-one or +C two-by-two blocks on the diagonal, R is an N-by-N upper triangular +C matrix, and scale is an output scale factor, set less than or +C equal to 1 to avoid overflow in X. +C +C In the case of equation (1) the matrix S must be stable (that +C is, all the eigenvalues of S must have negative real parts), +C and for equation (2) the matrix S must be convergent (that is, +C all the eigenvalues of S must lie inside the unit circle). +C +C ARGUMENTS +C +C Mode Parameters +C +C DISCR LOGICAL +C Specifies the type of Lyapunov equation to be solved as +C follows: +C = .TRUE. : Equation (2), discrete-time case; +C = .FALSE.: Equation (1), continuous-time case. +C +C LTRANS LOGICAL +C Specifies the form of op(K) to be used, as follows: +C = .FALSE.: op(K) = K (No transpose); +C = .TRUE. : op(K) = K**T (Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices S and R. N >= 0. +C +C S (input) DOUBLE PRECISION array of dimension (LDS,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain the block upper triangular matrix. +C The elements below the upper Hessenberg part of the array +C S are not referenced. The 2-by-2 blocks must only +C correspond to complex conjugate pairs of eigenvalues (not +C to real eigenvalues). +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,N). +C +C R (input/output) DOUBLE PRECISION array of dimension (LDR,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix R. +C On exit, the leading N-by-N upper triangular part of this +C array contains the upper triangular matrix U. +C The strict lower triangle of R is not referenced. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (4*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the Lyapunov equation is (nearly) singular +C (warning indicator); +C if DISCR = .FALSE., this means that while the +C matrix S has computed eigenvalues with negative real +C parts, it is only just stable in the sense that +C small perturbations in S can make one or more of the +C eigenvalues have a non-negative real part; +C if DISCR = .TRUE., this means that while the +C matrix S has computed eigenvalues inside the unit +C circle, it is nevertheless only just convergent, in +C the sense that small perturbations in S can make one +C or more of the eigenvalues lie outside the unit +C circle; +C perturbed values were used to solve the equation +C (but the matrix S is unchanged); +C = 2: if the matrix S is not stable (that is, one or more +C of the eigenvalues of S has a non-negative real +C part), if DISCR = .FALSE., or not convergent (that +C is, one or more of the eigenvalues of S lies outside +C the unit circle), if DISCR = .TRUE.; +C = 3: if the matrix S has two or more consecutive non-zero +C elements on the first sub-diagonal, so that there is +C a block larger than 2-by-2 on the diagonal; +C = 4: if the matrix S has a 2-by-2 diagonal block with +C real eigenvalues instead of a complex conjugate +C pair. +C +C METHOD +C +C The method used by the routine is based on a variant of the +C Bartels and Stewart backward substitution method [1], that finds +C the Cholesky factor op(U) directly without first finding X and +C without the need to form the normal matrix op(R)'*op(R) [2]. +C +C The continuous-time Lyapunov equation in the canonical form +C 2 +C op(S)'*op(U)'*op(U) + op(U)'*op(U)*op(S) = -scale *op(R)'*op(R), +C +C or the discrete-time Lyapunov equation in the canonical form +C 2 +C op(S)'*op(U)'*op(U)*op(S) - op(U)'*op(U) = -scale *op(R)'*op(R), +C +C where U and R are upper triangular, is solved for U. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. +C Solution of the matrix equation A'X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-325, 1982. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C The Lyapunov equation may be very ill-conditioned. In particular +C if S is only just stable (or convergent) then the Lyapunov +C equation will be ill-conditioned. "Large" elements in U relative +C to those of S and R, or a "small" value for scale, is a symptom +C of ill-conditioning. A condition estimate can be computed using +C SLICOT Library routine SB03MD. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Supersedes Release 2.0 routine SB03CZ by Sven Hammarling, +C NAG Ltd, United Kingdom, Oct. 1986. +C Partly based on SB03CZ and PLYAP1 by A. Varga, University of +C Bochum, May 1992. +C +C REVISIONS +C +C Dec. 1997, April 1998, May 1999, Feb. 2004. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + LOGICAL DISCR, LTRANS + INTEGER INFO, LDR, LDS, N + DOUBLE PRECISION SCALE +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), R(LDR,*), S(LDS,*) +C .. Local Scalars .. + LOGICAL CONT, TBYT + INTEGER INFOM, ISGN, J, J1, J2, J3, K, K1, K2, K3, + $ KOUNT, KSIZE + DOUBLE PRECISION ABSSKK, ALPHA, BIGNUM, D1, D2, DR, EPS, SCALOC, + $ SMIN, SMLNUM, SUM, T1, T2, T3, T4, TAU1, TAU2, + $ TEMP, V1, V2, V3, V4 +C .. Local Arrays .. + DOUBLE PRECISION A(2,2), B(2,2), U(2,2) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANHS + EXTERNAL DLAMCH, DLANHS +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DLABAD, DLARFG, DSCAL, DSWAP, + $ DTRMM, DTRMV, MB04ND, MB04OD, SB03OR, SB03OY, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDR.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB03OT', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF (N.EQ.0) + $ RETURN +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM*DBLE( N*N ) / EPS + BIGNUM = ONE / SMLNUM +C + SMIN = MAX( SMLNUM, EPS*DLANHS( 'Max', N, S, LDS, DWORK ) ) + INFOM = 0 +C +C Start the solution. Most of the comments refer to notation and +C equations in sections 5 and 10 of the second reference above. +C +C Determine whether or not the current block is two-by-two. +C K gives the position of the start of the current block and +C TBYT is true if the block is two-by-two. +C + CONT = .NOT.DISCR + ISGN = 1 + IF ( .NOT.LTRANS ) THEN +C +C Case op(M) = M. +C + KOUNT = 1 +C + 10 CONTINUE +C WHILE( KOUNT.LE.N )LOOP + IF ( KOUNT.LE.N ) THEN + K = KOUNT + IF ( KOUNT.GE.N ) THEN + TBYT = .FALSE. + KOUNT = KOUNT + 1 + ELSE IF ( S(K+1,K).EQ.ZERO ) THEN + TBYT = .FALSE. + KOUNT = KOUNT + 1 + ELSE + TBYT = .TRUE. + IF ( (K+1).LT.N ) THEN + IF ( S(K+2,K+1).NE.ZERO ) THEN + INFO = 3 + RETURN + END IF + END IF + KOUNT = KOUNT + 2 + END IF + IF ( TBYT ) THEN +C +C Solve the two-by-two Lyapunov equation (6.1) or (10.19), +C using the routine SB03OY. +C + B(1,1) = S(K,K) + B(2,1) = S(K+1,K) + B(1,2) = S(K,K+1) + B(2,2) = S(K+1,K+1) + U(1,1) = R(K,K) + U(1,2) = R(K,K+1) + U(2,2) = R(K+1,K+1) +C + CALL SB03OY( DISCR, LTRANS, ISGN, B, 2, U, 2, A, 2, + $ SCALOC, INFO ) + IF ( INFO.GT.1 ) + $ RETURN + INFOM = MAX( INFO, INFOM ) + IF( SCALOC.NE.ONE ) THEN +C + DO 20 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 20 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + R(K,K) = U(1,1) + R(K,K+1) = U(1,2) + R(K+1,K+1) = U(2,2) +C +C If we are not at the end of S then set up and solve +C equation (6.2) or (10.20). +C +C Note that SB03OY returns ( u11*s11*inv( u11 ) ) in B +C and returns scaled alpha in A. ksize is the order of +C the remainder of S. k1, k2 and k3 point to the start +C of vectors in DWORK. +C + IF ( KOUNT.LE.N ) THEN + KSIZE = N - K - 1 + K1 = KSIZE + 1 + K2 = KSIZE + K1 + K3 = KSIZE + K2 +C +C Form the right-hand side of (6.2) or (10.20), the +C first column in DWORK( 1 ) ,..., DWORK( n - k - 1 ) +C the second in DWORK( n - k ) ,..., +C DWORK( 2*( n - k - 1 ) ). +C + CALL DCOPY( KSIZE, R(K,K+2), LDR, DWORK, 1 ) + CALL DCOPY( KSIZE, R(K+1,K+2), LDR, DWORK(K1), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', + $ 'Non-unit', KSIZE, 2, -ONE, A, 2, DWORK, + $ KSIZE ) + IF ( CONT ) THEN + CALL DAXPY( KSIZE, -R(K,K), S(K,K+2), LDS, DWORK, + $ 1 ) + CALL DAXPY( KSIZE, -R(K,K+1), S(K+1,K+2), LDS, + $ DWORK, 1) + CALL DAXPY( KSIZE, -R(K+1,K+1), S(K+1,K+2), LDS, + $ DWORK(K1), 1 ) + ELSE + CALL DAXPY( KSIZE, -R(K,K)*B(1,1), S(K,K+2), LDS, + $ DWORK, 1 ) + CALL DAXPY( KSIZE, -( R(K,K+1)*B(1,1) + R(K+1,K+1) + $ *B(2,1) ), S(K+1,K+2), LDS, DWORK, 1 ) + CALL DAXPY( KSIZE, -R(K,K)*B(1,2), S(K,K+2), LDS, + $ DWORK(K1), 1 ) + CALL DAXPY( KSIZE, -( R(K,K+1)*B(1,2) + R(K+1,K+1) + $ *B(2,2) ), S(K+1,K+2), LDS, DWORK(K1), + $ 1 ) + END IF +C +C SB03OR solves the Sylvester equations. The solution +C is overwritten on DWORK. +C + CALL SB03OR( DISCR, LTRANS, KSIZE, 2, S(K+2,K+2), LDS, + $ B, 2, DWORK, KSIZE, SCALOC, INFO ) + INFOM = MAX( INFO, INFOM ) + IF( SCALOC.NE.ONE ) THEN +C + DO 30 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 30 CONTINUE +C + SCALE = SCALE*SCALOC + END IF +C +C Copy the solution into the next 2*( n - k - 1 ) +C elements of DWORK. +C + CALL DCOPY( 2*KSIZE, DWORK, 1, DWORK(K2), 1 ) +C +C Now form the matrix Rhat of equation (6.4) or +C (10.22). Note that (10.22) is incorrect, so here we +C implement a corrected version of (10.22). +C + IF ( CONT ) THEN +C +C Swap the two rows of R with DWORK. +C + CALL DSWAP( KSIZE, DWORK, 1, R(K,K+2), LDR ) + CALL DSWAP( KSIZE, DWORK(K1), 1, R(K+1,K+2), LDR ) +C +C 1st column: +C + CALL DAXPY( KSIZE, -A(1,1), DWORK(K2), 1, DWORK, + $ 1 ) + CALL DAXPY( KSIZE, -A(1,2), DWORK(K3), 1, DWORK, + $ 1 ) +C +C 2nd column: +C + CALL DAXPY( KSIZE, -A(2,2), DWORK(K3), 1, + $ DWORK(K1), 1 ) + ELSE +C +C Form v = S1'*u + s*u11', overwriting v on DWORK. +C +C Compute S1'*u, first multiplying by the +C triangular part of S1. +C + CALL DTRMM( 'Left', 'Upper', 'Transpose', + $ 'Non-unit', KSIZE, 2, ONE, S(K+2,K+2), + $ LDS, DWORK, KSIZE ) +C +C Then multiply by the subdiagonal of S1 and add in +C to the above result. +C + J1 = K1 + J2 = K + 2 +C + DO 40 J = 1, KSIZE-1 + IF ( S(J2+1,J2).NE.ZERO ) THEN + DWORK(J) = S(J2+1,J2)*DWORK(K2+J) + DWORK(J) + DWORK(J1) = S(J2+1,J2)*DWORK(K3+J) + + $ DWORK(J1) + END IF + J1 = J1 + 1 + J2 = J2 + 1 + 40 CONTINUE +C +C Add in s*u11'. +C + CALL DAXPY( KSIZE, R(K,K), S(K,K+2), LDS, DWORK, + $ 1 ) + CALL DAXPY( KSIZE, R(K,K+1), S(K+1,K+2), LDS, + $ DWORK, 1 ) + CALL DAXPY( KSIZE, R(K+1,K+1), S(K+1,K+2), LDS, + $ DWORK(K1), 1 ) +C +C Next recover r from R, swapping r with u. +C + CALL DSWAP( KSIZE, DWORK(K2), 1, R(K,K+2), LDR ) + CALL DSWAP( KSIZE, DWORK(K3), 1, R(K+1,K+2), LDR ) +C +C Now we perform the QR factorization. +C +C ( a ) = Q*( t ), +C ( b ) +C +C and form +C +C ( p' ) = Q'*( r' ). +C ( y' ) ( v' ) +C +C y is then the correct vector to use in (10.22). +C Note that a is upper triangular and that t and +C p are not required. +C + CALL DLARFG( 3, A(1,1), B(1,1), 1, TAU1 ) + V1 = B(1,1) + T1 = TAU1*V1 + V2 = B(2,1) + T2 = TAU1*V2 + SUM = A(1,2) + V1*B(1,2) + V2*B(2,2) + B(1,2) = B(1,2) - SUM*T1 + B(2,2) = B(2,2) - SUM*T2 + CALL DLARFG( 3, A(2,2), B(1,2), 1, TAU2 ) + V3 = B(1,2) + T3 = TAU2*V3 + V4 = B(2,2) + T4 = TAU2*V4 + J1 = K1 + J2 = K2 + J3 = K3 +C + DO 50 J = 1, KSIZE + SUM = DWORK(J2) + V1*DWORK(J) + V2*DWORK(J1) + D1 = DWORK(J) - SUM*T1 + D2 = DWORK(J1) - SUM*T2 + SUM = DWORK(J3) + V3*D1 + V4*D2 + DWORK(J) = D1 - SUM*T3 + DWORK(J1) = D2 - SUM*T4 + J1 = J1 + 1 + J2 = J2 + 1 + J3 = J3 + 1 + 50 CONTINUE +C + END IF +C +C Now update R1 to give Rhat. +C + CALL DCOPY( KSIZE, DWORK, 1, DWORK(K2), 1 ) + CALL DCOPY( KSIZE, DWORK(K1), 1, DWORK(K3), 1 ) + CALL DCOPY( KSIZE, DWORK(K3), 1, DWORK(2), 2 ) + CALL DCOPY( KSIZE, DWORK(K2), 1, DWORK(1), 2 ) + CALL MB04OD( 'Full', KSIZE, 0, 2, R(K+2,K+2), LDR, + $ DWORK, 2, DWORK, 1, DWORK, 1, DWORK(K2), + $ DWORK(K3) ) + END IF + ELSE +C +C 1-by-1 block. +C +C Make sure S is stable or convergent and find u11 in +C equation (5.13) or (10.15). +C + IF ( DISCR ) THEN + ABSSKK = ABS( S(K,K) ) + IF ( ( ABSSKK - ONE ).GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + TEMP = SQRT( ( ONE - ABSSKK )*( ONE + ABSSKK ) ) + ELSE + IF ( S(K,K).GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + TEMP = SQRT( ABS( TWO*S(K,K) ) ) + END IF +C + SCALOC = ONE + IF( TEMP.LT.SMIN ) THEN + TEMP = SMIN + INFOM = 1 + END IF + DR = ABS( R(K,K) ) + IF( TEMP.LT.ONE .AND. DR.GT.ONE ) THEN + IF( DR.GT.BIGNUM*TEMP ) + $ SCALOC = ONE / DR + END IF + ALPHA = SIGN( TEMP, R(K,K) ) + R(K,K) = R(K,K)/ALPHA + IF( SCALOC.NE.ONE ) THEN +C + DO 60 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 60 CONTINUE +C + SCALE = SCALE*SCALOC + END IF +C +C If we are not at the end of S then set up and solve +C equation (5.14) or (10.16). ksize is the order of the +C remainder of S. k1 and k2 point to the start of vectors +C in DWORK. +C + IF ( KOUNT.LE.N ) THEN + KSIZE = N - K + K1 = KSIZE + 1 + K2 = KSIZE + K1 +C +C Form the right-hand side in DWORK( 1 ),..., +C DWORK( n - k ). +C + CALL DCOPY( KSIZE, R(K,K+1), LDR, DWORK, 1 ) + CALL DSCAL( KSIZE, -ALPHA, DWORK, 1 ) + IF ( CONT ) THEN + CALL DAXPY( KSIZE, -R(K,K), S(K,K+1), LDS, DWORK, + $ 1 ) + ELSE + CALL DAXPY( KSIZE, -S(K,K)*R(K,K), S(K,K+1), LDS, + $ DWORK, 1 ) + END IF +C +C SB03OR solves the Sylvester equations. The solution is +C overwritten on DWORK. +C + CALL SB03OR( DISCR, LTRANS, KSIZE, 1, S(K+1,K+1), LDS, + $ S(K,K), 1, DWORK, KSIZE, SCALOC, INFO ) + INFOM = MAX( INFO, INFOM ) + IF( SCALOC.NE.ONE ) THEN +C + DO 70 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 70 CONTINUE +C + SCALE = SCALE*SCALOC + END IF +C +C Copy the solution into the next ( n - k ) elements +C of DWORK, copy the solution back into R and copy +C the row of R back into DWORK. +C + CALL DCOPY( KSIZE, DWORK, 1, DWORK(K1), 1 ) + CALL DSWAP( KSIZE, DWORK, 1, R(K,K+1), LDR ) +C +C Now form the matrix Rhat of equation (5.15) or +C (10.17), first computing y in DWORK, and then +C updating R1. +C + IF ( CONT ) THEN + CALL DAXPY( KSIZE, -ALPHA, DWORK(K1), 1, DWORK, 1 ) + ELSE +C +C First form lambda( 1 )*r and then add in +C alpha*u11*s. +C + CALL DSCAL( KSIZE, -S(K,K), DWORK, 1 ) + CALL DAXPY( KSIZE, ALPHA*R(K,K), S(K,K+1), LDS, + $ DWORK, 1 ) +C +C Now form alpha*S1'*u, first multiplying by the +C sub-diagonal of S1 and then the triangular part +C of S1, and add the result in DWORK. +C + J1 = K + 1 +C + DO 80 J = 1, KSIZE-1 + IF ( S(J1+1,J1).NE.ZERO ) DWORK(J) + $ = ALPHA*S(J1+1,J1)*DWORK(K1+J) + DWORK(J) + J1 = J1 + 1 + 80 CONTINUE +C + CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', + $ KSIZE, S(K+1,K+1), LDS, DWORK(K1), 1 ) + CALL DAXPY( KSIZE, ALPHA, DWORK(K1), 1, DWORK, 1 ) + END IF + CALL MB04OD( 'Full', KSIZE, 0, 1, R(K+1,K+1), LDR, + $ DWORK, 1, DWORK, 1, DWORK, 1, DWORK(K2), + $ DWORK(K1) ) + END IF + END IF + GO TO 10 + END IF +C END WHILE 10 +C + ELSE +C +C Case op(M) = M'. +C + KOUNT = N +C + 90 CONTINUE +C WHILE( KOUNT.GE.1 )LOOP + IF ( KOUNT.GE.1 ) THEN + K = KOUNT + IF ( KOUNT.EQ.1 ) THEN + TBYT = .FALSE. + KOUNT = KOUNT - 1 + ELSE IF ( S(K,K-1).EQ.ZERO ) THEN + TBYT = .FALSE. + KOUNT = KOUNT - 1 + ELSE + TBYT = .TRUE. + K = K - 1 + IF ( K.GT.1 ) THEN + IF ( S(K,K-1).NE.ZERO ) THEN + INFO = 3 + RETURN + END IF + END IF + KOUNT = KOUNT - 2 + END IF + IF ( TBYT ) THEN +C +C Solve the two-by-two Lyapunov equation corresponding to +C (6.1) or (10.19), using the routine SB03OY. +C + B(1,1) = S(K,K) + B(2,1) = S(K+1,K) + B(1,2) = S(K,K+1) + B(2,2) = S(K+1,K+1) + U(1,1) = R(K,K) + U(1,2) = R(K,K+1) + U(2,2) = R(K+1,K+1) +C + CALL SB03OY( DISCR, LTRANS, ISGN, B, 2, U, 2, A, 2, + $ SCALOC, INFO ) + IF ( INFO.GT.1 ) + $ RETURN + INFOM = MAX( INFO, INFOM ) + IF( SCALOC.NE.ONE ) THEN +C + DO 100 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 100 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + R(K,K) = U(1,1) + R(K,K+1) = U(1,2) + R(K+1,K+1) = U(2,2) +C +C If we are not at the front of S then set up and solve +C equation corresponding to (6.2) or (10.20). +C +C Note that SB03OY returns ( inv( u11 )*s11*u11 ) in B +C and returns scaled alpha, alpha = inv( u11 )*r11, in A. +C ksize is the order of the remainder leading part of S. +C k1, k2 and k3 point to the start of vectors in DWORK. +C + IF ( KOUNT.GE.1 ) THEN + KSIZE = K - 1 + K1 = KSIZE + 1 + K2 = KSIZE + K1 + K3 = KSIZE + K2 +C +C Form the right-hand side of equations corresponding to +C (6.2) or (10.20), the first column in DWORK( 1 ) ,..., +C DWORK( k - 1 ) the second in DWORK( k ) ,..., +C DWORK( 2*( k - 1 ) ). +C + CALL DCOPY( KSIZE, R(1,K), 1, DWORK, 1 ) + CALL DCOPY( KSIZE, R(1,K+1), 1, DWORK(K1), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', + $ KSIZE, 2, -ONE, A, 2, DWORK, KSIZE ) + IF ( CONT ) THEN + CALL DAXPY( KSIZE, -R(K,K), S(1,K), 1, DWORK, 1 ) + CALL DAXPY( KSIZE, -R(K,K+1), S(1,K), 1, DWORK(K1), + $ 1 ) + CALL DAXPY( KSIZE, -R(K+1,K+1), S(1,K+1), 1, + $ DWORK(K1), 1 ) + ELSE + CALL DAXPY( KSIZE, -( R(K,K)*B(1,1) + R(K,K+1) + $ *B(1,2) ), S(1,K), 1, DWORK, 1 ) + CALL DAXPY( KSIZE, -R(K+1,K+1)*B(1,2), S(1,K+1), 1, + $ DWORK, 1 ) + CALL DAXPY( KSIZE, -( R(K,K)*B(2,1) + R(K,K+1) + $ *B(2,2) ), S(1,K), 1, DWORK(K1), 1 ) + CALL DAXPY( KSIZE, -R(K+1,K+1)*B(2,2), S(1,K+1), 1, + $ DWORK(K1), 1 ) + END IF +C +C SB03OR solves the Sylvester equations. The solution +C is overwritten on DWORK. +C + CALL SB03OR( DISCR, LTRANS, KSIZE, 2, S, LDS, B, 2, + $ DWORK, KSIZE, SCALOC, INFO ) + INFOM = MAX( INFO, INFOM ) + IF( SCALOC.NE.ONE ) THEN +C + DO 110 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 110 CONTINUE +C + SCALE = SCALE*SCALOC + END IF +C +C Copy the solution into the next 2*( k - 1 ) elements +C of DWORK. +C + CALL DCOPY( 2*KSIZE, DWORK, 1, DWORK(K2), 1 ) +C +C Now form the matrix Rhat of equation corresponding +C to (6.4) or (10.22) (corrected version). +C + IF ( CONT ) THEN +C +C Swap the two columns of R with DWORK. +C + CALL DSWAP( KSIZE, DWORK, 1, R(1,K), 1 ) + CALL DSWAP( KSIZE, DWORK(K1), 1, R(1,K+1), 1 ) +C +C 1st column: +C + CALL DAXPY( KSIZE, -A(1,1), DWORK(K2), 1, DWORK, + $ 1 ) +C +C 2nd column: +C + CALL DAXPY( KSIZE, -A(1,2), DWORK(K2), 1, + $ DWORK(K1), 1 ) + CALL DAXPY( KSIZE, -A(2,2), DWORK(K3), 1, + $ DWORK(K1), 1 ) + ELSE +C +C Form v = S1*u + s*u11, overwriting v on DWORK. +C +C Compute S1*u, first multiplying by the triangular +C part of S1. +C + CALL DTRMM( 'Left', 'Upper', 'No transpose', + $ 'Non-unit', KSIZE, 2, ONE, S, LDS, + $ DWORK, KSIZE ) +C +C Then multiply by the subdiagonal of S1 and add in +C to the above result. +C + J1 = K1 +C + DO 120 J = 2, KSIZE + J1 = J1 + 1 + IF ( S(J,J-1).NE.ZERO ) THEN + DWORK(J) = S(J,J-1)*DWORK(K2+J-2) + DWORK(J) + DWORK(J1) = S(J,J-1)*DWORK(K3+J-2) + + $ DWORK(J1) + END IF + 120 CONTINUE +C +C Add in s*u11. +C + CALL DAXPY( KSIZE, R(K,K), S(1,K), 1, DWORK, 1 ) + CALL DAXPY( KSIZE, R(K,K+1), S(1,K), 1, DWORK(K1), + $ 1 ) + CALL DAXPY( KSIZE, R(K+1,K+1), S(1,K+1), 1, + $ DWORK(K1), 1 ) +C +C Next recover r from R, swapping r with u. +C + CALL DSWAP( KSIZE, DWORK(K2), 1, R(1,K), 1 ) + CALL DSWAP( KSIZE, DWORK(K3), 1, R(1,K+1), 1 ) +C +C Now we perform the QL factorization. +C +C ( a' ) = Q*( t ), +C ( b' ) +C +C and form +C +C ( p' ) = Q'*( r' ). +C ( y' ) ( v' ) +C +C y is then the correct vector to use in the +C relation corresponding to (10.22). +C Note that a is upper triangular and that t and +C p are not required. +C + CALL DLARFG( 3, A(2,2), B(2,1), 2, TAU1 ) + V1 = B(2,1) + T1 = TAU1*V1 + V2 = B(2,2) + T2 = TAU1*V2 + SUM = A(1,2) + V1*B(1,1) + V2*B(1,2) + B(1,1) = B(1,1) - SUM*T1 + B(1,2) = B(1,2) - SUM*T2 + CALL DLARFG( 3, A(1,1), B(1,1), 2, TAU2 ) + V3 = B(1,1) + T3 = TAU2*V3 + V4 = B(1,2) + T4 = TAU2*V4 + J1 = K1 + J2 = K2 + J3 = K3 +C + DO 130 J = 1, KSIZE + SUM = DWORK(J3) + V1*DWORK(J) + V2*DWORK(J1) + D1 = DWORK(J) - SUM*T1 + D2 = DWORK(J1) - SUM*T2 + SUM = DWORK(J2) + V3*D1 + V4*D2 + DWORK(J) = D1 - SUM*T3 + DWORK(J1) = D2 - SUM*T4 + J1 = J1 + 1 + J2 = J2 + 1 + J3 = J3 + 1 + 130 CONTINUE +C + END IF +C +C Now update R1 to give Rhat. +C + CALL MB04ND( 'Full', KSIZE, 0, 2, R, LDR, DWORK, + $ KSIZE, DWORK, 1, DWORK, 1, DWORK(K2), + $ DWORK(K3) ) + END IF + ELSE +C +C 1-by-1 block. +C +C Make sure S is stable or convergent and find u11 in +C equation corresponding to (5.13) or (10.15). +C + IF ( DISCR ) THEN + ABSSKK = ABS( S(K,K) ) + IF ( ( ABSSKK - ONE ).GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + TEMP = SQRT( ( ONE - ABSSKK )*( ONE + ABSSKK ) ) + ELSE + IF ( S(K,K).GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + TEMP = SQRT( ABS( TWO*S(K,K) ) ) + END IF +C + SCALOC = ONE + IF( TEMP.LT.SMIN ) THEN + TEMP = SMIN + INFOM = 1 + END IF + DR = ABS( R(K,K) ) + IF( TEMP.LT.ONE .AND. DR.GT.ONE ) THEN + IF( DR.GT.BIGNUM*TEMP ) + $ SCALOC = ONE / DR + END IF + ALPHA = SIGN( TEMP, R(K,K) ) + R(K,K) = R(K,K)/ALPHA + IF( SCALOC.NE.ONE ) THEN +C + DO 140 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 140 CONTINUE +C + SCALE = SCALE*SCALOC + END IF +C +C If we are not at the front of S then set up and solve +C equation corresponding to (5.14) or (10.16). ksize is +C the order of the remainder leading part of S. k1 and k2 +C point to the start of vectors in DWORK. +C + IF ( KOUNT.GE.1 ) THEN + KSIZE = K - 1 + K1 = KSIZE + 1 + K2 = KSIZE + K1 +C +C Form the right-hand side in DWORK( 1 ),..., +C DWORK( k - 1 ). +C + CALL DCOPY( KSIZE, R(1,K), 1, DWORK, 1 ) + CALL DSCAL( KSIZE, -ALPHA, DWORK, 1 ) + IF ( CONT ) THEN + CALL DAXPY( KSIZE, -R(K,K), S(1,K), 1, DWORK, 1 ) + ELSE + CALL DAXPY( KSIZE, -S(K,K)*R(K,K), S(1,K), 1, + $ DWORK, 1 ) + END IF +C +C SB03OR solves the Sylvester equations. The solution is +C overwritten on DWORK. +C + CALL SB03OR( DISCR, LTRANS, KSIZE, 1, S, LDS, S(K,K), + $ 1, DWORK, KSIZE, SCALOC, INFO ) + INFOM = MAX( INFO, INFOM ) + IF( SCALOC.NE.ONE ) THEN +C + DO 150 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 150 CONTINUE +C + SCALE = SCALE*SCALOC + END IF +C +C Copy the solution into the next ( k - 1 ) elements +C of DWORK, copy the solution back into R and copy +C the column of R back into DWORK. +C + CALL DCOPY( KSIZE, DWORK, 1, DWORK(K1), 1 ) + CALL DSWAP( KSIZE, DWORK, 1, R(1,K), 1 ) +C +C Now form the matrix Rhat of equation corresponding +C to (5.15) or (10.17), first computing y in DWORK, +C and then updating R1. +C + IF ( CONT ) THEN + CALL DAXPY( KSIZE, -ALPHA, DWORK(K1), 1, DWORK, 1 ) + ELSE +C +C First form lambda( 1 )*r and then add in +C alpha*u11*s. +C + CALL DSCAL( KSIZE, -S(K,K), DWORK, 1 ) + CALL DAXPY( KSIZE, ALPHA*R(K,K), S(1,K), 1, DWORK, + $ 1 ) +C +C Now form alpha*S1*u, first multiplying by the +C sub-diagonal of S1 and then the triangular part +C of S1, and add the result in DWORK. +C + DO 160 J = 2, KSIZE + IF ( S(J,J-1).NE.ZERO ) DWORK(J) + $ = ALPHA*S(J,J-1)*DWORK(K1+J-2) + DWORK(J) + 160 CONTINUE +C + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', + $ KSIZE, S, LDS, DWORK(K1), 1 ) + CALL DAXPY( KSIZE, ALPHA, DWORK(K1), 1, DWORK, 1 ) + END IF + CALL MB04ND( 'Full', KSIZE, 0, 1, R, LDR, DWORK, + $ KSIZE, DWORK, 1, DWORK, 1, DWORK(K2), + $ DWORK(K1) ) + END IF + END IF + GO TO 90 + END IF +C END WHILE 90 +C + END IF + INFO = INFOM + RETURN +C *** Last line of SB03OT *** + END diff --git a/mex/sources/libslicot/SB03OU.f b/mex/sources/libslicot/SB03OU.f new file mode 100644 index 000000000..d9ae8cb17 --- /dev/null +++ b/mex/sources/libslicot/SB03OU.f @@ -0,0 +1,410 @@ + SUBROUTINE SB03OU( DISCR, LTRANS, N, M, A, LDA, B, LDB, TAU, U, + $ LDU, SCALE, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X = op(U)'*op(U) either the stable non-negative +C definite continuous-time Lyapunov equation +C 2 +C op(A)'*X + X*op(A) = -scale *op(B)'*op(B) (1) +C +C or the convergent non-negative definite discrete-time Lyapunov +C equation +C 2 +C op(A)'*X*op(A) - X = -scale *op(B)'*op(B) (2) +C +C where op(K) = K or K' (i.e., the transpose of the matrix K), A is +C an N-by-N matrix in real Schur form, op(B) is an M-by-N matrix, +C U is an upper triangular matrix containing the Cholesky factor of +C the solution matrix X, X = op(U)'*op(U), and scale is an output +C scale factor, set less than or equal to 1 to avoid overflow in X. +C If matrix B has full rank then the solution matrix X will be +C positive-definite and hence the Cholesky factor U will be +C nonsingular, but if B is rank deficient then X may only be +C positive semi-definite and U will be singular. +C +C In the case of equation (1) the matrix A must be stable (that +C is, all the eigenvalues of A must have negative real parts), +C and for equation (2) the matrix A must be convergent (that is, +C all the eigenvalues of A must lie inside the unit circle). +C +C ARGUMENTS +C +C Mode Parameters +C +C DISCR LOGICAL +C Specifies the type of Lyapunov equation to be solved as +C follows: +C = .TRUE. : Equation (2), discrete-time case; +C = .FALSE.: Equation (1), continuous-time case. +C +C LTRANS LOGICAL +C Specifies the form of op(K) to be used, as follows: +C = .FALSE.: op(K) = K (No transpose); +C = .TRUE. : op(K) = K**T (Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A and the number of columns in +C matrix op(B). N >= 0. +C +C M (input) INTEGER +C The number of rows in matrix op(B). M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain a real Schur form matrix S. The elements +C below the upper Hessenberg part of the array A are not +C referenced. The 2-by-2 blocks must only correspond to +C complex conjugate pairs of eigenvalues (not to real +C eigenvalues). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C if LTRANS = .FALSE., and dimension (LDB,M), if +C LTRANS = .TRUE.. +C On entry, if LTRANS = .FALSE., the leading M-by-N part of +C this array must contain the coefficient matrix B of the +C equation. +C On entry, if LTRANS = .TRUE., the leading N-by-M part of +C this array must contain the coefficient matrix B of the +C equation. +C On exit, if LTRANS = .FALSE., the leading +C MIN(M,N)-by-MIN(M,N) upper triangular part of this array +C contains the upper triangular matrix R (as defined in +C METHOD), and the M-by-MIN(M,N) strictly lower triangular +C part together with the elements of the array TAU are +C overwritten by details of the matrix P (also defined in +C METHOD). When M < N, columns (M+1),...,N of the array B +C are overwritten by the matrix Z (see METHOD). +C On exit, if LTRANS = .TRUE., the leading +C MIN(M,N)-by-MIN(M,N) upper triangular part of +C B(1:N,M-N+1), if M >= N, or of B(N-M+1:N,1:M), if M < N, +C contains the upper triangular matrix R (as defined in +C METHOD), and the remaining elements (below the diagonal +C of R) together with the elements of the array TAU are +C overwritten by details of the matrix P (also defined in +C METHOD). When M < N, rows 1,...,(N-M) of the array B +C are overwritten by the matrix Z (see METHOD). +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,M), if LTRANS = .FALSE., +C LDB >= MAX(1,N), if LTRANS = .TRUE.. +C +C TAU (output) DOUBLE PRECISION array of dimension (MIN(N,M)) +C This array contains the scalar factors of the elementary +C reflectors defining the matrix P. +C +C U (output) DOUBLE PRECISION array of dimension (LDU,N) +C The leading N-by-N upper triangular part of this array +C contains the Cholesky factor of the solution matrix X of +C the problem, X = op(U)'*op(U). +C The array U may be identified with B in the calling +C statement, if B is properly dimensioned, and the +C intermediate results returned in B are not needed. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, or INFO = 1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,4*N). +C For optimum performance LDWORK should sometimes be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the Lyapunov equation is (nearly) singular +C (warning indicator); +C if DISCR = .FALSE., this means that while the matrix +C A has computed eigenvalues with negative real parts, +C it is only just stable in the sense that small +C perturbations in A can make one or more of the +C eigenvalues have a non-negative real part; +C if DISCR = .TRUE., this means that while the matrix +C A has computed eigenvalues inside the unit circle, +C it is nevertheless only just convergent, in the +C sense that small perturbations in A can make one or +C more of the eigenvalues lie outside the unit circle; +C perturbed values were used to solve the equation +C (but the matrix A is unchanged); +C = 2: if matrix A is not stable (that is, one or more of +C the eigenvalues of A has a non-negative real part), +C if DISCR = .FALSE., or not convergent (that is, one +C or more of the eigenvalues of A lies outside the +C unit circle), if DISCR = .TRUE.; +C = 3: if matrix A has two or more consecutive non-zero +C elements on the first sub-diagonal, so that there is +C a block larger than 2-by-2 on the diagonal; +C = 4: if matrix A has a 2-by-2 diagonal block with real +C eigenvalues instead of a complex conjugate pair. +C +C METHOD +C +C The method used by the routine is based on the Bartels and +C Stewart method [1], except that it finds the upper triangular +C matrix U directly without first finding X and without the need +C to form the normal matrix op(B)'*op(B) [2]. +C +C If LTRANS = .FALSE., the matrix B is factored as +C +C B = P ( R ), M >= N, B = P ( R Z ), M < N, +C ( 0 ) +C +C (QR factorization), where P is an M-by-M orthogonal matrix and +C R is a square upper triangular matrix. +C +C If LTRANS = .TRUE., the matrix B is factored as +C +C B = ( 0 R ) P, M >= N, B = ( Z ) P, M < N, +C ( R ) +C +C (RQ factorization), where P is an M-by-M orthogonal matrix and +C R is a square upper triangular matrix. +C +C These factorizations are used to solve the continuous-time +C Lyapunov equation in the canonical form +C 2 +C op(A)'*op(U)'*op(U) + op(U)'*op(U)*op(A) = -scale *op(F)'*op(F), +C +C or the discrete-time Lyapunov equation in the canonical form +C 2 +C op(A)'*op(U)'*op(U)*op(A) - op(U)'*op(U) = -scale *op(F)'*op(F), +C +C where U and F are N-by-N upper triangular matrices, and +C +C F = R, if M >= N, or +C +C F = ( R ), if LTRANS = .FALSE., or +C ( 0 ) +C +C F = ( 0 Z ), if LTRANS = .TRUE., if M < N. +C ( 0 R ) +C +C The canonical equation is solved for U. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. +C Solution of the matrix equation A'X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-325, 1982. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C The Lyapunov equation may be very ill-conditioned. In particular, +C if A is only just stable (or convergent) then the Lyapunov +C equation will be ill-conditioned. "Large" elements in U relative +C to those of A and B, or a "small" value for scale, are symptoms +C of ill-conditioning. A condition estimate can be computed using +C SLICOT Library routine SB03MD. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Supersedes Release 2.0 routine SB03CZ by Sven Hammarling, +C NAG Ltd, United Kingdom. +C Partly based on routine PLYAPS by A. Varga, University of Bochum, +C May 1992. +C +C REVISIONS +C +C Dec. 1997, April 1998, May 1999. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + LOGICAL DISCR, LTRANS + INTEGER INFO, LDA, LDB, LDU, LDWORK, M, N + DOUBLE PRECISION SCALE +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*), U(LDU,*) +C .. Local Scalars .. + INTEGER I, J, K, L, MN, WRKOPT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEQRF, DGERQF, DLACPY, DLASET, SB03OT, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( ( LDB.LT.MAX( 1, M ) .AND. .NOT.LTRANS ) .OR. + $ ( LDB.LT.MAX( 1, N ) .AND. LTRANS ) ) THEN + INFO = -8 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.MAX( 1, 4*N ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB03OU', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + MN = MIN( N, M ) + IF ( MN.EQ.0 ) THEN + SCALE = ONE + DWORK(1) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF ( LTRANS ) THEN +C +C Case op(K) = K'. +C +C Perform the RQ factorization of B. +C Workspace: need N; +C prefer N*NB. +C + CALL DGERQF( N, M, B, LDB, TAU, DWORK, LDWORK, INFO ) +C +C The triangular matrix F is constructed in the array U so that +C U can share the same memory as B. +C + IF ( M.GE.N ) THEN + CALL DLACPY( 'Upper', MN, N, B(1,M-N+1), LDB, U, LDU ) + ELSE +C + DO 10 I = M, 1, -1 + CALL DCOPY( N-M+I, B(1,I), 1, U(1,N-M+I), 1 ) + 10 CONTINUE +C + CALL DLASET( 'Full', N, N-M, ZERO, ZERO, U, LDU ) + END IF + ELSE +C +C Case op(K) = K. +C +C Perform the QR factorization of B. +C Workspace: need N; +C prefer N*NB. +C + CALL DGEQRF( M, N, B, LDB, TAU, DWORK, LDWORK, INFO ) + CALL DLACPY( 'Upper', MN, N, B, LDB, U, LDU ) + IF ( M.LT.N ) + $ CALL DLASET( 'Upper', N-M, N-M, ZERO, ZERO, U(M+1,M+1), + $ LDU ) + END IF + WRKOPT = DWORK(1) +C +C Solve the canonical Lyapunov equation +C 2 +C op(A)'*op(U)'*op(U) + op(U)'*op(U)*op(A) = -scale *op(F)'*op(F), +C +C or +C 2 +C op(A)'*op(U)'*op(U)*op(A) - op(U)'*op(U) = -scale *op(F)'*op(F) +C +C for U. +C + CALL SB03OT( DISCR, LTRANS, N, A, LDA, U, LDU, SCALE, DWORK, + $ INFO ) + IF ( INFO.NE.0 .AND. INFO.NE.1 ) + $ RETURN +C +C Make the diagonal elements of U non-negative. +C + IF ( LTRANS ) THEN +C + DO 30 J = 1, N + IF ( U(J,J).LT.ZERO ) THEN +C + DO 20 I = 1, J + U(I,J) = -U(I,J) + 20 CONTINUE +C + END IF + 30 CONTINUE +C + ELSE + K = 1 +C + DO 50 J = 1, N + DWORK(K) = U(J,J) + L = 1 +C + DO 40 I = 1, J + IF ( DWORK(L).LT.ZERO ) U(I,J) = -U(I,J) + L = L + 1 + 40 CONTINUE +C + K = K + 1 + 50 CONTINUE +C + END IF +C + DWORK(1) = MAX( WRKOPT, 4*N ) + RETURN +C *** Last line of SB03OU *** + END diff --git a/mex/sources/libslicot/SB03OV.f b/mex/sources/libslicot/SB03OV.f new file mode 100644 index 000000000..bd92699b8 --- /dev/null +++ b/mex/sources/libslicot/SB03OV.f @@ -0,0 +1,105 @@ + SUBROUTINE SB03OV( A, B, C, S ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct a complex plane rotation such that, for a complex +C number a and a real number b, +C +C ( conjg( c ) s )*( a ) = ( d ), +C ( -s c ) ( b ) ( 0 ) +C +C where d is always real and is overwritten on a, so that on +C return the imaginary part of a is zero. b is unaltered. +C +C This routine has A and C declared as REAL, because it is intended +C for use within a real Lyapunov solver and the REAL declarations +C mean that a standard Fortran DOUBLE PRECISION version may be +C readily constructed. However A and C could safely be declared +C COMPLEX in the calling program, although some systems may give a +C type mismatch warning. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C A (input/output) DOUBLE PRECISION array, dimension (2) +C On entry, A(1) and A(2) must contain the real and +C imaginary part, respectively, of the complex number a. +C On exit, A(1) contains the real part of d, and A(2) is +C set to zero. +C +C B (input) DOUBLE PRECISION +C The real number b. +C +C C (output) DOUBLE PRECISION array, dimension (2) +C C(1) and C(2) contain the real and imaginary part, +C respectively, of the complex number c, the cosines of +C the plane rotation. +C +C S (output) DOUBLE PRECISION +C The real number s, the sines of the plane rotation. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB03CV by Sven Hammarling, +C NAG Ltd., United Kingdom, May 1985. +C +C REVISIONS +C +C Dec. 1997. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation. +C +C ***************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION B, S +C .. Array Arguments .. + DOUBLE PRECISION A(2), C(2) +C .. Local Scalars .. + DOUBLE PRECISION D +C .. External Functions .. + DOUBLE PRECISION DLAPY3 + EXTERNAL DLAPY3 +C .. Executable Statements .. +C + D = DLAPY3( A(1), A(2), B ) + IF ( D.EQ.ZERO ) THEN + C(1) = ONE + C(2) = ZERO + S = ZERO + ELSE + C(1) = A(1)/D + C(2) = A(2)/D + S = B/D + A(1) = D + A(2) = ZERO + END IF +C + RETURN +C *** Last line of SB03OV *** + END diff --git a/mex/sources/libslicot/SB03OY.f b/mex/sources/libslicot/SB03OY.f new file mode 100644 index 000000000..44a94b979 --- /dev/null +++ b/mex/sources/libslicot/SB03OY.f @@ -0,0 +1,693 @@ + SUBROUTINE SB03OY( DISCR, LTRANS, ISGN, S, LDS, R, LDR, A, LDA, + $ SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for the Cholesky factor U of X, +C +C op(U)'*op(U) = X, +C +C where U is a two-by-two upper triangular matrix, either the +C continuous-time two-by-two Lyapunov equation +C 2 +C op(S)'*X + X*op(S) = -ISGN*scale *op(R)'*op(R), +C +C when DISCR = .FALSE., or the discrete-time two-by-two Lyapunov +C equation +C 2 +C op(S)'*X*op(S) - X = -ISGN*scale *op(R)'*op(R), +C +C when DISCR = .TRUE., where op(K) = K or K' (i.e., the transpose of +C the matrix K), S is a two-by-two matrix with complex conjugate +C eigenvalues, R is a two-by-two upper triangular matrix, +C ISGN = -1 or 1, and scale is an output scale factor, set less +C than or equal to 1 to avoid overflow in X. The routine also +C computes two matrices, B and A, so that +C 2 +C B*U = U*S and A*U = scale *R, if LTRANS = .FALSE., or +C 2 +C U*B = S*U and U*A = scale *R, if LTRANS = .TRUE., +C which are used by the general Lyapunov solver. +C In the continuous-time case ISGN*S must be stable, so that its +C eigenvalues must have strictly negative real parts. +C In the discrete-time case S must be convergent if ISGN = 1, that +C is, its eigenvalues must have moduli less than unity, or S must +C be completely divergent if ISGN = -1, that is, its eigenvalues +C must have moduli greater than unity. +C +C ARGUMENTS +C +C Mode Parameters +C +C DISCR LOGICAL +C Specifies the equation to be solved: 2 +C = .FALSE.: op(S)'*X + X*op(S) = -ISGN*scale *op(R)'*op(R); +C 2 +C = .TRUE. : op(S)'*X*op(S) - X = -ISGN*scale *op(R)'*op(R). +C +C LTRANS LOGICAL +C Specifies the form of op(K) to be used, as follows: +C = .FALSE.: op(K) = K (No transpose); +C = .TRUE. : op(K) = K**T (Transpose). +C +C ISGN INTEGER +C Specifies the sign of the equation as described before. +C ISGN may only be 1 or -1. +C +C Input/Output Parameters +C +C S (input/output) DOUBLE PRECISION array, dimension (LDS,2) +C On entry, S must contain a 2-by-2 matrix. +C On exit, S contains a 2-by-2 matrix B such that B*U = U*S, +C if LTRANS = .FALSE., or U*B = S*U, if LTRANS = .TRUE.. +C Notice that if U is nonsingular then +C B = U*S*inv( U ), if LTRANS = .FALSE. +C B = inv( U )*S*U, if LTRANS = .TRUE.. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= 2. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,2) +C On entry, R must contain a 2-by-2 upper triangular matrix. +C The element R( 2, 1 ) is not referenced. +C On exit, R contains U, the 2-by-2 upper triangular +C Cholesky factor of the solution X, X = op(U)'*op(U). +C +C LDR INTEGER +C The leading dimension of array R. LDR >= 2. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,2) +C A contains a 2-by-2 upper triangular matrix A satisfying +C A*U/scale = scale*R, if LTRANS = .FALSE., or +C U*A/scale = scale*R, if LTRANS = .TRUE.. +C Notice that if U is nonsingular then +C A = scale*scale*R*inv( U ), if LTRANS = .FALSE. +C A = scale*scale*inv( U )*R, if LTRANS = .TRUE.. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= 2. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if the Lyapunov equation is (nearly) singular +C (warning indicator); +C if DISCR = .FALSE., this means that while the +C matrix S has computed eigenvalues with negative real +C parts, it is only just stable in the sense that +C small perturbations in S can make one or more of the +C eigenvalues have a non-negative real part; +C if DISCR = .TRUE., this means that while the +C matrix S has computed eigenvalues inside the unit +C circle, it is nevertheless only just convergent, in +C the sense that small perturbations in S can make one +C or more of the eigenvalues lie outside the unit +C circle; +C perturbed values were used to solve the equation +C (but the matrix S is unchanged); +C = 2: if DISCR = .FALSE., and ISGN*S is not stable or +C if DISCR = .TRUE., ISGN = 1 and S is not convergent +C or if DISCR = .TRUE., ISGN = -1 and S is not +C completely divergent; +C = 4: if S has real eigenvalues. +C +C NOTE: In the interests of speed, this routine does not check all +C inputs for errors. +C +C METHOD +C +C The LAPACK scheme for solving 2-by-2 Sylvester equations is +C adapted for 2-by-2 Lyapunov equations, but directly computing the +C Cholesky factor of the solution. +C +C REFERENCES +C +C [1] Hammarling S. J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-325, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB03CY by Sven Hammarling, +C NAG Ltd., United Kingdom, November 1986. +C Partly based on SB03CY and PLYAP2 by A. Varga, University of +C Bochum, May 1992. +C +C REVISIONS +C +C Dec. 1997, April 1998. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ***************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, FOUR + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ FOUR = 4.0D0 ) +C .. Scalar Arguments .. + LOGICAL DISCR, LTRANS + INTEGER INFO, ISGN, LDA, LDR, LDS + DOUBLE PRECISION SCALE +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), R(LDR,*), S(LDS,*) +C .. Local Scalars .. + DOUBLE PRECISION ABSB, ABSG, ABST, ALPHA, BIGNUM, E1, E2, EPS, + $ ETA, P1, P3, P3I, P3R, S11, S12, S21, S22, + $ SCALOC, SGN, SMIN, SMLNUM, SNP, SNQ, SNT, TEMPI, + $ TEMPR, V1, V3 +C .. Local Arrays .. + DOUBLE PRECISION CSP(2), CSQ(2), CST(2), DELTA(2), DP(2), DT(2), + $ G(2), GAMMA(2), P2(2), T(2), TEMP(2), V2(2), + $ X11(2), X12(2), X21(2), X22(2), Y(2) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2, DLAPY3 + EXTERNAL DLAMCH, DLAPY2, DLAPY3 +C .. External Subroutines .. + EXTERNAL DLABAD, DLANV2, SB03OV +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +C .. Executable Statements .. +C +C The comments in this routine refer to notation and equation +C numbers in sections 6 and 10 of [1]. +C +C Find the eigenvalue lambda = E1 - i*E2 of s11. +C + INFO = 0 + SGN = ISGN + S11 = S(1,1) + S12 = S(1,2) + S21 = S(2,1) + S22 = S(2,2) +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM*FOUR / EPS + BIGNUM = ONE / SMLNUM +C + SMIN = MAX( SMLNUM, EPS*MAX( ABS( S11 ), ABS( S12 ), + $ ABS( S21 ), ABS( S22 ) ) ) + SCALE = ONE +C + CALL DLANV2( S11, S12, S21, S22, TEMPR, TEMPI, E1, E2, CSP, CSQ ) + IF ( TEMPI.EQ.ZERO ) THEN + INFO = 4 + RETURN + END IF + ABSB = DLAPY2( E1, E2 ) + IF ( DISCR ) THEN + IF ( SGN*( ABSB - ONE ).GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + ELSE + IF ( SGN*E1.GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + END IF +C +C Compute the cos and sine that define Qhat. The sine is real. +C + TEMP(1) = S(1,1) - E1 + TEMP(2) = E2 + IF ( LTRANS ) TEMP(2) = -E2 + CALL SB03OV( TEMP, S(2,1), CSQ, SNQ ) +C +C beta in (6.9) is given by beta = E1 + i*E2, compute t. +C + TEMP(1) = CSQ(1)*S(1,2) - SNQ*S(1,1) + TEMP(2) = CSQ(2)*S(1,2) + TEMPR = CSQ(1)*S(2,2) - SNQ*S(2,1) + TEMPI = CSQ(2)*S(2,2) + T(1) = CSQ(1)*TEMP(1) - CSQ(2)*TEMP(2) + SNQ*TEMPR + T(2) = CSQ(1)*TEMP(2) + CSQ(2)*TEMP(1) + SNQ*TEMPI +C + IF ( LTRANS ) THEN +C ( -- ) +C Case op(M) = M'. Note that the modified R is ( p3 p2 ). +C ( 0 p1 ) +C +C Compute the cos and sine that define Phat. +C + TEMP(1) = CSQ(1)*R(2,2) - SNQ*R(1,2) + TEMP(2) = -CSQ(2)*R(2,2) + CALL SB03OV( TEMP, -SNQ*R(1,1), CSP, SNP ) +C +C Compute p1, p2 and p3 of the relation corresponding to (6.11). +C + P1 = TEMP(1) + TEMP(1) = CSQ(1)*R(1,2) + SNQ*R(2,2) + TEMP(2) = -CSQ(2)*R(1,2) + TEMPR = CSQ(1)*R(1,1) + TEMPI = -CSQ(2)*R(1,1) + P2(1) = CSP(1)*TEMP(1) - CSP(2)*TEMP(2) + SNP*TEMPR + P2(2) = -CSP(1)*TEMP(2) - CSP(2)*TEMP(1) - SNP*TEMPI + P3R = CSP(1)*TEMPR + CSP(2)*TEMPI - SNP*TEMP(1) + P3I = CSP(1)*TEMPI - CSP(2)*TEMPR - SNP*TEMP(2) + ELSE +C +C Case op(M) = M. +C +C Compute the cos and sine that define Phat. +C + TEMP(1) = CSQ(1)*R(1,1) + SNQ*R(1,2) + TEMP(2) = CSQ(2)*R(1,1) + CALL SB03OV( TEMP, SNQ*R(2,2), CSP, SNP ) +C +C Compute p1, p2 and p3 of (6.11). +C + P1 = TEMP(1) + TEMP(1) = CSQ(1)*R(1,2) - SNQ*R(1,1) + TEMP(2) = CSQ(2)*R(1,2) + TEMPR = CSQ(1)*R(2,2) + TEMPI = CSQ(2)*R(2,2) + P2(1) = CSP(1)*TEMP(1) - CSP(2)*TEMP(2) + SNP*TEMPR + P2(2) = CSP(1)*TEMP(2) + CSP(2)*TEMP(1) + SNP*TEMPI + P3R = CSP(1)*TEMPR + CSP(2)*TEMPI - SNP*TEMP(1) + P3I = CSP(2)*TEMPR - CSP(1)*TEMPI + SNP*TEMP(2) + END IF +C +C Make p3 real by multiplying by conjg ( p3 )/abs( p3 ) to give +C +C p3 := abs( p3 ). +C + IF ( P3I.EQ.ZERO ) THEN + P3 = ABS( P3R ) + DP(1) = SIGN( ONE, P3R ) + DP(2) = ZERO + ELSE + P3 = DLAPY2( P3R, P3I ) + DP(1) = P3R/P3 + DP(2) = -P3I/P3 + END IF +C +C Now compute the quantities v1, v2, v3 and y in (6.13) - (6.15), +C or (10.23) - (10.25). Care is taken to avoid overflows. +C + IF ( DISCR ) THEN + ALPHA = SQRT( ABS( ONE - ABSB )*( ONE + ABSB ) ) + ELSE + ALPHA = SQRT( ABS( TWO*E1 ) ) + END IF +C + SCALOC = ONE + IF( ALPHA.LT.SMIN ) THEN + ALPHA = SMIN + INFO = 1 + END IF + ABST = ABS( P1 ) + IF( ALPHA.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ALPHA ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + P1 = SCALOC*P1 + P2(1) = SCALOC*P2(1) + P2(2) = SCALOC*P2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + V1 = P1/ALPHA +C + IF ( DISCR ) THEN + G(1) = ( ONE - E1 )*( ONE + E1 ) + E2**2 + G(2) = -TWO*E1*E2 + ABSG = DLAPY2( G(1), G(2) ) + SCALOC = ONE + IF( ABSG.LT.SMIN ) THEN + ABSG = SMIN + INFO = 1 + END IF + TEMP(1) = SGN*ALPHA*P2(1) + V1*( E1*T(1) - E2*T(2) ) + TEMP(2) = SGN*ALPHA*P2(2) + V1*( E1*T(2) + E2*T(1) ) + ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) + IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSG ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + V1 = SCALOC*V1 + TEMP(1) = SCALOC*TEMP(1) + TEMP(2) = SCALOC*TEMP(2) + P1 = SCALOC*P1 + P2(1) = SCALOC*P2(1) + P2(2) = SCALOC*P2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + TEMP(1) = TEMP(1)/ABSG + TEMP(2) = TEMP(2)/ABSG +C + SCALOC = ONE + V2(1) = G(1)*TEMP(1) + G(2)*TEMP(2) + V2(2) = G(1)*TEMP(2) - G(2)*TEMP(1) + ABST = MAX( ABS( V2(1) ), ABS( V2(2) ) ) + IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSG ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + V1 = SCALOC*V1 + V2(1) = SCALOC*V2(1) + V2(2) = SCALOC*V2(2) + P1 = SCALOC*P1 + P2(1) = SCALOC*P2(1) + P2(2) = SCALOC*P2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + V2(1) = V2(1)/ABSG + V2(2) = V2(2)/ABSG +C + SCALOC = ONE + TEMP(1) = P1*T(1) - TWO*E2*P2(2) + TEMP(2) = P1*T(2) + TWO*E2*P2(1) + ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) + IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSG ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + TEMP(1) = SCALOC*TEMP(1) + TEMP(2) = SCALOC*TEMP(2) + V1 = SCALOC*V1 + V2(1) = SCALOC*V2(1) + V2(2) = SCALOC*V2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + TEMP(1) = TEMP(1)/ABSG + TEMP(2) = TEMP(2)/ABSG +C + SCALOC = ONE + Y(1) = -( G(1)*TEMP(1) + G(2)*TEMP(2) ) + Y(2) = -( G(1)*TEMP(2) - G(2)*TEMP(1) ) + ABST = MAX( ABS( Y(1) ), ABS( Y(2) ) ) + IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSG ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + Y(1) = SCALOC*Y(1) + Y(2) = SCALOC*Y(2) + V1 = SCALOC*V1 + V2(1) = SCALOC*V2(1) + V2(2) = SCALOC*V2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + Y(1) = Y(1)/ABSG + Y(2) = Y(2)/ABSG + ELSE +C + SCALOC = ONE + IF( ABSB.LT.SMIN ) THEN + ABSB = SMIN + INFO = 1 + END IF + TEMP(1) = SGN*ALPHA*P2(1) + V1*T(1) + TEMP(2) = SGN*ALPHA*P2(2) + V1*T(2) + ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) + IF( ABSB.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSB ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + V1 = SCALOC*V1 + TEMP(1) = SCALOC*TEMP(1) + TEMP(2) = SCALOC*TEMP(2) + P2(1) = SCALOC*P2(1) + P2(2) = SCALOC*P2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + TEMP(1) = TEMP(1)/( TWO*ABSB ) + TEMP(2) = TEMP(2)/( TWO*ABSB ) + SCALOC = ONE + V2(1) = -( E1*TEMP(1) + E2*TEMP(2) ) + V2(2) = -( E1*TEMP(2) - E2*TEMP(1) ) + ABST = MAX( ABS( V2(1) ), ABS( V2(2) ) ) + IF( ABSB.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSB ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + V1 = SCALOC*V1 + V2(1) = SCALOC*V2(1) + V2(2) = SCALOC*V2(2) + P2(1) = SCALOC*P2(1) + P2(2) = SCALOC*P2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + V2(1) = V2(1)/ABSB + V2(2) = V2(2)/ABSB + Y(1) = P2(1) - ALPHA*V2(1) + Y(2) = P2(2) - ALPHA*V2(2) + END IF +C + SCALOC = ONE + V3 = DLAPY3( P3, Y(1), Y(2) ) + IF( ALPHA.LT.ONE .AND. V3.GT.ONE ) THEN + IF( V3.GT.BIGNUM*ALPHA ) + $ SCALOC = ONE / V3 + END IF + IF( SCALOC.NE.ONE ) THEN + V1 = SCALOC*V1 + V2(1) = SCALOC*V2(1) + V2(2) = SCALOC*V2(2) + V3 = SCALOC*V3 + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + V3 = V3/ALPHA +C + IF ( LTRANS ) THEN +C +C Case op(M) = M'. +C +C Form X = conjg( Qhat' )*v11. +C + X11(1) = CSQ(1)*V3 + X11(2) = CSQ(2)*V3 + X21(1) = SNQ*V3 + X12(1) = CSQ(1)*V2(1) + CSQ(2)*V2(2) - SNQ*V1 + X12(2) = -CSQ(1)*V2(2) + CSQ(2)*V2(1) + X22(1) = CSQ(1)*V1 + SNQ*V2(1) + X22(2) = -CSQ(2)*V1 - SNQ*V2(2) +C +C Obtain u11 from the RQ-factorization of X. The conjugate of +C X22 should be taken. +C + X22(2) = -X22(2) + CALL SB03OV( X22, X21(1), CST, SNT ) + R(2,2) = X22(1) + R(1,2) = CST(1)*X12(1) - CST(2)*X12(2) + SNT*X11(1) + TEMPR = CST(1)*X11(1) + CST(2)*X11(2) - SNT*X12(1) + TEMPI = CST(1)*X11(2) - CST(2)*X11(1) - SNT*X12(2) + IF ( TEMPI.EQ.ZERO ) THEN + R(1,1) = ABS( TEMPR ) + DT(1) = SIGN( ONE, TEMPR ) + DT(2) = ZERO + ELSE + R(1,1) = DLAPY2( TEMPR, TEMPI ) + DT(1) = TEMPR/R(1,1) + DT(2) = -TEMPI/R(1,1) + END IF + ELSE +C +C Case op(M) = M. +C +C Now form X = v11*conjg( Qhat' ). +C + X11(1) = CSQ(1)*V1 - SNQ*V2(1) + X11(2) = -CSQ(2)*V1 + SNQ*V2(2) + X21(1) = -SNQ*V3 + X12(1) = CSQ(1)*V2(1) + CSQ(2)*V2(2) + SNQ*V1 + X12(2) = -CSQ(1)*V2(2) + CSQ(2)*V2(1) + X22(1) = CSQ(1)*V3 + X22(2) = CSQ(2)*V3 +C +C Obtain u11 from the QR-factorization of X. +C + CALL SB03OV( X11, X21(1), CST, SNT ) + R(1,1) = X11(1) + R(1,2) = CST(1)*X12(1) + CST(2)*X12(2) + SNT*X22(1) + TEMPR = CST(1)*X22(1) - CST(2)*X22(2) - SNT*X12(1) + TEMPI = CST(1)*X22(2) + CST(2)*X22(1) - SNT*X12(2) + IF ( TEMPI.EQ.ZERO ) THEN + R(2,2) = ABS( TEMPR ) + DT(1) = SIGN( ONE, TEMPR ) + DT(2) = ZERO + ELSE + R(2,2) = DLAPY2( TEMPR, TEMPI ) + DT(1) = TEMPR/R(2,2) + DT(2) = -TEMPI/R(2,2) + END IF + END IF +C +C The computations below are not needed when B and A are not +C useful. Compute delta, eta and gamma as in (6.21) or (10.26). +C + IF ( ( Y(1).EQ.ZERO ).AND.( Y(2).EQ.ZERO ) ) THEN + DELTA(1) = ZERO + DELTA(2) = ZERO + GAMMA(1) = ZERO + GAMMA(2) = ZERO + ETA = ALPHA + ELSE + DELTA(1) = Y(1)/V3 + DELTA(2) = Y(2)/V3 + GAMMA(1) = -ALPHA*DELTA(1) + GAMMA(2) = -ALPHA*DELTA(2) + ETA = P3/V3 + IF ( DISCR ) THEN + TEMPR = E1*DELTA(1) - E2*DELTA(2) + DELTA(2) = E1*DELTA(2) + E2*DELTA(1) + DELTA(1) = TEMPR + END IF + END IF +C + IF ( LTRANS ) THEN +C +C Case op(M) = M'. +C +C Find X = conjg( That' )*( inv( v11 )*s11hat*v11 ). +C ( Defer the scaling.) +C + X11(1) = CST(1)*E1 + CST(2)*E2 + X11(2) = -CST(1)*E2 + CST(2)*E1 + X21(1) = SNT*E1 + X21(2) = -SNT*E2 + X12(1) = SGN*( CST(1)*GAMMA(1) + CST(2)*GAMMA(2) ) - SNT*E1 + X12(2) = SGN*( -CST(1)*GAMMA(2) + CST(2)*GAMMA(1) ) - SNT*E2 + X22(1) = CST(1)*E1 + CST(2)*E2 + SGN*SNT*GAMMA(1) + X22(2) = CST(1)*E2 - CST(2)*E1 - SGN*SNT*GAMMA(2) +C +C Now find B = X*That. ( Include the scaling here.) +C + S(1,1) = CST(1)*X11(1) + CST(2)*X11(2) - SNT*X12(1) + TEMPR = CST(1)*X21(1) + CST(2)*X21(2) - SNT*X22(1) + TEMPI = CST(1)*X21(2) - CST(2)*X21(1) - SNT*X22(2) + S(2,1) = DT(1)*TEMPR - DT(2)*TEMPI + TEMPR = CST(1)*X12(1) - CST(2)*X12(2) + SNT*X11(1) + TEMPI = CST(1)*X12(2) + CST(2)*X12(1) + SNT*X11(2) + S(1,2) = DT(1)*TEMPR + DT(2)*TEMPI + S(2,2) = CST(1)*X22(1) - CST(2)*X22(2) + SNT*X21(1) +C +C Form X = ( inv( v11 )*p11 )*conjg( Phat' ). +C + TEMPR = DP(1)*ETA + TEMPI = -DP(2)*ETA + X11(1) = CSP(1)*TEMPR - CSP(2)*TEMPI + SNP*DELTA(1) + X11(2) = CSP(1)*TEMPI + CSP(2)*TEMPR - SNP*DELTA(2) + X21(1) = SNP*ALPHA + X12(1) = -SNP*TEMPR + CSP(1)*DELTA(1) - CSP(2)*DELTA(2) + X12(2) = -SNP*TEMPI - CSP(1)*DELTA(2) - CSP(2)*DELTA(1) + X22(1) = CSP(1)*ALPHA + X22(2) = -CSP(2)*ALPHA +C +C Finally form A = conjg( That' )*X. +C + TEMPR = CST(1)*X11(1) - CST(2)*X11(2) - SNT*X21(1) + TEMPI = CST(1)*X22(2) + CST(2)*X22(1) + A(1,1) = DT(1)*TEMPR + DT(2)*TEMPI + TEMPR = CST(1)*X12(1) - CST(2)*X12(2) - SNT*X22(1) + TEMPI = CST(1)*X12(2) + CST(2)*X12(1) - SNT*X22(1) + A(1,2) = DT(1)*TEMPR + DT(2)*TEMPI + A(2,1) = ZERO + A(2,2) = CST(1)*X22(1) + CST(2)*X22(2) + SNT*X12(1) + ELSE +C +C Case op(M) = M. +C +C Find X = That*( v11*s11hat*inv( v11 ) ). ( Defer the scaling.) +C + X11(1) = CST(1)*E1 + CST(2)*E2 + X11(2) = CST(1)*E2 - CST(2)*E1 + X21(1) = -SNT*E1 + X21(2) = -SNT*E2 + X12(1) = SGN*( CST(1)*GAMMA(1) - CST(2)*GAMMA(2) ) + SNT*E1 + X12(2) = SGN*( -CST(1)*GAMMA(2) - CST(2)*GAMMA(1) ) - SNT*E2 + X22(1) = CST(1)*E1 + CST(2)*E2 - SGN*SNT*GAMMA(1) + X22(2) = -CST(1)*E2 + CST(2)*E1 + SGN*SNT*GAMMA(2) +C +C Now find B = X*conjg( That' ). ( Include the scaling here.) +C + S(1,1) = CST(1)*X11(1) - CST(2)*X11(2) + SNT*X12(1) + TEMPR = CST(1)*X21(1) - CST(2)*X21(2) + SNT*X22(1) + TEMPI = CST(1)*X21(2) + CST(2)*X21(1) + SNT*X22(2) + S(2,1) = DT(1)*TEMPR - DT(2)*TEMPI + TEMPR = CST(1)*X12(1) + CST(2)*X12(2) - SNT*X11(1) + TEMPI = CST(1)*X12(2) - CST(2)*X12(1) - SNT*X11(2) + S(1,2) = DT(1)*TEMPR + DT(2)*TEMPI + S(2,2) = CST(1)*X22(1) + CST(2)*X22(2) - SNT*X21(1) +C +C Form X = Phat*( p11*inv( v11 ) ). +C + TEMPR = DP(1)*ETA + TEMPI = -DP(2)*ETA + X11(1) = CSP(1)*ALPHA + X11(2) = CSP(2)*ALPHA + X21(1) = SNP*ALPHA + X12(1) = CSP(1)*DELTA(1) + CSP(2)*DELTA(2) - SNP*TEMPR + X12(2) = -CSP(1)*DELTA(2) + CSP(2)*DELTA(1) - SNP*TEMPI + X22(1) = CSP(1)*TEMPR + CSP(2)*TEMPI + SNP*DELTA(1) + X22(2) = CSP(1)*TEMPI - CSP(2)*TEMPR - SNP*DELTA(2) +C +C Finally form A = X*conjg( That' ). +C + A(1,1) = CST(1)*X11(1) - CST(2)*X11(2) + SNT*X12(1) + A(2,1) = ZERO + A(1,2) = CST(1)*X12(1) + CST(2)*X12(2) - SNT*X11(1) + TEMPR = CST(1)*X22(1) + CST(2)*X22(2) - SNT*X21(1) + TEMPI = CST(1)*X22(2) - CST(2)*X22(1) + A(2,2) = DT(1)*TEMPR + DT(2)*TEMPI + END IF +C + IF( SCALE.NE.ONE ) THEN + A(1,1) = SCALE*A(1,1) + A(1,2) = SCALE*A(1,2) + A(2,2) = SCALE*A(2,2) + END IF +C + RETURN +C *** Last line of SB03OY *** + END diff --git a/mex/sources/libslicot/SB03PD.f b/mex/sources/libslicot/SB03PD.f new file mode 100644 index 000000000..8cef1572f --- /dev/null +++ b/mex/sources/libslicot/SB03PD.f @@ -0,0 +1,410 @@ + SUBROUTINE SB03PD( JOB, FACT, TRANA, N, A, LDA, U, LDU, C, LDC, + $ SCALE, SEPD, FERR, WR, WI, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the real discrete Lyapunov matrix equation +C +C op(A)'*X*op(A) - X = scale*C +C +C and/or estimate the quantity, called separation, +C +C sepd(op(A),op(A)') = min norm(op(A)'*X*op(A) - X)/norm(X) +C +C where op(A) = A or A' (A**T) and C is symmetric (C = C'). +C (A' denotes the transpose of the matrix A.) A is N-by-N, the right +C hand side C and the solution X are N-by-N, and scale is an output +C scale factor, set less than or equal to 1 to avoid overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'X': Compute the solution only; +C = 'S': Compute the separation only; +C = 'B': Compute both the solution and the separation. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, A and U contain the factors from the +C real Schur factorization of the matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in A and U. +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X, and C. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. If FACT = 'F', then A contains +C an upper quasi-triangular matrix in Schur canonical form. +C On exit, if INFO = 0 or INFO = N+1, the leading N-by-N +C part of this array contains the upper quasi-triangular +C matrix in Schur canonical form from the Shur factorization +C of A. The contents of array A is not modified if +C FACT = 'F'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,N) +C If FACT = 'F', then U is an input argument and on entry +C it must contain the orthogonal matrix U from the real +C Schur factorization of A. +C If FACT = 'N', then U is an output argument and on exit, +C if INFO = 0 or INFO = N+1, it contains the orthogonal +C N-by-N matrix from the real Schur factorization of A. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry with JOB = 'X' or 'B', the leading N-by-N part of +C this array must contain the symmetric matrix C. +C On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1, +C the leading N-by-N part of C has been overwritten by the +C symmetric solution matrix X. +C If JOB = 'S', C is not referenced. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= 1, if JOB = 'S'; +C LDC >= MAX(1,N), otherwise. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C SEPD (output) DOUBLE PRECISION +C If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1, +C SEPD contains the estimate in the 1-norm of +C sepd(op(A),op(A)'). +C If JOB = 'X' or N = 0, SEPD is not referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains +C an estimated forward error bound for the solution X. +C If XTRUE is the true solution, FERR bounds the relative +C error in the computed solution, measured in the Frobenius +C norm: norm(X - XTRUE)/norm(XTRUE). +C If JOB = 'X' or JOB = 'S', FERR is not referenced. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI +C contain the real and imaginary parts, respectively, of the +C eigenvalues of A. +C If FACT = 'F', WR and WI are not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C This array is not referenced if JOB = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 1 and +C If JOB = 'X' then +C If FACT = 'F', LDWORK >= MAX(N*N,2*N); +C If FACT = 'N', LDWORK >= MAX(N*N,3*N). +C If JOB = 'S' or JOB = 'B' then +C LDWORK >= 2*N*N + 2*N. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, the QR algorithm failed to compute all +C the eigenvalues (see LAPACK Library routine DGEES); +C elements i+1:n of WR and WI contain eigenvalues +C which have converged, and A contains the partially +C converged Schur form; +C = N+1: if matrix A has almost reciprocal eigenvalues; +C perturbed values were used to solve the equation +C (but the matrix A is unchanged). +C +C METHOD +C +C After reducing matrix A to real Schur canonical form (if needed), +C a discrete-time version of the Bartels-Stewart algorithm is used. +C A set of equivalent linear algebraic systems of equations of order +C at most four are formed and solved using Gaussian elimination with +C complete pivoting. +C +C REFERENCES +C +C [1] Barraud, A.Y. T +C A numerical algorithm to solve A XA - X = Q. +C IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977. +C +C [2] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C FURTHER COMMENTS +C +C SEPD is defined as +C +C sepd( op(A), op(A)' ) = sigma_min( T ) +C +C where sigma_min(T) is the smallest singular value of the +C N*N-by-N*N matrix +C +C T = kprod( op(A)', op(A)' ) - I(N**2). +C +C I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the +C Kronecker product. The program estimates sigma_min(T) by the +C reciprocal of an estimate of the 1-norm of inverse(T). The true +C reciprocal 1-norm of inverse(T) cannot differ from sigma_min(T) by +C more than a factor of N. +C +C When SEPD is small, small changes in A, C can cause large changes +C in the solution of the equation. An approximate bound on the +C maximum relative error in the computed solution is +C +C EPS * norm(A)**2 / SEPD +C +C where EPS is the machine precision. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Supersedes Release 2.0 routine MB03AD by Control Systems Research +C Group, Kingston Polytechnic, United Kingdom, October 1982. +C Based on DGELPD by P. Petkov, Tech. University of Sofia, September +C 1993. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER FACT, JOB, TRANA + INTEGER INFO, LDA, LDC, LDU, LDWORK, N + DOUBLE PRECISION FERR, SCALE, SEPD +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), + $ U( LDU, * ), WI( * ), WR( * ) +C .. +C .. Local Scalars .. + LOGICAL NOFACT, NOTA, WANTBH, WANTSP, WANTX + CHARACTER NOTRA, UPLO + INTEGER I, IERR, KASE, LWA, MINWRK, SDIM + DOUBLE PRECISION EST, SCALEF +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAMCH, DLANHS + EXTERNAL DLAMCH, DLANHS, LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DLACON, MB01RD, SB03MX, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + WANTX = LSAME( JOB, 'X' ) + WANTSP = LSAME( JOB, 'S' ) + WANTBH = LSAME( JOB, 'B' ) + NOFACT = LSAME( FACT, 'N' ) + NOTA = LSAME( TRANA, 'N' ) +C + INFO = 0 + IF( .NOT.WANTBH .AND. .NOT.WANTSP .AND. .NOT.WANTX ) THEN + INFO = -1 + ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOTA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. + $ .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( WANTSP .AND. LDC.LT.1 .OR. + $ .NOT.WANTSP .AND. LDC.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF +C +C Compute workspace. +C + IF( WANTX ) THEN + IF( NOFACT ) THEN + MINWRK = MAX( N*N, 3*N ) + ELSE + MINWRK = MAX( N*N, 2*N ) + END IF + ELSE + MINWRK = 2*N*N + 2*N + END IF + IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN + INFO = -18 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + SCALE = ONE + IF( WANTBH ) + $ FERR = ZERO + DWORK(1) = ONE + RETURN + END IF +C + LWA = 0 +C + IF( NOFACT ) THEN +C +C Compute the Schur factorization of A. +C Workspace: need 3*N; +C prefer larger. +C + CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + IF( INFO.GT.0 ) + $ RETURN + LWA = INT( DWORK( 1 ) ) + END IF +C + IF( .NOT.WANTSP ) THEN +C +C Transform the right-hand side. +C Workspace: need N*N. +C + UPLO = 'U' + CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, C, LDC, U, + $ LDU, C, LDC, DWORK, LDWORK, INFO ) +C + DO 10 I = 2, N + CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) + 10 CONTINUE +C +C Solve the transformed equation. +C Workspace: 2*N. +C + CALL SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) + IF( INFO.GT.0 ) + $ INFO = N + 1 +C +C Transform back the solution. +C + CALL MB01RD( UPLO, 'No transpose', N, N, ZERO, ONE, C, LDC, U, + $ LDU, C, LDC, DWORK, LDWORK, INFO ) +C + DO 20 I = 2, N + CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) + 20 CONTINUE +C + END IF +C + IF( .NOT.WANTX ) THEN +C +C Estimate sepd(op(A),op(A)'). +C Workspace: 2*N*N + 2*N. +C + IF( NOTA ) THEN + NOTRA = 'T' + ELSE + NOTRA = 'N' + END IF +C + EST = ZERO + KASE = 0 +C REPEAT + 30 CONTINUE + CALL DLACON( N*N, DWORK( N*N+1 ), DWORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.1 ) THEN + CALL SB03MX( TRANA, N, A, LDA, DWORK, N, SCALEF, + $ DWORK( 2*N*N + 1 ), IERR ) + ELSE + CALL SB03MX( NOTRA, N, A, LDA, DWORK, N, SCALEF, + $ DWORK( 2*N*N + 1 ), IERR ) + END IF + GO TO 30 + END IF +C UNTIL KASE = 0 +C + SEPD = SCALEF / EST +C + IF( WANTBH ) THEN +C +C Compute the estimate of the relative error. +C + FERR = DLAMCH( 'Precision' )* + $ DLANHS( 'Frobenius', N, A, LDA, DWORK )**2 / SEPD + END IF + END IF +C + DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) ) +C + RETURN +C *** Last line of SB03PD *** + END diff --git a/mex/sources/libslicot/SB03QD.f b/mex/sources/libslicot/SB03QD.f new file mode 100644 index 000000000..5f8ccf886 --- /dev/null +++ b/mex/sources/libslicot/SB03QD.f @@ -0,0 +1,676 @@ + SUBROUTINE SB03QD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, + $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, + $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the conditioning and compute an error bound on the +C solution of the real continuous-time Lyapunov matrix equation +C +C op(A)'*X + X*op(A) = scale*C +C +C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The +C matrix A is N-by-N, the right hand side C and the solution X are +C N-by-N symmetric matrices, and scale is a given scale factor. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'C': Compute the reciprocal condition number only; +C = 'E': Compute the error bound only; +C = 'B': Compute both the reciprocal condition number and +C the error bound. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, T and U (if LYAPUN = 'O') contain the +C factors from the real Schur factorization of the +C matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in T and U (if +C LYAPUN = 'O'). +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C UPLO CHARACTER*1 +C Specifies which part of the symmetric matrix C is to be +C used, as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part. +C +C LYAPUN CHARACTER*1 +C Specifies whether or not the original Lyapunov equations +C should be solved in the iterative estimation process, +C as follows: +C = 'O': Solve the original Lyapunov equations, updating +C the right-hand sides and solutions with the +C matrix U, e.g., X <-- U'*X*U; +C = 'R': Solve reduced Lyapunov equations only, without +C updating the right-hand sides and solutions. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X and C. N >= 0. +C +C SCALE (input) DOUBLE PRECISION +C The scale factor, scale, set by a Lyapunov solver. +C 0 <= SCALE <= 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of +C this array must contain the original matrix A. +C If FACT = 'F' and LYAPUN = 'R', A is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O'; +C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. +C +C T (input/output) DOUBLE PRECISION array, dimension +C (LDT,N) +C If FACT = 'F', then on entry the leading N-by-N upper +C Hessenberg part of this array must contain the upper +C quasi-triangular matrix T in Schur canonical form from a +C Schur factorization of A. +C If FACT = 'N', then this array need not be set on input. +C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the +C leading N-by-N upper Hessenberg part of this array +C contains the upper quasi-triangular matrix T in Schur +C canonical form from a Schur factorization of A. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= MAX(1,N). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,N) +C If LYAPUN = 'O' and FACT = 'F', then U is an input +C argument and on entry, the leading N-by-N part of this +C array must contain the orthogonal matrix U from a real +C Schur factorization of A. +C If LYAPUN = 'O' and FACT = 'N', then U is an output +C argument and on exit, if INFO = 0 or INFO = N+1, it +C contains the orthogonal N-by-N matrix from a real Schur +C factorization of A. +C If LYAPUN = 'R', the array U is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= 1, if LYAPUN = 'R'; +C LDU >= MAX(1,N), if LYAPUN = 'O'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C If UPLO = 'U', the leading N-by-N upper triangular part of +C this array must contain the upper triangular part of the +C matrix C of the original Lyapunov equation (with +C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov +C equation (with matrix T), if LYAPUN = 'R'. +C If UPLO = 'L', the leading N-by-N lower triangular part of +C this array must contain the lower triangular part of the +C matrix C of the original Lyapunov equation (with +C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov +C equation (with matrix T), if LYAPUN = 'R'. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,N). +C +C X (input) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array must contain the +C symmetric solution matrix X of the original Lyapunov +C equation (with matrix A), if LYAPUN = 'O', or of the +C reduced Lyapunov equation (with matrix T), if +C LYAPUN = 'R'. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= MAX(1,N). +C +C SEP (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'B', the estimated quantity +C sep(op(A),-op(A)'). +C If N = 0, or X = 0, or JOB = 'E', SEP is not referenced. +C +C RCOND (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal +C condition number of the continuous-time Lyapunov equation. +C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. +C If JOB = 'E', RCOND is not referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'E' or JOB = 'B', an estimated forward error +C bound for the solution X. If XTRUE is the true solution, +C FERR bounds the magnitude of the largest entry in +C (X - XTRUE) divided by the magnitude of the largest entry +C in X. +C If N = 0 or X = 0, FERR is set to 0. +C If JOB = 'C', FERR is not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C If JOB = 'C', then +C LDWORK >= MAX(1,2*N*N), if FACT = 'F'; +C LDWORK >= MAX(1,2*N*N,5*N), if FACT = 'N'. +C If JOB = 'E', or JOB = 'B', and LYAPUN = 'O', then +C LDWORK >= MAX(1,3*N*N), if FACT = 'F'; +C LDWORK >= MAX(1,3*N*N,5*N), if FACT = 'N'. +C If JOB = 'E', or JOB = 'B', and LYAPUN = 'R', then +C LDWORK >= MAX(1,3*N*N+N-1), if FACT = 'F'; +C LDWORK >= MAX(1,3*N*N+N-1,5*N), if FACT = 'N'. +C For optimum performance LDWORK should sometimes be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, i <= N, the QR algorithm failed to +C complete the reduction to Schur canonical form (see +C LAPACK Library routine DGEES); on exit, the matrix +C T(i+1:N,i+1:N) contains the partially converged +C Schur form, and DWORK(i+1:N) and DWORK(N+i+1:2*N) +C contain the real and imaginary parts, respectively, +C of the converged eigenvalues; this error is unlikely +C to appear; +C = N+1: if the matrices T and -T' have common or very +C close eigenvalues; perturbed values were used to +C solve Lyapunov equations, but the matrix T, if given +C (for FACT = 'F'), is unchanged. +C +C METHOD +C +C The condition number of the continuous-time Lyapunov equation is +C estimated as +C +C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), +C +C where Omega and Theta are linear operators defined by +C +C Omega(W) = op(A)'*W + W*op(A), +C Theta(W) = inv(Omega(op(W)'*X + X*op(W))). +C +C The routine estimates the quantities +C +C sep(op(A),-op(A)') = 1 / norm(inv(Omega)) +C +C and norm(Theta) using 1-norm condition estimators. +C +C The forward error bound is estimated using a practical error bound +C similar to the one proposed in [1]. +C +C REFERENCES +C +C [1] Higham, N.J. +C Perturbation theory and backward error for AX-XB=C. +C BIT, vol. 33, pp. 124-136, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C The accuracy of the estimates obtained depends on the solution +C accuracy and on the properties of the 1-norm estimator. +C +C FURTHER COMMENTS +C +C The option LYAPUN = 'R' may occasionally produce slightly worse +C or better estimates, and it is much faster than the option 'O'. +C When SEP is computed and it is zero, the routine returns +C immediately, with RCOND and FERR (if requested) set to 0 and 1, +C respectively. In this case, the equation is singular. +C +C CONTRIBUTORS +C +C P. Petkov, Tech. University of Sofia, December 1998. +C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, March 2003. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D0, + $ THREE = 3.0D0 ) +C .. +C .. Scalar Arguments .. + CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO + INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N + DOUBLE PRECISION FERR, RCOND, SCALE, SEP +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), + $ T( LDT, * ), U( LDU, * ), X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL JOBB, JOBC, JOBE, LOWER, NOFACT, NOTRNA, + $ UPDATE + CHARACTER SJOB, TRANAT + INTEGER I, IABS, IRES, IWRK, IXBS, J, JJ, JX, LDW, NN, + $ SDIM, WRKOPT + DOUBLE PRECISION ANORM, CNORM, DENOM, EPS, EPSN, TEMP, THNORM, + $ TMAX, XANORM, XNORM +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DGEES, DLACPY, DLASET, DSYR2K, MB01UD, + $ MB01UW, SB03QX, SB03QY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + JOBC = LSAME( JOB, 'C' ) + JOBE = LSAME( JOB, 'E' ) + JOBB = LSAME( JOB, 'B' ) + NOFACT = LSAME( FACT, 'N' ) + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + UPDATE = LSAME( LYAPUN, 'O' ) +C + NN = N*N + IF( JOBC ) THEN + LDW = 2*NN + ELSE + LDW = 3*NN + END IF + IF( .NOT.( JOBC .OR. UPDATE ) ) + $ LDW = LDW + N - 1 +C + INFO = 0 + IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN + INFO = -1 + ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. + $ LSAME( TRANA, 'C' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) THEN + INFO = -7 + ELSE IF( LDA.LT.1 .OR. + $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDWORK.LT.1 .OR. + $ ( LDWORK.LT.LDW .AND. .NOT.NOFACT ) .OR. + $ ( LDWORK.LT.MAX( LDW, 5*N ) .AND. NOFACT ) ) THEN + INFO = -23 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + IF( .NOT.JOBE ) + $ RCOND = ONE + IF( .NOT.JOBC ) + $ FERR = ZERO + DWORK( 1 ) = ONE + RETURN + END IF +C +C Compute the 1-norm of the matrix X. +C + XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK ) + IF( XNORM.EQ.ZERO ) THEN +C +C The solution is zero. +C + IF( .NOT.JOBE ) + $ RCOND = ZERO + IF( .NOT.JOBC ) + $ FERR = ZERO + DWORK( 1 ) = DBLE( N ) + RETURN + END IF +C +C Compute the 1-norm of A or T. +C + IF( NOFACT .OR. UPDATE ) THEN + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) + ELSE + ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) + END IF +C +C For the special case A = 0, set SEP and RCOND to 0. +C For the special case A = I, set SEP to 2 and RCOND to 1. +C A quick test is used in general. +C + IF( ANORM.EQ.ONE ) THEN + IF( NOFACT .OR. UPDATE ) THEN + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) + ELSE + CALL DLACPY( 'Full', N, N, T, LDT, DWORK, N ) + IF( N.GT.2 ) + $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, DWORK( 3 ), + $ N ) + END IF + DWORK( NN+1 ) = ONE + CALL DAXPY( N, -ONE, DWORK( NN+1 ), 0, DWORK, N+1 ) + IF( DLANGE( 'Max', N, N, DWORK, N, DWORK ).EQ.ZERO ) THEN + IF( .NOT.JOBE ) THEN + SEP = TWO + RCOND = ONE + END IF + IF( JOBC ) THEN + DWORK( 1 ) = DBLE( NN + 1 ) + RETURN + ELSE +C +C Set FERR for the special case A = I. +C + CALL DLACPY( UPLO, N, N, X, LDX, DWORK, N ) +C + IF( LOWER ) THEN + DO 10 J = 1, N + CALL DAXPY( N-J+1, -SCALE/TWO, C( J, J ), 1, + $ DWORK( (J-1)*N+J ), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, N + CALL DAXPY( J, -SCALE/TWO, C( 1, J ), 1, + $ DWORK( (J-1)*N+1 ), 1 ) + 20 CONTINUE + END IF +C + FERR = MIN( ONE, DLANSY( '1-norm', UPLO, N, DWORK, N, + $ DWORK( NN+1 ) ) / XNORM ) + DWORK( 1 ) = DBLE( NN + N ) + RETURN + END IF + END IF +C + ELSE IF( ANORM.EQ.ZERO ) THEN + IF( .NOT.JOBE ) THEN + SEP = ZERO + RCOND = ZERO + END IF + IF( .NOT.JOBC ) + $ FERR = ONE + DWORK( 1 ) = DBLE( N ) + RETURN + END IF +C +C General case. +C + CNORM = DLANSY( '1-norm', UPLO, N, C, LDC, DWORK ) +C +C Workspace usage. +C + IABS = 0 + IXBS = IABS + NN + IRES = IXBS + NN + IWRK = IRES + NN + WRKOPT = 0 +C + IF( NOFACT ) THEN +C +C Compute the Schur factorization of A, A = U*T*U'. +C Workspace: need 5*N; +C prefer larger. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) + IF( UPDATE ) THEN + SJOB = 'V' + ELSE + SJOB = 'N' + END IF + CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, + $ DWORK( 1 ), DWORK( N+1 ), U, LDU, DWORK( 2*N+1 ), + $ LDWORK-2*N, BWORK, INFO ) + IF( INFO.GT.0 ) + $ RETURN + WRKOPT = INT( DWORK( 2*N+1 ) ) + 2*N + END IF +C + IF( .NOT.JOBE ) THEN +C +C Estimate sep(op(A),-op(A)') = sep(op(T),-op(T)') and +C norm(Theta). +C Workspace 2*N*N. +C + CALL SB03QY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX, + $ SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) +C + WRKOPT = MAX( WRKOPT, 2*NN ) +C +C Return if the equation is singular. +C + IF( SEP.EQ.ZERO ) THEN + RCOND = ZERO + IF( JOBB ) + $ FERR = ONE + DWORK( 1 ) = DBLE( WRKOPT ) + RETURN + END IF +C +C Estimate the reciprocal condition number. +C + TMAX = MAX( SEP, XNORM, ANORM ) + IF( TMAX.LE.ONE ) THEN + TEMP = SEP*XNORM + DENOM = ( SCALE*CNORM ) + ( SEP*ANORM )*THNORM + ELSE + TEMP = ( SEP / TMAX )*( XNORM / TMAX ) + DENOM = ( ( SCALE / TMAX )*( CNORM / TMAX ) ) + + $ ( ( SEP / TMAX )*( ANORM / TMAX ) )*THNORM + END IF + IF( TEMP.GE.DENOM ) THEN + RCOND = ONE + ELSE + RCOND = TEMP / DENOM + END IF + END IF +C + IF( .NOT.JOBC ) THEN +C +C Form a triangle of the residual matrix +C R = op(A)'*X + X*op(A) - scale*C, or +C R = op(T)'*X + X*op(T) - scale*C, +C exploiting the symmetry. +C Workspace 3*N*N. +C + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +C + IF( UPDATE ) THEN +C + CALL DLACPY( UPLO, N, N, C, LDC, DWORK( IRES+1 ), N ) + CALL DSYR2K( UPLO, TRANAT, N, N, ONE, A, LDA, X, LDX, + $ -SCALE, DWORK( IRES+1 ), N ) + ELSE + CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, + $ DWORK( IRES+1 ), N, INFO ) + JJ = IRES + 1 + IF( LOWER ) THEN + DO 30 J = 1, N + CALL DAXPY( N-J+1, ONE, DWORK( JJ ), N, DWORK( JJ ), + $ 1 ) + CALL DAXPY( N-J+1, -SCALE, C( J, J ), 1, DWORK( JJ ), + $ 1 ) + JJ = JJ + N + 1 + 30 CONTINUE + ELSE + DO 40 J = 1, N + CALL DAXPY( J, ONE, DWORK( IRES+J ), N, DWORK( JJ ), + $ 1 ) + CALL DAXPY( J, -SCALE, C( 1, J ), 1, DWORK( JJ ), 1 ) + JJ = JJ + N + 40 CONTINUE + END IF + END IF +C + WRKOPT = MAX( WRKOPT, 3*NN ) +C +C Get the machine precision. +C + EPS = DLAMCH( 'Epsilon' ) + EPSN = EPS*DBLE( N + 3 ) + TEMP = EPS*THREE*SCALE +C +C Add to abs(R) a term that takes account of rounding errors in +C forming R: +C abs(R) := abs(R) + EPS*(3*scale*abs(C) + +C (n+3)*(abs(op(A))'*abs(X) + abs(X)*abs(op(A)))), or +C abs(R) := abs(R) + EPS*(3*scale*abs(C) + +C (n+3)*(abs(op(T))'*abs(X) + abs(X)*abs(op(T)))), +C where EPS is the machine precision. +C + DO 60 J = 1, N + DO 50 I = 1, N + DWORK( IXBS+(J-1)*N+I ) = ABS( X( I, J ) ) + 50 CONTINUE + 60 CONTINUE +C + IF( LOWER ) THEN + DO 80 J = 1, N + DO 70 I = J, N + DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( C( I, J ) ) + + $ ABS( DWORK( IRES+(J-1)*N+I ) ) + 70 CONTINUE + 80 CONTINUE + ELSE + DO 100 J = 1, N + DO 90 I = 1, J + DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( C( I, J ) ) + + $ ABS( DWORK( IRES+(J-1)*N+I ) ) + 90 CONTINUE + 100 CONTINUE + END IF +C + IF( UPDATE ) THEN +C +C Workspace 3*N*N. +C + DO 120 J = 1, N + DO 110 I = 1, N + DWORK( IABS+(J-1)*N+I ) = ABS( A( I, J ) ) + 110 CONTINUE + 120 CONTINUE +C + CALL DSYR2K( UPLO, TRANAT, N, N, EPSN, DWORK( IABS+1 ), N, + $ DWORK( IXBS+1 ), N, ONE, DWORK( IRES+1 ), N ) + ELSE +C +C Workspace 3*N*N + N - 1. +C + DO 140 J = 1, N + DO 130 I = 1, MIN( J+1, N ) + DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) + 130 CONTINUE + 140 CONTINUE +C + CALL MB01UW( 'Left', TRANAT, N, N, EPSN, DWORK( IABS+1 ), + $ N, DWORK( IXBS+1), N, DWORK( IWRK+1 ), + $ LDWORK-IWRK, INFO ) + JJ = IRES + 1 + JX = IXBS + 1 + IF( LOWER ) THEN + DO 150 J = 1, N + CALL DAXPY( N-J+1, ONE, DWORK( JX ), N, DWORK( JX ), + $ 1 ) + CALL DAXPY( N-J+1, ONE, DWORK( JX ), 1, DWORK( JJ ), + $ 1 ) + JJ = JJ + N + 1 + JX = JX + N + 1 + 150 CONTINUE + ELSE + DO 160 J = 1, N + CALL DAXPY( J, ONE, DWORK( IXBS+J ), N, DWORK( JX ), + $ 1 ) + CALL DAXPY( J, ONE, DWORK( JX ), 1, DWORK( JJ ), 1 ) + JJ = JJ + N + JX = JX + N + 160 CONTINUE + END IF +C + WRKOPT = MAX( WRKOPT, 3*NN + N - 1 ) + END IF +C +C Compute forward error bound, using matrix norm estimator. +C Workspace 3*N*N. +C + XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) +C + CALL SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, + $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK, IRES, + $ INFO ) + END IF +C + DWORK( 1 ) = DBLE( WRKOPT ) + RETURN +C +C *** Last line of SB03QD *** + END diff --git a/mex/sources/libslicot/SB03QX.f b/mex/sources/libslicot/SB03QX.f new file mode 100644 index 000000000..255ca13a0 --- /dev/null +++ b/mex/sources/libslicot/SB03QX.f @@ -0,0 +1,394 @@ + SUBROUTINE SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, + $ R, LDR, FERR, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate a forward error bound for the solution X of a real +C continuous-time Lyapunov matrix equation, +C +C op(A)'*X + X*op(A) = C, +C +C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The +C matrix A, the right hand side C, and the solution X are N-by-N. +C An absolute residual matrix, which takes into account the rounding +C errors in forming it, is given in the array R. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C UPLO CHARACTER*1 +C Specifies which part of the symmetric matrix R is to be +C used, as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part. +C +C LYAPUN CHARACTER*1 +C Specifies whether or not the original Lyapunov equations +C should be solved, as follows: +C = 'O': Solve the original Lyapunov equations, updating +C the right-hand sides and solutions with the +C matrix U, e.g., X <-- U'*X*U; +C = 'R': Solve reduced Lyapunov equations only, without +C updating the right-hand sides and solutions. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and R. N >= 0. +C +C XANORM (input) DOUBLE PRECISION +C The absolute (maximal) norm of the symmetric solution +C matrix X of the Lyapunov equation. XANORM >= 0. +C +C T (input) DOUBLE PRECISION array, dimension (LDT,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain the upper quasi-triangular matrix T in Schur +C canonical form from a Schur factorization of A. +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,N). +C +C U (input) DOUBLE PRECISION array, dimension (LDU,N) +C The leading N-by-N part of this array must contain the +C orthogonal matrix U from a real Schur factorization of A. +C If LYAPUN = 'R', the array U is not referenced. +C +C LDU INTEGER +C The leading dimension of array U. +C LDU >= 1, if LYAPUN = 'R'; +C LDU >= MAX(1,N), if LYAPUN = 'O'. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) +C On entry, if UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular part of the absolute residual matrix R, with +C bounds on rounding errors added. +C On entry, if UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular part of the absolute residual matrix R, with +C bounds on rounding errors added. +C On exit, the leading N-by-N part of this array contains +C the symmetric absolute residual matrix R (with bounds on +C rounding errors added), fully stored. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C FERR (output) DOUBLE PRECISION +C An estimated forward error bound for the solution X. +C If XTRUE is the true solution, FERR bounds the magnitude +C of the largest entry in (X - XTRUE) divided by the +C magnitude of the largest entry in X. +C If N = 0 or XANORM = 0, FERR is set to 0, without any +C calculations. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 2*N*N. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = N+1: if the matrices T and -T' have common or very +C close eigenvalues; perturbed values were used to +C solve Lyapunov equations (but the matrix T is +C unchanged). +C +C METHOD +C +C The forward error bound is estimated using a practical error bound +C similar to the one proposed in [1], based on the 1-norm estimator +C in [2]. +C +C REFERENCES +C +C [1] Higham, N.J. +C Perturbation theory and backward error for AX-XB=C. +C BIT, vol. 33, pp. 124-136, 1993. +C +C [2] Higham, N.J. +C FORTRAN codes for estimating the one-norm of a real or +C complex matrix, with applications to condition estimation. +C ACM Trans. Math. Softw., 14, pp. 381-396, 1988. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C FURTHER COMMENTS +C +C The option LYAPUN = 'R' may occasionally produce slightly worse +C or better estimates, and it is much faster than the option 'O'. +C The routine can be also used as a final step in estimating a +C forward error bound for the solution of a continuous-time +C algebraic matrix Riccati equation. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Romania, +C Oct. 1998. Partly based on DGLSVX (and then SB03QD) by P. Petkov, +C Tech. University of Sofia, March 1998 (and December 1998). +C +C REVISIONS +C +C February 6, 1999, V. Sima, Katholieke Univ. Leuven, Belgium. +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER LYAPUN, TRANA, UPLO + INTEGER INFO, LDR, LDT, LDU, LDWORK, N + DOUBLE PRECISION FERR, XANORM +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION DWORK( * ), R( LDR, * ), T( LDT, * ), + $ U( LDU, * ) +C .. +C .. Local Scalars .. + LOGICAL LOWER, NOTRNA, UPDATE + CHARACTER TRANAT, UPLOW + INTEGER I, IJ, INFO2, ITMP, J, KASE, NN + DOUBLE PRECISION EST, SCALE, TEMP +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLANSY + EXTERNAL DLANSY, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DLACON, DSCAL, MA02ED, MB01RU, SB03MY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + NOTRNA = LSAME( TRANA, 'N' ) + UPDATE = LSAME( LYAPUN, 'O' ) +C + NN = N*N + INFO = 0 + IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. + $ LSAME( TRANA, 'C' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) + $ THEN + INFO = -2 + ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( XANORM.LT.ZERO ) THEN + INFO = -5 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN + INFO = -9 + ELSE IF( LDR.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.2*NN ) THEN + INFO = -15 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03QX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + FERR = ZERO + IF( N.EQ.0 .OR. XANORM.EQ.ZERO ) + $ RETURN +C + ITMP = NN + 1 +C + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +C +C Fill in the remaining triangle of the symmetric residual matrix. +C + CALL MA02ED( UPLO, N, R, LDR ) +C + KASE = 0 +C +C REPEAT + 10 CONTINUE + CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +C +C Select the triangular part of symmetric matrix to be used. +C + IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) + $ .GE. + $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) + $ ) THEN + UPLOW = 'U' + LOWER = .FALSE. + ELSE + UPLOW = 'L' + LOWER = .TRUE. + END IF +C + IF( KASE.EQ.2 ) THEN + IJ = 0 + IF( LOWER ) THEN +C +C Scale the lower triangular part of symmetric matrix +C by the residual matrix. +C + DO 30 J = 1, N + DO 20 I = J, N + IJ = IJ + 1 + DWORK( IJ ) = DWORK( IJ )*R( I, J ) + 20 CONTINUE + IJ = IJ + J + 30 CONTINUE + ELSE +C +C Scale the upper triangular part of symmetric matrix +C by the residual matrix. +C + DO 50 J = 1, N + DO 40 I = 1, J + IJ = IJ + 1 + DWORK( IJ ) = DWORK( IJ )*R( I, J ) + 40 CONTINUE + IJ = IJ + N - J + 50 CONTINUE + END IF + END IF +C + IF( UPDATE ) THEN +C +C Transform the right-hand side: RHS := U'*RHS*U. +C + CALL MB01RU( UPLOW, 'Transpose', N, N, ZERO, ONE, DWORK, N, + $ U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) + END IF + CALL MA02ED( UPLOW, N, DWORK, N ) +C + IF( KASE.EQ.2 ) THEN +C +C Solve op(T)'*Y + Y*op(T) = scale*RHS. +C + CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 ) + ELSE +C +C Solve op(T)*W + W*op(T)' = scale*RHS. +C + CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 ) + END IF +C + IF( INFO2.GT.0 ) + $ INFO = N + 1 +C + IF( UPDATE ) THEN +C +C Transform back to obtain the solution: Z := U*Z*U', with +C Z = Y or Z = W. +C + CALL MB01RU( UPLOW, 'No transpose', N, N, ZERO, ONE, DWORK, + $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) + END IF +C + IF( KASE.EQ.1 ) THEN + IJ = 0 + IF( LOWER ) THEN +C +C Scale the lower triangular part of symmetric matrix +C by the residual matrix. +C + DO 70 J = 1, N + DO 60 I = J, N + IJ = IJ + 1 + DWORK( IJ ) = DWORK( IJ )*R( I, J ) + 60 CONTINUE + IJ = IJ + J + 70 CONTINUE + ELSE +C +C Scale the upper triangular part of symmetric matrix +C by the residual matrix. +C + DO 90 J = 1, N + DO 80 I = 1, J + IJ = IJ + 1 + DWORK( IJ ) = DWORK( IJ )*R( I, J ) + 80 CONTINUE + IJ = IJ + N - J + 90 CONTINUE + END IF + END IF +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( UPLOW, N, DWORK, N ) + GO TO 10 + END IF +C +C UNTIL KASE = 0 +C +C Compute the estimate of the relative error. +C + TEMP = XANORM*SCALE + IF( TEMP.GT.EST ) THEN + FERR = EST / TEMP + ELSE + FERR = ONE + END IF +C + RETURN +C +C *** Last line of SB03QX *** + END diff --git a/mex/sources/libslicot/SB03QY.f b/mex/sources/libslicot/SB03QY.f new file mode 100644 index 000000000..63f41f5b8 --- /dev/null +++ b/mex/sources/libslicot/SB03QY.f @@ -0,0 +1,443 @@ + SUBROUTINE SB03QY( JOB, TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX, + $ SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the separation between the matrices op(A) and -op(A)', +C +C sep(op(A),-op(A)') = min norm(op(A)'*X + X*op(A))/norm(X) +C = 1 / norm(inv(Omega)) +C +C and/or the 1-norm of Theta, where op(A) = A or A' (A**T), and +C Omega and Theta are linear operators associated to the real +C continuous-time Lyapunov matrix equation +C +C op(A)'*X + X*op(A) = C, +C +C defined by +C +C Omega(W) = op(A)'*W + W*op(A), +C Theta(W) = inv(Omega(op(W)'*X + X*op(W))). +C +C The 1-norm condition estimators are used. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'S': Compute the separation only; +C = 'T': Compute the norm of Theta only; +C = 'B': Compute both the separation and the norm of Theta. +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C LYAPUN CHARACTER*1 +C Specifies whether or not the original Lyapunov equations +C should be solved, as follows: +C = 'O': Solve the original Lyapunov equations, updating +C the right-hand sides and solutions with the +C matrix U, e.g., X <-- U'*X*U; +C = 'R': Solve reduced Lyapunov equations only, without +C updating the right-hand sides and solutions. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and X. N >= 0. +C +C T (input) DOUBLE PRECISION array, dimension (LDT,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain the upper quasi-triangular matrix T in Schur +C canonical form from a Schur factorization of A. +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,N). +C +C U (input) DOUBLE PRECISION array, dimension (LDU,N) +C The leading N-by-N part of this array must contain the +C orthogonal matrix U from a real Schur factorization of A. +C If LYAPUN = 'R', the array U is not referenced. +C +C LDU INTEGER +C The leading dimension of array U. +C LDU >= 1, if LYAPUN = 'R'; +C LDU >= MAX(1,N), if LYAPUN = 'O'. +C +C X (input) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array must contain the +C solution matrix X of the Lyapunov equation (reduced +C Lyapunov equation if LYAPUN = 'R'). +C If JOB = 'S', the array X is not referenced. +C +C LDX INTEGER +C The leading dimension of array X. +C LDX >= 1, if JOB = 'S'; +C LDX >= MAX(1,N), if JOB = 'T' or 'B'. +C +C SEP (output) DOUBLE PRECISION +C If JOB = 'S' or JOB = 'B', and INFO >= 0, SEP contains the +C estimated separation of the matrices op(A) and -op(A)'. +C If JOB = 'T' or N = 0, SEP is not referenced. +C +C THNORM (output) DOUBLE PRECISION +C If JOB = 'T' or JOB = 'B', and INFO >= 0, THNORM contains +C the estimated 1-norm of operator Theta. +C If JOB = 'S' or N = 0, THNORM is not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 2*N*N. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = N+1: if the matrices T and -T' have common or very +C close eigenvalues; perturbed values were used to +C solve Lyapunov equations (but the matrix T is +C unchanged). +C +C METHOD +C +C SEP is defined as the separation of op(A) and -op(A)': +C +C sep( op(A), -op(A)' ) = sigma_min( K ) +C +C where sigma_min(K) is the smallest singular value of the +C N*N-by-N*N matrix +C +C K = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) ). +C +C I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker +C product. The routine estimates sigma_min(K) by the reciprocal of +C an estimate of the 1-norm of inverse(K), computed as suggested in +C [1]. This involves the solution of several continuous-time +C Lyapunov equations, either direct or transposed. The true +C reciprocal 1-norm of inverse(K) cannot differ from sigma_min(K) by +C more than a factor of N. +C The 1-norm of Theta is estimated similarly. +C +C REFERENCES +C +C [1] Higham, N.J. +C FORTRAN codes for estimating the one-norm of a real or +C complex matrix, with applications to condition estimation. +C ACM Trans. Math. Softw., 14, pp. 381-396, 1988. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C FURTHER COMMENTS +C +C When SEP is zero, the routine returns immediately, with THNORM +C (if requested) not set. In this case, the equation is singular. +C The option LYAPUN = 'R' may occasionally produce slightly worse +C or better estimates, and it is much faster than the option 'O'. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Romania, +C Oct. 1998. Partly based on DGLSVX (and then SB03QD) by P. Petkov, +C Tech. University of Sofia, March 1998 (and December 1998). +C +C REVISIONS +C +C February 13, 1999, V. Sima, Katholieke Univ. Leuven, Belgium. +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER JOB, LYAPUN, TRANA + INTEGER INFO, LDT, LDU, LDWORK, LDX, N + DOUBLE PRECISION SEP, THNORM +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION DWORK( * ), T( LDT, * ), U( LDU, * ), + $ X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL NOTRNA, UPDATE, WANTS, WANTT + CHARACTER TRANAT, UPLO + INTEGER INFO2, ITMP, KASE, NN + DOUBLE PRECISION BIGNUM, EST, SCALE +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DLACON, DLACPY, DSCAL, DSYR2K, MA02ED, MB01RU, + $ SB03MY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + WANTS = LSAME( JOB, 'S' ) + WANTT = LSAME( JOB, 'T' ) + NOTRNA = LSAME( TRANA, 'N' ) + UPDATE = LSAME( LYAPUN, 'O' ) +C + NN = N*N + INFO = 0 + IF( .NOT. ( WANTS .OR. WANTT .OR. LSAME( JOB, 'B' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. + $ LSAME( TRANA, 'C' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDX.LT.1 .OR. ( .NOT.WANTS .AND. LDX.LT.N ) ) THEN + INFO = -10 + ELSE IF( LDWORK.LT.2*NN ) THEN + INFO = -15 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03QY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C + ITMP = NN + 1 +C + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +C + IF( .NOT.WANTT ) THEN +C +C Estimate sep(op(A),-op(A)'). +C Workspace: 2*N*N. +C + KASE = 0 +C +C REPEAT + 10 CONTINUE + CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +C +C Select the triangular part of symmetric matrix to be used. +C + IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) + $ .GE. + $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) + $ ) THEN + UPLO = 'U' + ELSE + UPLO = 'L' + END IF +C + IF( UPDATE ) THEN +C +C Transform the right-hand side: RHS := U'*RHS*U. +C + CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK, + $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, + $ INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) + END IF + CALL MA02ED( UPLO, N, DWORK, N ) +C + IF( KASE.EQ.1 ) THEN +C +C Solve op(T)'*Y + Y*op(T) = scale*RHS. +C + CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 ) + ELSE +C +C Solve op(T)*W + W*op(T)' = scale*RHS. +C + CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 ) + END IF +C + IF( INFO2.GT.0 ) + $ INFO = N + 1 +C + IF( UPDATE ) THEN +C +C Transform back to obtain the solution: Z := U*Z*U', with +C Z = Y or Z = W. +C + CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, + $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ), + $ NN, INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( UPLO, N, DWORK, N ) + END IF +C + GO TO 10 + END IF +C UNTIL KASE = 0 +C + IF( EST.GT.SCALE ) THEN + SEP = SCALE / EST + ELSE + BIGNUM = ONE / DLAMCH( 'Safe minimum' ) + IF( SCALE.LT.EST*BIGNUM ) THEN + SEP = SCALE / EST + ELSE + SEP = BIGNUM + END IF + END IF +C +C Return if the equation is singular. +C + IF( SEP.EQ.ZERO ) + $ RETURN + END IF +C + IF( .NOT.WANTS ) THEN +C +C Estimate norm(Theta). +C Workspace: 2*N*N. +C + KASE = 0 +C +C REPEAT + 20 CONTINUE + CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +C +C Select the triangular part of symmetric matrix to be used. +C + IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) + $ .GE. + $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) + $ ) THEN + UPLO = 'U' + ELSE + UPLO = 'L' + END IF +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( UPLO, N, DWORK, N ) +C +C Compute RHS = op(W)'*X + X*op(W). +C + CALL DSYR2K( UPLO, TRANAT, N, N, ONE, DWORK, N, X, LDX, + $ ZERO, DWORK( ITMP ), N ) + CALL DLACPY( UPLO, N, N, DWORK( ITMP ), N, DWORK, N ) +C + IF( UPDATE ) THEN +C +C Transform the right-hand side: RHS := U'*RHS*U. +C + CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK, + $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, + $ INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) + END IF + CALL MA02ED( UPLO, N, DWORK, N ) +C + IF( KASE.EQ.1 ) THEN +C +C Solve op(T)'*Y + Y*op(T) = scale*RHS. +C + CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 ) + ELSE +C +C Solve op(T)*W + W*op(T)' = scale*RHS. +C + CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 ) + END IF +C + IF( INFO2.GT.0 ) + $ INFO = N + 1 +C + IF( UPDATE ) THEN +C +C Transform back to obtain the solution: Z := U*Z*U', with +C Z = Y or Z = W. +C + CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, + $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ), + $ NN, INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( UPLO, N, DWORK, N ) + END IF +C + GO TO 20 + END IF +C UNTIL KASE = 0 +C + IF( EST.LT.SCALE ) THEN + THNORM = EST / SCALE + ELSE + BIGNUM = ONE / DLAMCH( 'Safe minimum' ) + IF( EST.LT.SCALE*BIGNUM ) THEN + THNORM = EST / SCALE + ELSE + THNORM = BIGNUM + END IF + END IF + END IF +C + RETURN +C *** Last line of SB03QY *** + END diff --git a/mex/sources/libslicot/SB03RD.f b/mex/sources/libslicot/SB03RD.f new file mode 100644 index 000000000..0398a3abc --- /dev/null +++ b/mex/sources/libslicot/SB03RD.f @@ -0,0 +1,404 @@ + SUBROUTINE SB03RD( JOB, FACT, TRANA, N, A, LDA, U, LDU, C, LDC, + $ SCALE, SEP, FERR, WR, WI, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the real Lyapunov matrix equation +C +C op(A)'*X + X*op(A) = scale*C +C +C and/or estimate the separation between the matrices op(A) and +C -op(A)', where op(A) = A or A' (A**T) and C is symmetric (C = C'). +C (A' denotes the transpose of the matrix A.) A is N-by-N, the right +C hand side C and the solution X are N-by-N, and scale is an output +C scale factor, set less than or equal to 1 to avoid overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'X': Compute the solution only; +C = 'S': Compute the separation only; +C = 'B': Compute both the solution and the separation. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, A and U contain the factors from the +C real Schur factorization of the matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in A and U. +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X, and C. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. If FACT = 'F', then A contains +C an upper quasi-triangular matrix in Schur canonical form. +C On exit, if INFO = 0 or INFO = N+1, the leading N-by-N +C part of this array contains the upper quasi-triangular +C matrix in Schur canonical form from the Shur factorization +C of A. The contents of array A is not modified if +C FACT = 'F'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,N) +C If FACT = 'F', then U is an input argument and on entry +C it must contain the orthogonal matrix U from the real +C Schur factorization of A. +C If FACT = 'N', then U is an output argument and on exit, +C if INFO = 0 or INFO = N+1, it contains the orthogonal +C N-by-N matrix from the real Schur factorization of A. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry with JOB = 'X' or 'B', the leading N-by-N part of +C this array must contain the symmetric matrix C. +C On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1, +C the leading N-by-N part of C has been overwritten by the +C symmetric solution matrix X. +C If JOB = 'S', C is not referenced. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= 1, if JOB = 'S'; +C LDC >= MAX(1,N), otherwise. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C SEP (output) DOUBLE PRECISION +C If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1, SEP +C contains the estimated separation of the matrices op(A) +C and -op(A)'. +C If JOB = 'X' or N = 0, SEP is not referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains +C an estimated forward error bound for the solution X. +C If XTRUE is the true solution, FERR bounds the relative +C error in the computed solution, measured in the Frobenius +C norm: norm(X - XTRUE)/norm(XTRUE). +C If JOB = 'X' or JOB = 'S', FERR is not referenced. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI +C contain the real and imaginary parts, respectively, of the +C eigenvalues of A. +C If FACT = 'F', WR and WI are not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C This array is not referenced if JOB = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 1 and +C If JOB = 'X' then +C If FACT = 'F', LDWORK >= N*N; +C If FACT = 'N', LDWORK >= MAX(N*N,3*N). +C If JOB = 'S' or JOB = 'B' then +C If FACT = 'F', LDWORK >= 2*N*N; +C If FACT = 'N', LDWORK >= MAX(2*N*N,3*N). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, the QR algorithm failed to compute all +C the eigenvalues (see LAPACK Library routine DGEES); +C elements i+1:n of WR and WI contain eigenvalues +C which have converged, and A contains the partially +C converged Schur form; +C = N+1: if the matrices A and -A' have common or very +C close eigenvalues; perturbed values were used to +C solve the equation (but the matrix A is unchanged). +C +C METHOD +C +C After reducing matrix A to real Schur canonical form (if needed), +C the Bartels-Stewart algorithm is used. A set of equivalent linear +C algebraic systems of equations of order at most four are formed +C and solved using Gaussian elimination with complete pivoting. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C FURTHER COMMENTS +C +C SEP is defined as the separation of op(A) and -op(A)': +C +C sep( op(A), -op(A)' ) = sigma_min( T ) +C +C where sigma_min(T) is the smallest singular value of the +C N*N-by-N*N matrix +C +C T = kprod( I(N), op(A)' ) + kprod( op(A), I(N) ). +C +C I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker +C product. The program estimates sigma_min(T) by the reciprocal of +C an estimate of the 1-norm of inverse(T). The true reciprocal +C 1-norm of inverse(T) cannot differ from sigma_min(T) by more +C than a factor of N. +C +C When SEP is small, small changes in A, C can cause large changes +C in the solution of the equation. An approximate bound on the +C maximum relative error in the computed solution is +C +C EPS * norm(A) / SEP +C +C where EPS is the machine precision. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Supersedes Release 2.0 routine MB03AD by Control Systems Research +C Group, Kingston Polytechnic, United Kingdom, October 1982. +C Based on DGELYP by P. Petkov, Tech. University of Sofia, September +C 1993. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER FACT, JOB, TRANA + INTEGER INFO, LDA, LDC, LDU, LDWORK, N + DOUBLE PRECISION FERR, SCALE, SEP +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), + $ U( LDU, * ), WI( * ), WR( * ) +C .. +C .. Local Scalars .. + LOGICAL NOFACT, NOTA, WANTBH, WANTSP, WANTX + CHARACTER NOTRA, UPLO + INTEGER I, IERR, KASE, LWA, MINWRK, SDIM + DOUBLE PRECISION EST, SCALEF +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAMCH, DLANHS + EXTERNAL DLAMCH, DLANHS, LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DLACON, MB01RD, SB03MY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + WANTX = LSAME( JOB, 'X' ) + WANTSP = LSAME( JOB, 'S' ) + WANTBH = LSAME( JOB, 'B' ) + NOFACT = LSAME( FACT, 'N' ) + NOTA = LSAME( TRANA, 'N' ) +C + INFO = 0 + IF( .NOT.WANTSP .AND. .NOT.WANTBH .AND. .NOT.WANTX ) THEN + INFO = -1 + ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOTA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. + $ .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( WANTSP .AND. LDC.LT.1 .OR. + $ .NOT.WANTSP .AND. LDC.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF +C +C Compute workspace. +C + IF( WANTX ) THEN + IF( NOFACT ) THEN + MINWRK = MAX( N*N, 3*N ) + ELSE + MINWRK = N*N + END IF + ELSE + IF( NOFACT ) THEN + MINWRK = MAX( 2*N*N, 3*N ) + ELSE + MINWRK = 2*N*N + END IF + END IF + IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN + INFO = -18 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + SCALE = ONE + IF( WANTBH ) + $ FERR = ZERO + DWORK(1) = ONE + RETURN + END IF +C + LWA = 0 +C + IF( NOFACT ) THEN +C +C Compute the Schur factorization of A. +C Workspace: need 3*N; +C prefer larger. +C + CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + IF( INFO.GT.0 ) + $ RETURN + LWA = INT( DWORK( 1 ) ) + END IF +C + IF( .NOT.WANTSP ) THEN +C +C Transform the right-hand side. +C Workspace: need N*N. +C + UPLO = 'U' + CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, C, LDC, U, + $ LDU, C, LDC, DWORK, LDWORK, INFO ) +C + DO 10 I = 2, N + CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) + 10 CONTINUE +C +C Solve the transformed equation. +C + CALL SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) + IF( INFO.GT.0 ) + $ INFO = N + 1 +C +C Transform back the solution. +C + CALL MB01RD( UPLO, 'No transpose', N, N, ZERO, ONE, C, LDC, U, + $ LDU, C, LDC, DWORK, LDWORK, INFO ) +C + DO 20 I = 2, N + CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) + 20 CONTINUE +C + END IF +C + IF( .NOT.WANTX ) THEN +C +C Estimate sep(op(A),-op(A)'). +C Workspace: 2*N*N. +C + IF( NOTA ) THEN + NOTRA = 'T' + ELSE + NOTRA = 'N' + END IF +C + EST = ZERO + KASE = 0 +C REPEAT + 30 CONTINUE + CALL DLACON( N*N, DWORK( N*N+1 ), DWORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.1 ) THEN + CALL SB03MY( TRANA, N, A, LDA, DWORK, N, SCALEF, IERR ) + ELSE + CALL SB03MY( NOTRA, N, A, LDA, DWORK, N, SCALEF, IERR ) + END IF + GO TO 30 + END IF +C UNTIL KASE = 0 +C + SEP = SCALEF / EST +C + IF( WANTBH ) THEN +C +C Compute the estimate of the relative error. +C + FERR = DLAMCH( 'Precision' )* + $ DLANHS( 'Frobenius', N, A, LDA, DWORK ) / SEP + END IF + END IF +C + DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) ) +C + RETURN +C *** Last line of SB03RD *** + END diff --git a/mex/sources/libslicot/SB03SD.f b/mex/sources/libslicot/SB03SD.f new file mode 100644 index 000000000..bcf122954 --- /dev/null +++ b/mex/sources/libslicot/SB03SD.f @@ -0,0 +1,674 @@ + SUBROUTINE SB03SD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, + $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD, + $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the conditioning and compute an error bound on the +C solution of the real discrete-time Lyapunov matrix equation +C +C op(A)'*X*op(A) - X = scale*C +C +C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The +C matrix A is N-by-N, the right hand side C and the solution X are +C N-by-N symmetric matrices, and scale is a given scale factor. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'C': Compute the reciprocal condition number only; +C = 'E': Compute the error bound only; +C = 'B': Compute both the reciprocal condition number and +C the error bound. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, T and U (if LYAPUN = 'O') contain the +C factors from the real Schur factorization of the +C matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in T and U (if +C LYAPUN = 'O'). +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C UPLO CHARACTER*1 +C Specifies which part of the symmetric matrix C is to be +C used, as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part. +C +C LYAPUN CHARACTER*1 +C Specifies whether or not the original Lyapunov equations +C should be solved in the iterative estimation process, +C as follows: +C = 'O': Solve the original Lyapunov equations, updating +C the right-hand sides and solutions with the +C matrix U, e.g., X <-- U'*X*U; +C = 'R': Solve reduced Lyapunov equations only, without +C updating the right-hand sides and solutions. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X and C. N >= 0. +C +C SCALE (input) DOUBLE PRECISION +C The scale factor, scale, set by a Lyapunov solver. +C 0 <= SCALE <= 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of +C this array must contain the original matrix A. +C If FACT = 'F' and LYAPUN = 'R', A is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O'; +C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. +C +C T (input/output) DOUBLE PRECISION array, dimension +C (LDT,N) +C If FACT = 'F', then on entry the leading N-by-N upper +C Hessenberg part of this array must contain the upper +C quasi-triangular matrix T in Schur canonical form from a +C Schur factorization of A. +C If FACT = 'N', then this array need not be set on input. +C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the +C leading N-by-N upper Hessenberg part of this array +C contains the upper quasi-triangular matrix T in Schur +C canonical form from a Schur factorization of A. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= MAX(1,N). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,N) +C If LYAPUN = 'O' and FACT = 'F', then U is an input +C argument and on entry, the leading N-by-N part of this +C array must contain the orthogonal matrix U from a real +C Schur factorization of A. +C If LYAPUN = 'O' and FACT = 'N', then U is an output +C argument and on exit, if INFO = 0 or INFO = N+1, it +C contains the orthogonal N-by-N matrix from a real Schur +C factorization of A. +C If LYAPUN = 'R', the array U is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= 1, if LYAPUN = 'R'; +C LDU >= MAX(1,N), if LYAPUN = 'O'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C If UPLO = 'U', the leading N-by-N upper triangular part of +C this array must contain the upper triangular part of the +C matrix C of the original Lyapunov equation (with +C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov +C equation (with matrix T), if LYAPUN = 'R'. +C If UPLO = 'L', the leading N-by-N lower triangular part of +C this array must contain the lower triangular part of the +C matrix C of the original Lyapunov equation (with +C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov +C equation (with matrix T), if LYAPUN = 'R'. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,N). +C +C X (input) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array must contain the +C symmetric solution matrix X of the original Lyapunov +C equation (with matrix A), if LYAPUN = 'O', or of the +C reduced Lyapunov equation (with matrix T), if +C LYAPUN = 'R'. +C The array X is modified internally, but restored on exit. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= MAX(1,N). +C +C SEPD (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'B', the estimated quantity +C sepd(op(A),op(A)'). +C If N = 0, or X = 0, or JOB = 'E', SEPD is not referenced. +C +C RCOND (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal +C condition number of the discrete-time Lyapunov equation. +C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. +C If JOB = 'E', RCOND is not referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'E' or JOB = 'B', an estimated forward error +C bound for the solution X. If XTRUE is the true solution, +C FERR bounds the magnitude of the largest entry in +C (X - XTRUE) divided by the magnitude of the largest entry +C in X. +C If N = 0 or X = 0, FERR is set to 0. +C If JOB = 'C', FERR is not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 1, if N = 0; else, +C LDWORK >= MAX(3,2*N*N) + N*N, if JOB = 'C', +C FACT = 'F'; +C LDWORK >= MAX(MAX(3,2*N*N) + N*N, 5*N), if JOB = 'C', +C FACT = 'N'; +C LDWORK >= MAX(3,2*N*N) + N*N + 2*N, if JOB = 'E', or +C JOB = 'B'. +C For optimum performance LDWORK should sometimes be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, i <= N, the QR algorithm failed to +C complete the reduction to Schur canonical form (see +C LAPACK Library routine DGEES); on exit, the matrix +C T(i+1:N,i+1:N) contains the partially converged +C Schur form, and DWORK(i+1:N) and DWORK(N+i+1:2*N) +C contain the real and imaginary parts, respectively, +C of the converged eigenvalues; this error is unlikely +C to appear; +C = N+1: if the matrix T has almost reciprocal eigenvalues; +C perturbed values were used to solve Lyapunov +C equations, but the matrix T, if given (for +C FACT = 'F'), is unchanged. +C +C METHOD +C +C The condition number of the discrete-time Lyapunov equation is +C estimated as +C +C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), +C +C where Omega and Theta are linear operators defined by +C +C Omega(W) = op(A)'*W*op(A) - W, +C Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))). +C +C The routine estimates the quantities +C +C sepd(op(A),op(A)') = 1 / norm(inv(Omega)) +C +C and norm(Theta) using 1-norm condition estimators. +C +C The forward error bound is estimated using a practical error bound +C similar to the one proposed in [1]. +C +C REFERENCES +C +C [1] Higham, N.J. +C Perturbation theory and backward error for AX-XB=C. +C BIT, vol. 33, pp. 124-136, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C The accuracy of the estimates obtained depends on the solution +C accuracy and on the properties of the 1-norm estimator. +C +C FURTHER COMMENTS +C +C The option LYAPUN = 'R' may occasionally produce slightly worse +C or better estimates, and it is much faster than the option 'O'. +C When SEPD is computed and it is zero, the routine returns +C immediately, with RCOND and FERR (if requested) set to 0 and 1, +C respectively. In this case, the equation is singular. +C +C CONTRIBUTORS +C +C P. Petkov, Tech. University of Sofia, December 1998. +C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, March 2003. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, THREE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, THREE = 3.0D0 ) +C .. +C .. Scalar Arguments .. + CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO + INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N + DOUBLE PRECISION FERR, RCOND, SCALE, SEPD +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), + $ T( LDT, * ), U( LDU, * ), X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL JOBB, JOBC, JOBE, LOWER, NOFACT, NOTRNA, + $ UPDATE + CHARACTER SJOB, TRANAT + INTEGER I, IABS, IRES, IWRK, IXMA, J, LDW, NN, SDIM, + $ WRKOPT + DOUBLE PRECISION ANORM, CNORM, DENOM, EPS, EPSN, TEMP, THNORM, + $ TMAX, XANORM, XNORM +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEES, DGEMM, DLACPY, DLASET, + $ MA02ED, MB01RU, MB01RX, MB01RY, MB01UD, SB03SX, + $ SB03SY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + JOBC = LSAME( JOB, 'C' ) + JOBE = LSAME( JOB, 'E' ) + JOBB = LSAME( JOB, 'B' ) + NOFACT = LSAME( FACT, 'N' ) + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + UPDATE = LSAME( LYAPUN, 'O' ) +C + NN = N*N + LDW = MAX( 3, 2*NN ) + NN +C + INFO = 0 + IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN + INFO = -1 + ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. + $ LSAME( TRANA, 'C' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) THEN + INFO = -7 + ELSE IF( LDA.LT.1 .OR. + $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDWORK.LT.1 .OR. + $ ( LDWORK.LT.LDW .AND. JOBC .AND. .NOT.NOFACT ) .OR. + $ ( LDWORK.LT.MAX( LDW, 5*N ) .AND. JOBC .AND. NOFACT ) .OR. + $ ( LDWORK.LT.( LDW + 2*N ) .AND. .NOT.JOBC ) ) THEN + INFO = -23 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03SD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + IF( .NOT.JOBE ) + $ RCOND = ONE + IF( .NOT.JOBC ) + $ FERR = ZERO + DWORK( 1 ) = ONE + RETURN + END IF +C +C Compute the 1-norm of the matrix X. +C + XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK ) + IF( XNORM.EQ.ZERO ) THEN +C +C The solution is zero. +C + IF( .NOT.JOBE ) + $ RCOND = ZERO + IF( .NOT.JOBC ) + $ FERR = ZERO + DWORK( 1 ) = DBLE( N ) + RETURN + END IF +C +C Compute the 1-norm of A or T. +C + IF( NOFACT .OR. UPDATE ) THEN + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) + ELSE + ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) + END IF +C +C For the special case A = I, set SEPD and RCOND to 0. +C For the special case A = 0, set SEPD and RCOND to 1. +C A quick test is used in general. +C + IF( ANORM.EQ.ONE ) THEN + IF( NOFACT .OR. UPDATE ) THEN + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) + ELSE + CALL DLACPY( 'Full', N, N, T, LDT, DWORK, N ) + IF( N.GT.2 ) + $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, DWORK( 3 ), + $ N ) + END IF + DWORK( NN+1 ) = ONE + CALL DAXPY( N, -ONE, DWORK( NN+1 ), 0, DWORK, N+1 ) + IF( DLANGE( 'Max', N, N, DWORK, N, DWORK ).EQ.ZERO ) THEN + IF( .NOT.JOBE ) THEN + SEPD = ZERO + RCOND = ZERO + END IF + IF( .NOT.JOBC ) + $ FERR = ONE + DWORK( 1 ) = DBLE( NN + 1 ) + RETURN + END IF +C + ELSE IF( ANORM.EQ.ZERO ) THEN + IF( .NOT.JOBE ) THEN + SEPD = ONE + RCOND = ONE + END IF + IF( JOBC ) THEN + DWORK( 1 ) = DBLE( N ) + RETURN + ELSE +C +C Set FERR for the special case A = 0. +C + CALL DLACPY( UPLO, N, N, X, LDX, DWORK, N ) +C + IF( LOWER ) THEN + DO 10 J = 1, N + CALL DAXPY( N-J+1, SCALE, C( J, J ), 1, + $ DWORK( (J-1)*N+J ), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, N + CALL DAXPY( J, SCALE, C( 1, J ), 1, + $ DWORK( (J-1)*N+1 ), 1 ) + 20 CONTINUE + END IF +C + FERR = MIN( ONE, DLANSY( '1-norm', UPLO, N, DWORK, N, + $ DWORK( NN+1 ) ) / XNORM ) + DWORK( 1 ) = DBLE( NN + N ) + RETURN + END IF + END IF +C +C General case. +C + CNORM = DLANSY( '1-norm', UPLO, N, C, LDC, DWORK ) +C +C Workspace usage. +C + IABS = NN + IXMA = MAX( 3, 2*NN ) + IRES = IXMA + IWRK = IXMA + NN + WRKOPT = 0 +C + IF( NOFACT ) THEN +C +C Compute the Schur factorization of A, A = U*T*U'. +C Workspace: need 5*N; +C prefer larger. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) + IF( UPDATE ) THEN + SJOB = 'V' + ELSE + SJOB = 'N' + END IF + CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, + $ DWORK( 1 ), DWORK( N+1 ), U, LDU, DWORK( 2*N+1 ), + $ LDWORK-2*N, BWORK, INFO ) + IF( INFO.GT.0 ) + $ RETURN + WRKOPT = INT( DWORK( 2*N+1 ) ) + 2*N + END IF +C +C Compute X*op(A) or X*op(T). +C + IF( UPDATE ) THEN + CALL DGEMM( 'NoTranspose', TRANA, N, N, N, ONE, X, LDX, A, LDA, + $ ZERO, DWORK( IXMA+1 ), N ) + ELSE + CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, + $ DWORK( IXMA+1 ), N, INFO ) + END IF +C + IF( .NOT.JOBE ) THEN +C +C Estimate sepd(op(A),op(A)') = sepd(op(T),op(T)') and +C norm(Theta). +C Workspace max(3,2*N*N) + N*N. +C + CALL SB03SY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, + $ DWORK( IXMA+1 ), N, SEPD, THNORM, IWORK, DWORK, + $ IXMA, INFO ) +C + WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + NN ) +C +C Return if the equation is singular. +C + IF( SEPD.EQ.ZERO ) THEN + RCOND = ZERO + IF( JOBB ) + $ FERR = ONE + DWORK( 1 ) = DBLE( WRKOPT ) + RETURN + END IF +C +C Estimate the reciprocal condition number. +C + TMAX = MAX( SEPD, XNORM, ANORM ) + IF( TMAX.LE.ONE ) THEN + TEMP = SEPD*XNORM + DENOM = ( SCALE*CNORM ) + ( SEPD*ANORM )*THNORM + ELSE + TEMP = ( SEPD / TMAX )*( XNORM / TMAX ) + DENOM = ( ( SCALE / TMAX )*( CNORM / TMAX ) ) + + $ ( ( SEPD / TMAX )*( ANORM / TMAX ) )*THNORM + END IF + IF( TEMP.GE.DENOM ) THEN + RCOND = ONE + ELSE + RCOND = TEMP / DENOM + END IF + END IF +C + IF( .NOT.JOBC ) THEN +C +C Form a triangle of the residual matrix +C R = scale*C + X - op(A)'*X*op(A), or +C R = scale*C + X - op(T)'*X*op(T), +C exploiting the symmetry. For memory savings, R is formed in the +C leading N-by-N upper/lower triangular part of DWORK, and it is +C finally moved in the location where X*op(A) or X*op(T) was +C stored, freeing workspace for the SB03SX call. +C + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +C + CALL DLACPY( UPLO, N, N, C, LDC, DWORK, N ) +C + IF( UPDATE ) THEN + CALL MB01RX( 'Left', UPLO, TRANAT, N, N, SCALE, -ONE, DWORK, + $ N, A, LDA, DWORK( IXMA+1 ), N, INFO ) + ELSE + CALL MB01RY( 'Left', UPLO, TRANAT, N, SCALE, -ONE, DWORK, N, + $ T, LDT, DWORK( IXMA+1 ), N, DWORK( IWRK+1 ), + $ INFO ) + END IF +C + IF( LOWER ) THEN + DO 30 J = 1, N + CALL DAXPY( N-J+1, ONE, X( J, J ), 1, DWORK( (J-1)*N+J ), + $ 1 ) + 30 CONTINUE + ELSE + DO 40 J = 1, N + CALL DAXPY( J, ONE, X( 1, J ), 1, DWORK( (J-1)*N+1 ), 1 ) + 40 CONTINUE + END IF +C + CALL DLACPY( UPLO, N, N, DWORK, N, DWORK( IRES+1 ), N ) +C +C Get the machine precision. +C + EPS = DLAMCH( 'Epsilon' ) + EPSN = EPS*DBLE( 2*N + 2 ) +C +C Add to abs(R) a term that takes account of rounding errors in +C forming R: +C abs(R) := abs(R) + EPS*(3*scale*abs(C) + 3*abs(X) + +C 2*(n+1)*abs(op(A))'*abs(X)*abs(op(A))), or +C abs(R) := abs(R) + EPS*(3*scale*abs(C) + 3*abs(X) + +C 2*(n+1)*abs(op(T))'*abs(X)*abs(op(T))), +C where EPS is the machine precision. +C Workspace max(3,2*N*N) + N*N + 2*N. +C Note that the lower or upper triangular part of X specified by +C UPLO is used as workspace, but it is finally restored. +C + IF( UPDATE ) THEN + DO 60 J = 1, N + DO 50 I = 1, N + DWORK( IABS+(J-1)*N+I ) = ABS( A( I, J ) ) + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1, N + DO 70 I = 1, MIN( J+1, N ) + DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) + 70 CONTINUE + 80 CONTINUE + END IF +C + CALL DCOPY( N, X, LDX+1, DWORK( IWRK+1 ), 1 ) +C + IF( LOWER ) THEN + DO 100 J = 1, N + DO 90 I = J, N + TEMP = ABS( X( I, J ) ) + X( I, J ) = TEMP + DWORK( IRES+(J-1)*N+I ) = + $ ABS( DWORK( IRES+(J-1)*N+I ) ) + + $ EPS*THREE*( SCALE*ABS( C( I, J ) ) + TEMP ) + 90 CONTINUE + 100 CONTINUE + ELSE + DO 120 J = 1, N + DO 110 I = 1, J + TEMP = ABS( X( I, J ) ) + X( I, J ) = TEMP + DWORK( IRES+(J-1)*N+I ) = + $ ABS( DWORK( IRES+(J-1)*N+I ) ) + + $ EPS*THREE*( SCALE*ABS( C( I, J ) ) + TEMP ) + 110 CONTINUE + 120 CONTINUE + END IF +C + IF( UPDATE ) THEN + CALL MB01RU( UPLO, TRANAT, N, N, ONE, EPSN, DWORK( IRES+1 ), + $ N, DWORK( IABS+1 ), N, X, LDX, DWORK, NN, + $ INFO ) + ELSE +C +C Compute W = abs(X)*abs(op(T)), and then premultiply by +C abs(T)' and add in the result. +C + CALL MB01UD( 'Right', TRANA, N, N, ONE, DWORK( IABS+1 ), N, + $ X, LDX, DWORK, N, INFO ) + CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPSN, + $ DWORK( IRES+1 ), N, DWORK( IABS+1 ), N, DWORK, + $ N, DWORK( IWRK+N+1 ), INFO ) + END IF +C + WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + NN + 2*N ) +C +C Restore X. +C + CALL DCOPY( N, DWORK( IWRK+1 ), 1, X, LDX+1 ) + IF( LOWER ) THEN + CALL MA02ED( 'Upper', N, X, LDX ) + ELSE + CALL MA02ED( 'Lower', N, X, LDX ) + END IF +C +C Compute forward error bound, using matrix norm estimator. +C Workspace max(3,2*N*N) + N*N. +C + XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) +C + CALL SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, + $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK, IRES, + $ INFO ) + END IF +C + DWORK( 1 ) = DBLE( WRKOPT ) + RETURN +C +C *** Last line of SB03SD *** + END diff --git a/mex/sources/libslicot/SB03SX.f b/mex/sources/libslicot/SB03SX.f new file mode 100644 index 000000000..58078b80d --- /dev/null +++ b/mex/sources/libslicot/SB03SX.f @@ -0,0 +1,398 @@ + SUBROUTINE SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, + $ R, LDR, FERR, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate a forward error bound for the solution X of a real +C discrete-time Lyapunov matrix equation, +C +C op(A)'*X*op(A) - X = C, +C +C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The +C matrix A, the right hand side C, and the solution X are N-by-N. +C An absolute residual matrix, which takes into account the rounding +C errors in forming it, is given in the array R. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C UPLO CHARACTER*1 +C Specifies which part of the symmetric matrix R is to be +C used, as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part. +C +C LYAPUN CHARACTER*1 +C Specifies whether or not the original Lyapunov equations +C should be solved, as follows: +C = 'O': Solve the original Lyapunov equations, updating +C the right-hand sides and solutions with the +C matrix U, e.g., X <-- U'*X*U; +C = 'R': Solve reduced Lyapunov equations only, without +C updating the right-hand sides and solutions. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and R. N >= 0. +C +C XANORM (input) DOUBLE PRECISION +C The absolute (maximal) norm of the symmetric solution +C matrix X of the Lyapunov equation. XANORM >= 0. +C +C T (input) DOUBLE PRECISION array, dimension (LDT,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain the upper quasi-triangular matrix T in Schur +C canonical form from a Schur factorization of A. +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,N). +C +C U (input) DOUBLE PRECISION array, dimension (LDU,N) +C The leading N-by-N part of this array must contain the +C orthogonal matrix U from a real Schur factorization of A. +C If LYAPUN = 'R', the array U is not referenced. +C +C LDU INTEGER +C The leading dimension of array U. +C LDU >= 1, if LYAPUN = 'R'; +C LDU >= MAX(1,N), if LYAPUN = 'O'. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) +C On entry, if UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular part of the absolute residual matrix R, with +C bounds on rounding errors added. +C On entry, if UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular part of the absolute residual matrix R, with +C bounds on rounding errors added. +C On exit, the leading N-by-N part of this array contains +C the symmetric absolute residual matrix R (with bounds on +C rounding errors added), fully stored. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C FERR (output) DOUBLE PRECISION +C An estimated forward error bound for the solution X. +C If XTRUE is the true solution, FERR bounds the magnitude +C of the largest entry in (X - XTRUE) divided by the +C magnitude of the largest entry in X. +C If N = 0 or XANORM = 0, FERR is set to 0, without any +C calculations. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 0, if N = 0; +C LDWORK >= MAX(3,2*N*N), if N > 0. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = N+1: if T has almost reciprocal eigenvalues; perturbed +C values were used to solve Lyapunov equations (but +C the matrix T is unchanged). +C +C METHOD +C +C The forward error bound is estimated using a practical error bound +C similar to the one proposed in [1], based on the 1-norm estimator +C in [2]. +C +C REFERENCES +C +C [1] Higham, N.J. +C Perturbation theory and backward error for AX-XB=C. +C BIT, vol. 33, pp. 124-136, 1993. +C +C [2] Higham, N.J. +C FORTRAN codes for estimating the one-norm of a real or +C complex matrix, with applications to condition estimation. +C ACM Trans. Math. Softw., 14, pp. 381-396, 1988. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C FURTHER COMMENTS +C +C The option LYAPUN = 'R' may occasionally produce slightly worse +C or better estimates, and it is much faster than the option 'O'. +C The routine can be also used as a final step in estimating a +C forward error bound for the solution of a discrete-time algebraic +C matrix Riccati equation. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Romania, +C Oct. 1998. Partly based on DDLSVX (and then SB03SD) by P. Petkov, +C Tech. University of Sofia, March 1998 (and December 1998). +C +C REVISIONS +C +C February 6, 1999, V. Sima, Katholieke Univ. Leuven, Belgium. +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER LYAPUN, TRANA, UPLO + INTEGER INFO, LDR, LDT, LDU, LDWORK, N + DOUBLE PRECISION FERR, XANORM +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION DWORK( * ), R( LDR, * ), T( LDT, * ), + $ U( LDU, * ) +C .. +C .. Local Scalars .. + LOGICAL LOWER, NOTRNA, UPDATE + CHARACTER TRANAT, UPLOW + INTEGER I, IJ, INFO2, ITMP, J, KASE, NN + DOUBLE PRECISION EST, SCALE, TEMP +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLANSY + EXTERNAL DLANSY, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DLACON, DSCAL, MA02ED, MB01RU, SB03MX, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + NOTRNA = LSAME( TRANA, 'N' ) + UPDATE = LSAME( LYAPUN, 'O' ) +C + NN = N*N + INFO = 0 + IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. + $ LSAME( TRANA, 'C' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) + $ THEN + INFO = -2 + ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( XANORM.LT.ZERO ) THEN + INFO = -5 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN + INFO = -9 + ELSE IF( LDR.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.0 .OR. + $ ( LDWORK.LT.MAX( 3, 2*NN ) .AND. N.GT.0 ) ) THEN + INFO = -15 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03SX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + FERR = ZERO + IF( N.EQ.0 .OR. XANORM.EQ.ZERO ) + $ RETURN +C + ITMP = NN + 1 +C + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +C +C Fill in the remaining triangle of the symmetric residual matrix. +C + CALL MA02ED( UPLO, N, R, LDR ) +C + KASE = 0 +C +C REPEAT + 10 CONTINUE + CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +C +C Select the triangular part of symmetric matrix to be used. +C + IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) + $ .GE. + $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) + $ ) THEN + UPLOW = 'U' + LOWER = .FALSE. + ELSE + UPLOW = 'L' + LOWER = .TRUE. + END IF +C + IF( KASE.EQ.2 ) THEN + IJ = 0 + IF( LOWER ) THEN +C +C Scale the lower triangular part of symmetric matrix +C by the residual matrix. +C + DO 30 J = 1, N + DO 20 I = J, N + IJ = IJ + 1 + DWORK( IJ ) = DWORK( IJ )*R( I, J ) + 20 CONTINUE + IJ = IJ + J + 30 CONTINUE + ELSE +C +C Scale the upper triangular part of symmetric matrix +C by the residual matrix. +C + DO 50 J = 1, N + DO 40 I = 1, J + IJ = IJ + 1 + DWORK( IJ ) = DWORK( IJ )*R( I, J ) + 40 CONTINUE + IJ = IJ + N - J + 50 CONTINUE + END IF + END IF +C + IF( UPDATE ) THEN +C +C Transform the right-hand side: RHS := U'*RHS*U. +C + CALL MB01RU( UPLOW, 'Transpose', N, N, ZERO, ONE, DWORK, N, + $ U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) + END IF + CALL MA02ED( UPLOW, N, DWORK, N ) +C + IF( KASE.EQ.2 ) THEN +C +C Solve op(T)'*Y*op(T) - Y = scale*RHS. +C + CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE, + $ DWORK( ITMP ), INFO2 ) + ELSE +C +C Solve op(T)*W*op(T)' - W = scale*RHS. +C + CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE, + $ DWORK( ITMP ), INFO2 ) + END IF +C + IF( INFO2.GT.0 ) + $ INFO = N + 1 +C + IF( UPDATE ) THEN +C +C Transform back to obtain the solution: Z := U*Z*U', with +C Z = Y or Z = W. +C + CALL MB01RU( UPLOW, 'No transpose', N, N, ZERO, ONE, DWORK, + $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) + END IF +C + IF( KASE.EQ.1 ) THEN + IJ = 0 + IF( LOWER ) THEN +C +C Scale the lower triangular part of symmetric matrix +C by the residual matrix. +C + DO 70 J = 1, N + DO 60 I = J, N + IJ = IJ + 1 + DWORK( IJ ) = DWORK( IJ )*R( I, J ) + 60 CONTINUE + IJ = IJ + J + 70 CONTINUE + ELSE +C +C Scale the upper triangular part of symmetric matrix +C by the residual matrix. +C + DO 90 J = 1, N + DO 80 I = 1, J + IJ = IJ + 1 + DWORK( IJ ) = DWORK( IJ )*R( I, J ) + 80 CONTINUE + IJ = IJ + N - J + 90 CONTINUE + END IF + END IF +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( UPLOW, N, DWORK, N ) + GO TO 10 + END IF +C +C UNTIL KASE = 0 +C +C Compute the estimate of the relative error. +C + TEMP = XANORM*SCALE + IF( TEMP.GT.EST ) THEN + FERR = EST / TEMP + ELSE + FERR = ONE + END IF +C + RETURN +C +C *** Last line of SB03SX *** + END diff --git a/mex/sources/libslicot/SB03SY.f b/mex/sources/libslicot/SB03SY.f new file mode 100644 index 000000000..8cdc0c9bb --- /dev/null +++ b/mex/sources/libslicot/SB03SY.f @@ -0,0 +1,451 @@ + SUBROUTINE SB03SY( JOB, TRANA, LYAPUN, N, T, LDT, U, LDU, XA, + $ LDXA, SEPD, THNORM, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the "separation" between the matrices op(A) and +C op(A)', +C +C sepd(op(A),op(A)') = min norm(op(A)'*X*op(A) - X)/norm(X) +C = 1 / norm(inv(Omega)) +C +C and/or the 1-norm of Theta, where op(A) = A or A' (A**T), and +C Omega and Theta are linear operators associated to the real +C discrete-time Lyapunov matrix equation +C +C op(A)'*X*op(A) - X = C, +C +C defined by +C +C Omega(W) = op(A)'*W*op(A) - W, +C Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))). +C +C The 1-norm condition estimators are used. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'S': Compute the separation only; +C = 'T': Compute the norm of Theta only; +C = 'B': Compute both the separation and the norm of Theta. +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C LYAPUN CHARACTER*1 +C Specifies whether or not the original Lyapunov equations +C should be solved, as follows: +C = 'O': Solve the original Lyapunov equations, updating +C the right-hand sides and solutions with the +C matrix U, e.g., X <-- U'*X*U; +C = 'R': Solve reduced Lyapunov equations only, without +C updating the right-hand sides and solutions. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and X. N >= 0. +C +C T (input) DOUBLE PRECISION array, dimension (LDT,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain the upper quasi-triangular matrix T in Schur +C canonical form from a Schur factorization of A. +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,N). +C +C U (input) DOUBLE PRECISION array, dimension (LDU,N) +C The leading N-by-N part of this array must contain the +C orthogonal matrix U from a real Schur factorization of A. +C If LYAPUN = 'R', the array U is not referenced. +C +C LDU INTEGER +C The leading dimension of array U. +C LDU >= 1, if LYAPUN = 'R'; +C LDU >= MAX(1,N), if LYAPUN = 'O'. +C +C XA (input) DOUBLE PRECISION array, dimension (LDXA,N) +C The leading N-by-N part of this array must contain the +C matrix product X*op(A), if LYAPUN = 'O', or U'*X*U*op(T), +C if LYAPUN = 'R', in the Lyapunov equation. +C If JOB = 'S', the array XA is not referenced. +C +C LDXA INTEGER +C The leading dimension of array XA. +C LDXA >= 1, if JOB = 'S'; +C LDXA >= MAX(1,N), if JOB = 'T' or 'B'. +C +C SEPD (output) DOUBLE PRECISION +C If JOB = 'S' or JOB = 'B', and INFO >= 0, SEPD contains +C the estimated quantity sepd(op(A),op(A)'). +C If JOB = 'T' or N = 0, SEPD is not referenced. +C +C THNORM (output) DOUBLE PRECISION +C If JOB = 'T' or JOB = 'B', and INFO >= 0, THNORM contains +C the estimated 1-norm of operator Theta. +C If JOB = 'S' or N = 0, THNORM is not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 0, if N = 0; +C LDWORK >= MAX(3,2*N*N), if N > 0. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = N+1: if T has (almost) reciprocal eigenvalues; +C perturbed values were used to solve Lyapunov +C equations (but the matrix T is unchanged). +C +C METHOD +C +C SEPD is defined as +C +C sepd( op(A), op(A)' ) = sigma_min( K ) +C +C where sigma_min(K) is the smallest singular value of the +C N*N-by-N*N matrix +C +C K = kprod( op(A)', op(A)' ) - I(N**2). +C +C I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the +C Kronecker product. The routine estimates sigma_min(K) by the +C reciprocal of an estimate of the 1-norm of inverse(K), computed as +C suggested in [1]. This involves the solution of several discrete- +C time Lyapunov equations, either direct or transposed. The true +C reciprocal 1-norm of inverse(K) cannot differ from sigma_min(K) by +C more than a factor of N. +C The 1-norm of Theta is estimated similarly. +C +C REFERENCES +C +C [1] Higham, N.J. +C FORTRAN codes for estimating the one-norm of a real or +C complex matrix, with applications to condition estimation. +C ACM Trans. Math. Softw., 14, pp. 381-396, 1988. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C FURTHER COMMENTS +C +C When SEPD is zero, the routine returns immediately, with THNORM +C (if requested) not set. In this case, the equation is singular. +C The option LYAPUN = 'R' may occasionally produce slightly worse +C or better estimates, and it is much faster than the option 'O'. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Romania, +C Oct. 1998. Partly based on DDLSVX (and then SB03SD) by P. Petkov, +C Tech. University of Sofia, March 1998 (and December 1998). +C +C REVISIONS +C +C February 6, 1999, V. Sima, Katholieke Univ. Leuven, Belgium. +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER JOB, LYAPUN, TRANA + INTEGER INFO, LDT, LDU, LDWORK, LDXA, N + DOUBLE PRECISION SEPD, THNORM +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION DWORK( * ), T( LDT, * ), U( LDU, * ), + $ XA( LDXA, * ) +C .. +C .. Local Scalars .. + LOGICAL NOTRNA, UPDATE, WANTS, WANTT + CHARACTER TRANAT, UPLO + INTEGER INFO2, ITMP, KASE, NN + DOUBLE PRECISION BIGNUM, EST, SCALE +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DLACON, DLACPY, DSCAL, DSYR2K, MA02ED, MB01RU, + $ SB03MX, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + WANTS = LSAME( JOB, 'S' ) + WANTT = LSAME( JOB, 'T' ) + NOTRNA = LSAME( TRANA, 'N' ) + UPDATE = LSAME( LYAPUN, 'O' ) +C + NN = N*N + INFO = 0 + IF( .NOT. ( WANTS .OR. WANTT .OR. LSAME( JOB, 'B' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. + $ LSAME( TRANA, 'C' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDXA.LT.1 .OR. ( .NOT.WANTS .AND. LDXA.LT.N ) ) THEN + INFO = -10 + ELSE IF( LDWORK.LT.0 .OR. + $ ( LDWORK.LT.MAX( 3, 2*NN ) .AND. N.GT.0 ) ) THEN + INFO = -15 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03SY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C + ITMP = NN + 1 +C + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +C + IF( .NOT.WANTT ) THEN +C +C Estimate sepd(op(A),op(A)'). +C Workspace: max(3,2*N*N). +C + KASE = 0 +C +C REPEAT + 10 CONTINUE + CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +C +C Select the triangular part of symmetric matrix to be used. +C + IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) + $ .GE. + $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) + $ ) THEN + UPLO = 'U' + ELSE + UPLO = 'L' + END IF +C + IF( UPDATE ) THEN +C +C Transform the right-hand side: RHS := U'*RHS*U. +C + CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK, + $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, + $ INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) + END IF + CALL MA02ED( UPLO, N, DWORK, N ) +C + IF( KASE.EQ.1 ) THEN +C +C Solve op(T)'*Y*op(T) - Y = scale*RHS. +C + CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE, + $ DWORK( ITMP ), INFO2 ) + ELSE +C +C Solve op(T)*W*op(T)' - W = scale*RHS. +C + CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE, + $ DWORK( ITMP ), INFO2 ) + END IF +C + IF( INFO2.GT.0 ) + $ INFO = N + 1 +C + IF( UPDATE ) THEN +C +C Transform back to obtain the solution: Z := U*Z*U', with +C Z = Y or Z = W. +C + CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, + $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ), + $ NN, INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( UPLO, N, DWORK, N ) + END IF +C + GO TO 10 + END IF +C UNTIL KASE = 0 +C + IF( EST.GT.SCALE ) THEN + SEPD = SCALE / EST + ELSE + BIGNUM = ONE / DLAMCH( 'Safe minimum' ) + IF( SCALE.LT.EST*BIGNUM ) THEN + SEPD = SCALE / EST + ELSE + SEPD = BIGNUM + END IF + END IF +C +C Return if the equation is singular. +C + IF( SEPD.EQ.ZERO ) + $ RETURN + END IF +C + IF( .NOT.WANTS ) THEN +C +C Estimate norm(Theta). +C Workspace: max(3,2*N*N). +C + KASE = 0 +C +C REPEAT + 20 CONTINUE + CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN +C +C Select the triangular part of symmetric matrix to be used. +C + IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) + $ .GE. + $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) + $ ) THEN + UPLO = 'U' + ELSE + UPLO = 'L' + END IF +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( UPLO, N, DWORK, N ) +C +C Compute RHS = op(W)'*X*op(A) + op(A)'*X*op(W). +C + CALL DSYR2K( UPLO, TRANAT, N, N, ONE, DWORK, N, XA, LDXA, + $ ZERO, DWORK( ITMP ), N ) + CALL DLACPY( UPLO, N, N, DWORK( ITMP ), N, DWORK, N ) +C + IF( UPDATE ) THEN +C +C Transform the right-hand side: RHS := U'*RHS*U. +C + CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK, + $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, + $ INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) + END IF + CALL MA02ED( UPLO, N, DWORK, N ) +C + IF( KASE.EQ.1 ) THEN +C +C Solve op(T)'*Y*op(T) - Y = scale*RHS. +C + CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE, + $ DWORK( ITMP ), INFO2 ) + ELSE +C +C Solve op(T)*W*op(T)' - W = scale*RHS. +C + CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE, + $ DWORK( ITMP ), INFO2 ) + END IF +C + IF( INFO2.GT.0 ) + $ INFO = N + 1 +C + IF( UPDATE ) THEN +C +C Transform back to obtain the solution: Z := U*Z*U', with +C Z = Y or Z = W. +C + CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, + $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ), + $ NN, INFO2 ) + CALL DSCAL( N, HALF, DWORK, N+1 ) +C +C Fill in the remaining triangle of the symmetric matrix. +C + CALL MA02ED( UPLO, N, DWORK, N ) + END IF +C + GO TO 20 + END IF +C UNTIL KASE = 0 +C + IF( EST.LT.SCALE ) THEN + THNORM = EST / SCALE + ELSE + BIGNUM = ONE / DLAMCH( 'Safe minimum' ) + IF( EST.LT.SCALE*BIGNUM ) THEN + THNORM = EST / SCALE + ELSE + THNORM = BIGNUM + END IF + END IF + END IF +C + RETURN +C *** Last line of SB03SY *** + END diff --git a/mex/sources/libslicot/SB03TD.f b/mex/sources/libslicot/SB03TD.f new file mode 100644 index 000000000..a1a81961f --- /dev/null +++ b/mex/sources/libslicot/SB03TD.f @@ -0,0 +1,545 @@ + SUBROUTINE SB03TD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, + $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, + $ RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the real continuous-time Lyapunov matrix equation +C +C op(A)'*X + X*op(A) = scale*C, +C +C estimate the conditioning, and compute an error bound on the +C solution X, where op(A) = A or A' (A**T), the matrix A is N-by-N, +C the right hand side C and the solution X are N-by-N symmetric +C matrices (C = C', X = X'), and scale is an output scale factor, +C set less than or equal to 1 to avoid overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'X': Compute the solution only; +C = 'S': Compute the separation only; +C = 'C': Compute the reciprocal condition number only; +C = 'E': Compute the error bound only; +C = 'A': Compute all: the solution, separation, reciprocal +C condition number, and the error bound. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, T and U (if LYAPUN = 'O') contain the +C factors from the real Schur factorization of the +C matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in T and U (if +C LYAPUN = 'O'). +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C UPLO CHARACTER*1 +C Specifies which part of the symmetric matrix C is to be +C used, as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part. +C +C LYAPUN CHARACTER*1 +C Specifies whether or not the original or "reduced" +C Lyapunov equations should be solved, as follows: +C = 'O': Solve the original Lyapunov equations, updating +C the right-hand sides and solutions with the +C matrix U, e.g., X <-- U'*X*U; +C = 'R': Solve reduced Lyapunov equations only, without +C updating the right-hand sides and solutions. +C This means that a real Schur form T of A appears +C in the equation, instead of A. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X, and C. N >= 0. +C +C SCALE (input or output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'E', SCALE is an input argument: +C the scale factor, set by a Lyapunov solver. +C 0 <= SCALE <= 1. +C If JOB = 'X' or JOB = 'A', SCALE is an output argument: +C the scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C If JOB = 'S', this argument is not used. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C If FACT = 'N' or (LYAPUN = 'O' and JOB <> 'X'), the +C leading N-by-N part of this array must contain the +C original matrix A. +C If FACT = 'F' and (LYAPUN = 'R' or JOB = 'X'), A is +C not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O' and +C JOB <> 'X'; +C LDA >= 1, otherwise. +C +C T (input/output) DOUBLE PRECISION array, dimension +C (LDT,N) +C If FACT = 'F', then on entry the leading N-by-N upper +C Hessenberg part of this array must contain the upper +C quasi-triangular matrix T in Schur canonical form from a +C Schur factorization of A. +C If FACT = 'N', then this array need not be set on input. +C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the +C leading N-by-N upper Hessenberg part of this array +C contains the upper quasi-triangular matrix T in Schur +C canonical form from a Schur factorization of A. +C The contents of array T is not modified if FACT = 'F'. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= MAX(1,N). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,N) +C If LYAPUN = 'O' and FACT = 'F', then U is an input +C argument and on entry, the leading N-by-N part of this +C array must contain the orthogonal matrix U from a real +C Schur factorization of A. +C If LYAPUN = 'O' and FACT = 'N', then U is an output +C argument and on exit, if INFO = 0 or INFO = N+1, it +C contains the orthogonal N-by-N matrix from a real Schur +C factorization of A. +C If LYAPUN = 'R', the array U is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= 1, if LYAPUN = 'R'; +C LDU >= MAX(1,N), if LYAPUN = 'O'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C If JOB <> 'S' and UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular part of the matrix C of the original Lyapunov +C equation (with matrix A), if LYAPUN = 'O', or of the +C reduced Lyapunov equation (with matrix T), if +C LYAPUN = 'R'. +C If JOB <> 'S' and UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular part of the matrix C of the original Lyapunov +C equation (with matrix A), if LYAPUN = 'O', or of the +C reduced Lyapunov equation (with matrix T), if +C LYAPUN = 'R'. +C The remaining strictly triangular part of this array is +C used as workspace. +C If JOB = 'X', then this array may be identified with X +C in the call of this routine. +C If JOB = 'S', the array C is not referenced. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= 1, if JOB = 'S'; +C LDC >= MAX(1,N), otherwise. +C +C X (input or output) DOUBLE PRECISION array, dimension +C (LDX,N) +C If JOB = 'C' or 'E', then X is an input argument and on +C entry, the leading N-by-N part of this array must contain +C the symmetric solution matrix X of the original Lyapunov +C equation (with matrix A), if LYAPUN = 'O', or of the +C reduced Lyapunov equation (with matrix T), if +C LYAPUN = 'R'. +C If JOB = 'X' or 'A', then X is an output argument and on +C exit, if INFO = 0 or INFO = N+1, the leading N-by-N part +C of this array contains the symmetric solution matrix X of +C of the original Lyapunov equation (with matrix A), if +C LYAPUN = 'O', or of the reduced Lyapunov equation (with +C matrix T), if LYAPUN = 'R'. +C If JOB = 'S', the array X is not referenced. +C +C LDX INTEGER +C The leading dimension of the array X. +C LDX >= 1, if JOB = 'S'; +C LDX >= MAX(1,N), otherwise. +C +C SEP (output) DOUBLE PRECISION +C If JOB = 'S' or JOB = 'C' or JOB = 'A', and INFO = 0 or +C INFO = N+1, SEP contains the estimated separation of the +C matrices op(A) and -op(A)', sep(op(A),-op(A)'). +C If N = 0, or X = 0, or JOB = 'X' or JOB = 'E', SEP is not +C referenced. +C +C RCOND (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'A', an estimate of the reciprocal +C condition number of the continuous-time Lyapunov equation. +C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. +C If JOB = 'X' or JOB = 'S' or JOB = 'E', RCOND is not +C referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = N+1, +C FERR contains an estimated forward error bound for the +C solution X. If XTRUE is the true solution, FERR bounds the +C relative error in the computed solution, measured in the +C Frobenius norm: norm(X - XTRUE)/norm(XTRUE). +C If N = 0 or X = 0, FERR is set to 0. +C If JOB = 'X' or JOB = 'S' or JOB = 'C', FERR is not +C referenced. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI +C contain the real and imaginary parts, respectively, of the +C eigenvalues of A. +C If FACT = 'F', WR and WI are not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C This array is not referenced if JOB = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C If JOB = 'X', then +C LDWORK >= MAX(1,N*N), if FACT = 'F'; +C LDWORK >= MAX(1,MAX(N*N,3*N)), if FACT = 'N'. +C If JOB = 'S' or JOB = 'C', then +C LDWORK >= MAX(1,2*N*N), if FACT = 'F'; +C LDWORK >= MAX(1,2*N*N,3*N), if FACT = 'N'. +C If JOB = 'E', or JOB = 'A', and LYAPUN = 'O', then +C LDWORK >= MAX(1,3*N*N); +C If JOB = 'E', or JOB = 'A', and LYAPUN = 'R', then +C LDWORK >= MAX(1,3*N*N+N-1). +C For optimum performance LDWORK should sometimes be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, i <= N, the QR algorithm failed to +C complete the reduction to Schur canonical form (see +C LAPACK Library routine DGEES); on exit, the matrix +C T(i+1:N,i+1:N) contains the partially converged +C Schur form, and the elements i+1:n of WR and WI +C contain the real and imaginary parts, respectively, +C of the converged eigenvalues; this error is unlikely +C to appear; +C = N+1: if the matrices T and -T' have common or very +C close eigenvalues; perturbed values were used to +C solve Lyapunov equations, but the matrix T, if given +C (for FACT = 'F'), is unchanged. +C +C METHOD +C +C After reducing matrix A to real Schur canonical form (if needed), +C the Bartels-Stewart algorithm is used. A set of equivalent linear +C algebraic systems of equations of order at most four are formed +C and solved using Gaussian elimination with complete pivoting. +C +C The condition number of the continuous-time Lyapunov equation is +C estimated as +C +C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), +C +C where Omega and Theta are linear operators defined by +C +C Omega(W) = op(A)'*W + W*op(A), +C Theta(W) = inv(Omega(op(W)'*X + X*op(W))). +C +C The routine estimates the quantities +C +C sep(op(A),-op(A)') = 1 / norm(inv(Omega)) +C +C and norm(Theta) using 1-norm condition estimators. +C +C The forward error bound is estimated using a practical error bound +C similar to the one proposed in [2]. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Higham, N.J. +C Perturbation theory and backward error for AX-XB=C. +C BIT, vol. 33, pp. 124-136, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C The accuracy of the estimates obtained depends on the solution +C accuracy and on the properties of the 1-norm estimator. +C +C FURTHER COMMENTS +C +C The separation of op(A) and -op(A)' can also be defined as +C +C sep( op(A), -op(A)' ) = sigma_min( T ), +C +C where sigma_min(T) is the smallest singular value of the +C N*N-by-N*N matrix +C +C T = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) ). +C +C I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker +C product. The routine estimates sigma_min(T) by the reciprocal of +C an estimate of the 1-norm of inverse(T). The true reciprocal +C 1-norm of inverse(T) cannot differ from sigma_min(T) by more +C than a factor of N. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. +C This is an extended and improved version of Release 3.0 routine +C SB03RD. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO + INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N + DOUBLE PRECISION FERR, RCOND, SCALE, SEP +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), + $ T( LDT, * ), U( LDU, * ), WI( * ), WR( * ), + $ X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL JOBA, JOBC, JOBE, JOBS, JOBX, LOWER, NOFACT, + $ NOTRNA, UPDATE + CHARACTER CFACT, JOBL, SJOB + INTEGER LDW, NN, SDIM + DOUBLE PRECISION THNORM +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + EXTERNAL LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DGEES, DLACPY, DSCAL, MA02ED, MB01RU, SB03MY, + $ SB03QD, SB03QY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode option parameters. +C + JOBX = LSAME( JOB, 'X' ) + JOBS = LSAME( JOB, 'S' ) + JOBC = LSAME( JOB, 'C' ) + JOBE = LSAME( JOB, 'E' ) + JOBA = LSAME( JOB, 'A' ) + NOFACT = LSAME( FACT, 'N' ) + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + UPDATE = LSAME( LYAPUN, 'O' ) +C +C Compute workspace. +C + NN = N*N + IF( JOBX ) THEN + LDW = NN + ELSE IF( JOBS .OR. JOBC ) THEN + LDW = 2*NN + ELSE + LDW = 3*NN + END IF + IF( ( JOBE .OR. JOBA ).AND. .NOT.UPDATE ) + $ LDW = LDW + N - 1 + IF( NOFACT ) + $ LDW = MAX( LDW, 3*N ) +C +C Test the scalar input parameters. +C + INFO = 0 + IF( .NOT.( JOBX .OR. JOBS .OR. JOBC .OR. JOBE .OR. JOBA ) ) THEN + INFO = -1 + ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. + $ LSAME( TRANA, 'C' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( ( JOBC .OR. JOBE ) .AND. + $ ( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) )THEN + INFO = -7 + ELSE IF( LDA.LT.1 .OR. + $ ( LDA.LT.N .AND. ( ( UPDATE .AND. .NOT.JOBX ) .OR. + $ NOFACT ) ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.1 .OR. ( .NOT.JOBS .AND. LDC.LT.N ) ) THEN + INFO = -15 + ELSE IF( LDX.LT.1 .OR. ( .NOT.JOBS .AND. LDX.LT.N ) ) THEN + INFO = -17 + ELSE IF( LDWORK.LT.1 .OR. ( LDWORK.LT.LDW ) ) THEN + INFO = -25 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03TD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + IF( JOBX .OR. JOBA ) + $ SCALE = ONE + IF( JOBC .OR. JOBA ) + $ RCOND = ONE + IF( JOBE .OR. JOBA ) + $ FERR = ZERO + DWORK( 1 ) = ONE + RETURN + END IF +C + IF( NOFACT ) THEN +C +C Compute the Schur factorization of A. +C Workspace: need 3*N; +C prefer larger. +C + CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) + IF( UPDATE ) THEN + SJOB = 'V' + ELSE + SJOB = 'N' + END IF + CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, WR, + $ WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CFACT = 'F' + ELSE + CFACT = FACT + END IF +C + IF( JOBX .OR. JOBA ) THEN +C +C Copy the right-hand side in X. +C + CALL DLACPY( UPLO, N, N, C, LDC, X, LDX ) +C + IF( UPDATE ) THEN +C +C Transform the right-hand side. +C Workspace: need N*N. +C + CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, U, + $ LDU, X, LDX, DWORK, LDWORK, INFO ) + CALL DSCAL( N, HALF, X, LDX+1 ) + END IF +C +C Fill in the remaining triangle of X. +C + CALL MA02ED( UPLO, N, X, LDX ) +C +C Solve the transformed equation. +C + CALL SB03MY( TRANA, N, T, LDT, X, LDX, SCALE, INFO ) + IF( INFO.GT.0 ) + $ INFO = N + 1 +C + IF( UPDATE ) THEN +C +C Transform back the solution. +C + CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, X, LDX, + $ U, LDU, X, LDX, DWORK, LDWORK, INFO ) + CALL DSCAL( N, HALF, X, LDX+1 ) +C +C Fill in the remaining triangle of X. +C + CALL MA02ED( UPLO, N, X, LDX ) + END IF + END IF +C + IF( JOBS ) THEN +C +C Estimate sep(op(A),-op(A)'). +C Workspace: 2*N*N. +C + CALL SB03QY( 'Separation', TRANA, LYAPUN, N, T, LDT, U, LDU, X, + $ LDX, SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) +C + ELSE IF( .NOT.JOBX ) THEN +C +C Estimate the reciprocal condition and/or the error bound. +C Workspace: 2*N*N, if JOB = 'C'; +C 3*N*N + a*(N-1), where: +C a = 1, if JOB = 'E' or JOB = 'A', and LYAPUN = 'R'; +C a = 0, otherwise. +C + IF( JOBA ) THEN + JOBL = 'B' + ELSE + JOBL = JOB + END IF + CALL SB03QD( JOBL, CFACT, TRANA, UPLO, LYAPUN, N, SCALE, A, + $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, RCOND, + $ FERR, IWORK, DWORK, LDWORK, INFO ) + LDW = MAX( LDW, INT( DWORK( 1 ) ) ) + END IF +C + DWORK( 1 ) = DBLE( LDW ) +C + RETURN +C *** Last line of SB03TD *** + END diff --git a/mex/sources/libslicot/SB03UD.f b/mex/sources/libslicot/SB03UD.f new file mode 100644 index 000000000..f09443eb7 --- /dev/null +++ b/mex/sources/libslicot/SB03UD.f @@ -0,0 +1,554 @@ + SUBROUTINE SB03UD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, + $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD, + $ RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the real discrete-time Lyapunov matrix equation +C +C op(A)'*X*op(A) - X = scale*C, +C +C estimate the conditioning, and compute an error bound on the +C solution X, where op(A) = A or A' (A**T), the matrix A is N-by-N, +C the right hand side C and the solution X are N-by-N symmetric +C matrices (C = C', X = X'), and scale is an output scale factor, +C set less than or equal to 1 to avoid overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'X': Compute the solution only; +C = 'S': Compute the separation only; +C = 'C': Compute the reciprocal condition number only; +C = 'E': Compute the error bound only; +C = 'A': Compute all: the solution, separation, reciprocal +C condition number, and the error bound. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, T and U (if LYAPUN = 'O') contain the +C factors from the real Schur factorization of the +C matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in T and U (if +C LYAPUN = 'O'). +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C UPLO CHARACTER*1 +C Specifies which part of the symmetric matrix C is to be +C used, as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part. +C +C LYAPUN CHARACTER*1 +C Specifies whether or not the original or "reduced" +C Lyapunov equations should be solved, as follows: +C = 'O': Solve the original Lyapunov equations, updating +C the right-hand sides and solutions with the +C matrix U, e.g., X <-- U'*X*U; +C = 'R': Solve reduced Lyapunov equations only, without +C updating the right-hand sides and solutions. +C This means that a real Schur form T of A appears +C in the equation, instead of A. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X, and C. N >= 0. +C +C SCALE (input or output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'E', SCALE is an input argument: +C the scale factor, set by a Lyapunov solver. +C 0 <= SCALE <= 1. +C If JOB = 'X' or JOB = 'A', SCALE is an output argument: +C the scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C If JOB = 'S', this argument is not used. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C If FACT = 'N' or (LYAPUN = 'O' and JOB <> 'X'), the +C leading N-by-N part of this array must contain the +C original matrix A. +C If FACT = 'F' and (LYAPUN = 'R' or JOB = 'X'), A is +C not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O' and +C JOB <> 'X'; +C LDA >= 1, otherwise. +C +C T (input/output) DOUBLE PRECISION array, dimension +C (LDT,N) +C If FACT = 'F', then on entry the leading N-by-N upper +C Hessenberg part of this array must contain the upper +C quasi-triangular matrix T in Schur canonical form from a +C Schur factorization of A. +C If FACT = 'N', then this array need not be set on input. +C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the +C leading N-by-N upper Hessenberg part of this array +C contains the upper quasi-triangular matrix T in Schur +C canonical form from a Schur factorization of A. +C The contents of array T is not modified if FACT = 'F'. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= MAX(1,N). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,N) +C If LYAPUN = 'O' and FACT = 'F', then U is an input +C argument and on entry, the leading N-by-N part of this +C array must contain the orthogonal matrix U from a real +C Schur factorization of A. +C If LYAPUN = 'O' and FACT = 'N', then U is an output +C argument and on exit, if INFO = 0 or INFO = N+1, it +C contains the orthogonal N-by-N matrix from a real Schur +C factorization of A. +C If LYAPUN = 'R', the array U is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= 1, if LYAPUN = 'R'; +C LDU >= MAX(1,N), if LYAPUN = 'O'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C If JOB <> 'S' and UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular part of the matrix C of the original Lyapunov +C equation (with matrix A), if LYAPUN = 'O', or of the +C reduced Lyapunov equation (with matrix T), if +C LYAPUN = 'R'. +C If JOB <> 'S' and UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular part of the matrix C of the original Lyapunov +C equation (with matrix A), if LYAPUN = 'O', or of the +C reduced Lyapunov equation (with matrix T), if +C LYAPUN = 'R'. +C The remaining strictly triangular part of this array is +C used as workspace. +C If JOB = 'X', then this array may be identified with X +C in the call of this routine. +C If JOB = 'S', the array C is not referenced. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= 1, if JOB = 'S'; +C LDC >= MAX(1,N), otherwise. +C +C X (input or output) DOUBLE PRECISION array, dimension +C (LDX,N) +C If JOB = 'C' or 'E', then X is an input argument and on +C entry, the leading N-by-N part of this array must contain +C the symmetric solution matrix X of the original Lyapunov +C equation (with matrix A), if LYAPUN = 'O', or of the +C reduced Lyapunov equation (with matrix T), if +C LYAPUN = 'R'. +C If JOB = 'X' or 'A', then X is an output argument and on +C exit, if INFO = 0 or INFO = N+1, the leading N-by-N part +C of this array contains the symmetric solution matrix X of +C of the original Lyapunov equation (with matrix A), if +C LYAPUN = 'O', or of the reduced Lyapunov equation (with +C matrix T), if LYAPUN = 'R'. +C If JOB = 'S', the array X is not referenced. +C +C LDX INTEGER +C The leading dimension of the array X. +C LDX >= 1, if JOB = 'S'; +C LDX >= MAX(1,N), otherwise. +C +C SEPD (output) DOUBLE PRECISION +C If JOB = 'S' or JOB = 'C' or JOB = 'A', and INFO = 0 or +C INFO = N+1, SEPD contains the estimated separation of the +C matrices op(A) and op(A)', sepd(op(A),op(A)'). +C If N = 0, or X = 0, or JOB = 'X' or JOB = 'E', SEPD is not +C referenced. +C +C RCOND (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'A', an estimate of the reciprocal +C condition number of the continuous-time Lyapunov equation. +C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. +C If JOB = 'X' or JOB = 'S' or JOB = 'E', RCOND is not +C referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = N+1, +C FERR contains an estimated forward error bound for the +C solution X. If XTRUE is the true solution, FERR bounds the +C relative error in the computed solution, measured in the +C Frobenius norm: norm(X - XTRUE)/norm(XTRUE). +C If N = 0 or X = 0, FERR is set to 0. +C If JOB = 'X' or JOB = 'S' or JOB = 'C', FERR is not +C referenced. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI +C contain the real and imaginary parts, respectively, of the +C eigenvalues of A. +C If FACT = 'F', WR and WI are not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C This array is not referenced if JOB = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C If JOB = 'X', then +C LDWORK >= MAX(1,N*N,2*N), if FACT = 'F'; +C LDWORK >= MAX(1,N*N,3*N), if FACT = 'N'. +C If JOB = 'S', then +C LDWORK >= MAX(3,2*N*N). +C If JOB = 'C', then +C LDWORK >= MAX(3,2*N*N) + N*N. +C If JOB = 'E', or JOB = 'A', then +C LDWORK >= MAX(3,2*N*N) + N*N + 2*N. +C For optimum performance LDWORK should sometimes be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, i <= N, the QR algorithm failed to +C complete the reduction to Schur canonical form (see +C LAPACK Library routine DGEES); on exit, the matrix +C T(i+1:N,i+1:N) contains the partially converged +C Schur form, and the elements i+1:n of WR and WI +C contain the real and imaginary parts, respectively, +C of the converged eigenvalues; this error is unlikely +C to appear; +C = N+1: if the matrix T has almost reciprocal eigenvalues; +C perturbed values were used to solve Lyapunov +C equations, but the matrix T, if given (for +C FACT = 'F'), is unchanged. +C +C METHOD +C +C After reducing matrix A to real Schur canonical form (if needed), +C a discrete-time version of the Bartels-Stewart algorithm is used. +C A set of equivalent linear algebraic systems of equations of order +C at most four are formed and solved using Gaussian elimination with +C complete pivoting. +C +C The condition number of the discrete-time Lyapunov equation is +C estimated as +C +C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), +C +C where Omega and Theta are linear operators defined by +C +C Omega(W) = op(A)'*W*op(A) - W, +C Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))). +C +C The routine estimates the quantities +C +C sepd(op(A),op(A)') = 1 / norm(inv(Omega)) +C +C and norm(Theta) using 1-norm condition estimators. +C +C The forward error bound is estimated using a practical error bound +C similar to the one proposed in [3]. +C +C REFERENCES +C +C [1] Barraud, A.Y. T +C A numerical algorithm to solve A XA - X = Q. +C IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977. +C +C [2] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [3] Higham, N.J. +C Perturbation theory and backward error for AX-XB=C. +C BIT, vol. 33, pp. 124-136, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C The accuracy of the estimates obtained depends on the solution +C accuracy and on the properties of the 1-norm estimator. +C +C FURTHER COMMENTS +C +C The "separation" sepd of op(A) and op(A)' can also be defined as +C +C sepd( op(A), op(A)' ) = sigma_min( T ), +C +C where sigma_min(T) is the smallest singular value of the +C N*N-by-N*N matrix +C +C T = kprod( op(A)', op(A)' ) - I(N**2). +C +C I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the +C Kronecker product. The routine estimates sigma_min(T) by the +C reciprocal of an estimate of the 1-norm of inverse(T). The true +C reciprocal 1-norm of inverse(T) cannot differ from sigma_min(T) by +C more than a factor of N. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. +C This is an extended and improved version of Release 3.0 routine +C SB03PD. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO + INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N + DOUBLE PRECISION FERR, RCOND, SCALE, SEPD +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), + $ T( LDT, * ), U( LDU, * ), WI( * ), WR( * ), + $ X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL JOBA, JOBC, JOBE, JOBS, JOBX, LOWER, NOFACT, + $ NOTRNA, UPDATE + CHARACTER CFACT, JOBL, SJOB + INTEGER LDW, NN, SDIM + DOUBLE PRECISION THNORM +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + EXTERNAL LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DGEES, DLACPY, DSCAL, MA02ED, MB01RU, SB03MX, + $ SB03SD, SB03SY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode option parameters. +C + JOBX = LSAME( JOB, 'X' ) + JOBS = LSAME( JOB, 'S' ) + JOBC = LSAME( JOB, 'C' ) + JOBE = LSAME( JOB, 'E' ) + JOBA = LSAME( JOB, 'A' ) + NOFACT = LSAME( FACT, 'N' ) + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + UPDATE = LSAME( LYAPUN, 'O' ) +C +C Compute workspace. +C + NN = N*N + IF( JOBX ) THEN + IF( NOFACT ) THEN + LDW = MAX( 1, NN, 3*N ) + ELSE + LDW = MAX( 1, NN, 2*N ) + END IF + ELSE IF( JOBS ) THEN + LDW = MAX( 3, 2*NN ) + ELSE IF( JOBC ) THEN + LDW = MAX( 3, 2*NN ) + NN + ELSE + LDW = MAX( 3, 2*NN ) + NN + 2*N + END IF +C +C Test the scalar input parameters. +C + INFO = 0 + IF( .NOT.( JOBX .OR. JOBS .OR. JOBC .OR. JOBE .OR. JOBA ) ) THEN + INFO = -1 + ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. + $ LSAME( TRANA, 'C' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( ( JOBC .OR. JOBE ) .AND. + $ ( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) )THEN + INFO = -7 + ELSE IF( LDA.LT.1 .OR. + $ ( LDA.LT.N .AND. ( ( UPDATE .AND. .NOT.JOBX ) .OR. + $ NOFACT ) ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.1 .OR. ( .NOT.JOBS .AND. LDC.LT.N ) ) THEN + INFO = -15 + ELSE IF( LDX.LT.1 .OR. ( .NOT.JOBS .AND. LDX.LT.N ) ) THEN + INFO = -17 + ELSE IF( LDWORK.LT.LDW ) THEN + INFO = -25 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03UD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + IF( JOBX .OR. JOBA ) + $ SCALE = ONE + IF( JOBC .OR. JOBA ) + $ RCOND = ONE + IF( JOBE .OR. JOBA ) + $ FERR = ZERO + DWORK( 1 ) = ONE + RETURN + END IF +C + IF( NOFACT ) THEN +C +C Compute the Schur factorization of A. +C Workspace: need 3*N; +C prefer larger. +C + CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) + IF( UPDATE ) THEN + SJOB = 'V' + ELSE + SJOB = 'N' + END IF + CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, WR, + $ WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + IF( INFO.GT.0 ) + $ RETURN + LDW = MAX( LDW, INT( DWORK( 1 ) ) ) + CFACT = 'F' + ELSE + CFACT = FACT + END IF +C + IF( JOBX .OR. JOBA ) THEN +C +C Copy the right-hand side in X. +C + CALL DLACPY( UPLO, N, N, C, LDC, X, LDX ) +C + IF( UPDATE ) THEN +C +C Transform the right-hand side. +C Workspace: need N*N. +C + CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, U, + $ LDU, X, LDX, DWORK, LDWORK, INFO ) + CALL DSCAL( N, HALF, X, LDX+1 ) + END IF +C +C Fill in the remaining triangle of X. +C + CALL MA02ED( UPLO, N, X, LDX ) +C +C Solve the transformed equation. +C Workspace: 2*N. +C + CALL SB03MX( TRANA, N, T, LDT, X, LDX, SCALE, DWORK, INFO ) + IF( INFO.GT.0 ) + $ INFO = N + 1 +C + IF( UPDATE ) THEN +C +C Transform back the solution. +C + CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, X, LDX, + $ U, LDU, X, LDX, DWORK, LDWORK, INFO ) + CALL DSCAL( N, HALF, X, LDX+1 ) +C +C Fill in the remaining triangle of X. +C + CALL MA02ED( UPLO, N, X, LDX ) + END IF + END IF +C + IF( JOBS ) THEN +C +C Estimate sepd(op(A),op(A)'). +C Workspace: MAX(3,2*N*N). +C + CALL SB03SY( 'Separation', TRANA, LYAPUN, N, T, LDT, U, LDU, + $ DWORK, 1, SEPD, THNORM, IWORK, DWORK, LDWORK, + $ INFO ) +C + ELSE IF( .NOT.JOBX ) THEN +C +C Estimate the reciprocal condition and/or the error bound. +C Workspace: MAX(3,2*N*N) + N*N + a*N, where: +C a = 2, if JOB = 'E' or JOB = 'A'; +C a = 0, otherwise. +C + IF( JOBA ) THEN + JOBL = 'B' + ELSE + JOBL = JOB + END IF + CALL SB03SD( JOBL, CFACT, TRANA, UPLO, LYAPUN, N, SCALE, A, + $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD, RCOND, + $ FERR, IWORK, DWORK, LDWORK, INFO ) + LDW = MAX( LDW, INT( DWORK( 1 ) ) ) + END IF +C + DWORK( 1 ) = DBLE( LDW ) +C + RETURN +C *** Last line of SB03UD *** + END diff --git a/mex/sources/libslicot/SB04MD.f b/mex/sources/libslicot/SB04MD.f new file mode 100644 index 000000000..c618c8ac7 --- /dev/null +++ b/mex/sources/libslicot/SB04MD.f @@ -0,0 +1,347 @@ + SUBROUTINE SB04MD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X the continuous-time Sylvester equation +C +C AX + XB = C +C +C where A, B, C and X are general N-by-N, M-by-M, N-by-M and +C N-by-M matrices respectively. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the coefficient matrix A of the equation. +C On exit, the leading N-by-N upper Hessenberg part of this +C array contains the matrix H, and the remainder of the +C leading N-by-N part, together with the elements 2,3,...,N +C of array DWORK, contain the orthogonal transformation +C matrix U (stored in factored form). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading M-by-M part of this array must +C contain the coefficient matrix B of the equation. +C On exit, the leading M-by-M part of this array contains +C the quasi-triangular Schur factor S of the matrix B'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading N-by-M part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading N-by-M part of this array contains +C the solution matrix X of the problem. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,M) +C The leading M-by-M part of this array contains the +C orthogonal matrix Z used to transform B' to real upper +C Schur form. +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= MAX(1,M). +C +C Workspace +C +C IWORK INTEGER array, dimension (4*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2), DWORK(3),..., DWORK(N) contain +C the scalar factors of the elementary reflectors used to +C reduce A to upper Hessenberg form, as returned by LAPACK +C Library routine DGEHRD. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = MAX(1, 2*N*N + 8*N, 5*M, N + M). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, 1 <= i <= M, the QR algorithm failed to +C compute all the eigenvalues (see LAPACK Library +C routine DGEES); +C > M: if a singular matrix was encountered whilst solving +C for the (INFO-M)-th column of matrix X. +C +C METHOD +C +C The matrix A is transformed to upper Hessenberg form H = U'AU by +C the orthogonal transformation matrix U; matrix B' is transformed +C to real upper Schur form S = Z'B'Z using the orthogonal +C transformation matrix Z. The matrix C is also multiplied by the +C transformations, F = U'CZ, and the solution matrix Y of the +C transformed system +C +C HY + YS' = F +C +C is computed by back substitution. Finally, the matrix Y is then +C multiplied by the orthogonal transformation matrices, X = UYZ', in +C order to obtain the solution matrix X to the original problem. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C 3 3 2 2 +C The algorithm requires about (5/3) N + 10 M + 5 N M + 2.5 M N +C operations and is backward stable. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04AD by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000, Aug. 2000. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER I, IEIG, IFAIL, IHI, ILO, IND, ITAU, JWORK, + $ SDIM, WRKOPT +C .. Local Scalars .. + LOGICAL SELECT +C .. Local Arrays .. + LOGICAL BWORK(1) +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEHRD, DGEMM, DGEMV, DLACPY, + $ DORMHR, DSWAP, SB04MU, SB04MY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDZ.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDWORK.LT.MAX( 1, 2*N*N + 8*N, 5*M, N + M ) ) THEN + INFO = -13 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB04MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + ILO = 1 + IHI = N + WRKOPT = 1 +C +C Step 1 : Reduce A to upper Hessenberg and B' to quasi-upper +C triangular. That is, H = U' * A * U (store U in factored +C form) and S = Z' * B' * Z (save Z). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + DO 20 I = 2, M + CALL DSWAP( I-1, B(1,I), 1, B(I,1), LDB ) + 20 CONTINUE +C +C Workspace: need 5*M; +C prefer larger. +C + IEIG = M + 1 + JWORK = IEIG + M + CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, B, LDB, + $ SDIM, DWORK, DWORK(IEIG), Z, LDZ, DWORK(JWORK), + $ LDWORK-JWORK+1, BWORK, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Workspace: need 2*N; +C prefer N + N*NB. +C + ITAU = 2 + JWORK = ITAU + N - 1 + CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Step 2 : Form F = ( U' * C ) * Z. Use BLAS 3, if enough space. +C +C Workspace: need N + M; +C prefer N + M*NB. +C + CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( LDWORK.GE.JWORK - 1 + N*M ) THEN + CALL DGEMM( 'No transpose', 'No transpose', N, M, M, ONE, C, + $ LDC, Z, LDZ, ZERO, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) + WRKOPT = MAX( WRKOPT, JWORK - 1 + N*M ) + ELSE +C + DO 40 I = 1, N + CALL DGEMV( 'Transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, + $ ZERO, DWORK(JWORK), 1 ) + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + 40 CONTINUE +C + END IF +C + IND = M + 60 CONTINUE + IF ( IND.GT.1 ) THEN +C +C Step 3 : Solve H * Y + Y * S' = F for Y. +C + IF ( B(IND,IND-1).EQ.ZERO ) THEN +C +C Solve a special linear algebraic system of order N. +C Workspace: N*(N+1)/2 + 3*N. +C + CALL SB04MY( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + WRKOPT = MAX( WRKOPT, JWORK + N*( N + 1 )/2 + 2*N - 1 ) + IND = IND - 1 + ELSE +C +C Solve a special linear algebraic system of order 2*N. +C Workspace: 2*N*N + 8*N; +C + CALL SB04MU( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + WRKOPT = MAX( WRKOPT, JWORK + 2*N*N + 7*N - 1 ) + IND = IND - 2 + END IF + GO TO 60 + ELSE IF ( IND.EQ.1 ) THEN +C +C Solve a special linear algebraic system of order N. +C Workspace: N*(N+1)/2 + 3*N; +C + CALL SB04MY( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + WRKOPT = MAX( WRKOPT, JWORK + N*( N + 1 )/2 + 2*N - 1 ) + END IF +C +C Step 4 : Form C = ( U * Y ) * Z'. Use BLAS 3, if enough space. +C +C Workspace: need N + M; +C prefer N + M*NB. +C + CALL DORMHR( 'Left', 'No transpose', N, M, ILO, IHI, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( LDWORK.GE.JWORK - 1 + N*M ) THEN + CALL DGEMM( 'No transpose', 'Transpose', N, M, M, ONE, C, LDC, + $ Z, LDZ, ZERO, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) + ELSE +C + DO 80 I = 1, N + CALL DGEMV( 'No transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, + $ ZERO, DWORK(JWORK), 1 ) + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + 80 CONTINUE + END IF +C + RETURN +C *** Last line of SB04MD *** + END diff --git a/mex/sources/libslicot/SB04MR.f b/mex/sources/libslicot/SB04MR.f new file mode 100644 index 000000000..a8aa560cd --- /dev/null +++ b/mex/sources/libslicot/SB04MR.f @@ -0,0 +1,222 @@ + SUBROUTINE SB04MR( M, D, IPR, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a linear algebraic system of order M whose coefficient +C matrix has zeros below the second subdiagonal. The matrix is +C stored compactly, row-wise. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the system. M >= 0. +C Note that parameter M should have twice the value in the +C original problem (see SLICOT Library routine SB04MU). +C +C D (input/output) DOUBLE PRECISION array, dimension +C (M*(M+1)/2+3*M) +C On entry, the first M*(M+1)/2 + 2*M elements of this array +C must contain the coefficient matrix, stored compactly, +C row-wise, and the next M elements must contain the right +C hand side of the linear system, as set by SLICOT Library +C routine SB04MU. +C On exit, the content of this array is updated, the last M +C elements containing the solution with components +C interchanged (see IPR). +C +C IPR (output) INTEGER array, dimension (2*M) +C The leading M elements contain information about the +C row interchanges performed for solving the system. +C Specifically, the i-th component of the solution is +C specified by IPR(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if a singular matrix was encountered. +C +C METHOD +C +C Gaussian elimination with partial pivoting is used. The rows of +C the matrix are not actually permuted, only their indices are +C interchanged in array IPR. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB04AR by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, M +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION D(*) +C .. Local Scalars .. + INTEGER I, I1, I2, IPRM, IPRM1, J, K, L, M1, MPI, MPI1, + $ MPI2 + DOUBLE PRECISION D1, D2, D3, DMAX +C .. External Subroutines .. + EXTERNAL DAXPY +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + INFO = 0 + I2 = ( M*( M + 5 ) )/2 + MPI = M + IPRM = I2 + M1 = M + I1 = 1 +C + DO 20 I = 1, M + MPI = MPI + 1 + IPRM = IPRM + 1 + IPR(MPI) = I1 + IPR(I) = IPRM + I1 = I1 + M1 + IF ( I.GE.3 ) M1 = M1 - 1 + 20 CONTINUE +C + M1 = M - 1 + MPI1 = M + 1 +C +C Reduce to upper triangular form. +C + DO 80 I = 1, M1 + MPI = MPI1 + MPI1 = MPI1 + 1 + IPRM = IPR(MPI) + D1 = D(IPRM) + I1 = 2 + IF ( I.EQ.M1 ) I1 = 1 + MPI2 = MPI + I1 + L = 0 + DMAX = ABS( D1 ) +C + DO 40 J = MPI1, MPI2 + D2 = D(IPR(J)) + D3 = ABS( D2 ) + IF ( D3.GT.DMAX ) THEN + DMAX = D3 + D1 = D2 + L = J - MPI + END IF + 40 CONTINUE +C +C Check singularity. +C + IF ( DMAX.EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C + IF ( L.GT.0 ) THEN +C +C Permute the row indices. +C + K = IPRM + J = MPI + L + IPRM = IPR(J) + IPR(J) = K + IPR(MPI) = IPRM + K = IPR(I) + I2 = I + L + IPR(I) = IPR(I2) + IPR(I2) = K + END IF + IPRM = IPRM + 1 +C +C Annihilate the subdiagonal elements of the matrix. +C + I2 = I + D3 = D(IPR(I)) +C + DO 60 J = MPI1, MPI2 + I2 = I2 + 1 + IPRM1 = IPR(J) + DMAX = -D(IPRM1)/D1 + D(IPR(I2)) = D(IPR(I2)) + DMAX*D3 + CALL DAXPY( M-I, DMAX, D(IPRM), 1, D(IPRM1+1), 1 ) + 60 CONTINUE +C + IPR(MPI1) = IPR(MPI1) + 1 + IF ( I.NE.M1 ) IPR(MPI2) = IPR(MPI2) + 1 + 80 CONTINUE +C + MPI = M + M + IPRM = IPR(MPI) +C +C Check singularity. +C + IF ( D(IPRM).EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C +C Back substitution. +C + D(IPR(M)) = D(IPR(M))/D(IPRM) +C + DO 120 I = M1, 1, -1 + MPI = MPI - 1 + IPRM = IPR(MPI) + IPRM1 = IPRM + DMAX = ZERO +C + DO 100 K = I+1, M + IPRM1 = IPRM1 + 1 + DMAX = DMAX + D(IPR(K))*D(IPRM1) + 100 CONTINUE +C + D(IPR(I)) = ( D(IPR(I)) - DMAX )/D(IPRM) + 120 CONTINUE +C + RETURN +C *** Last line of SB04MR *** + END diff --git a/mex/sources/libslicot/SB04MU.f b/mex/sources/libslicot/SB04MU.f new file mode 100644 index 000000000..ed3879eca --- /dev/null +++ b/mex/sources/libslicot/SB04MU.f @@ -0,0 +1,190 @@ + SUBROUTINE SB04MU( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct and solve a linear algebraic system of order 2*M +C whose coefficient matrix has zeros below the second subdiagonal. +C Such systems appear when solving continuous-time Sylvester +C equations using the Hessenberg-Schur method. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix B. N >= 0. +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C IND (input) INTEGER +C IND and IND - 1 specify the indices of the columns in C +C to be computed. IND > 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain an +C upper Hessenberg matrix. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain a +C matrix in real Schur form. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading M-by-N part of this array contains +C the matrix C with columns IND-1 and IND updated. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Workspace +C +C D DOUBLE PRECISION array, dimension (2*M*M+7*M) +C +C IPR INTEGER array, dimension (4*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C > 0: if INFO = IND, a singular matrix was encountered. +C +C METHOD +C +C A special linear algebraic system of order 2*M, whose coefficient +C matrix has zeros below the second subdiagonal is constructed and +C solved. The coefficient matrix is stored compactly, row-wise. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB04AU by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, IND, LDA, LDB, LDC, M, N +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) +C .. Local Scalars .. + INTEGER I, I2, IND1, J, K, K1, K2, M2 + DOUBLE PRECISION TEMP +C .. External Subroutines .. + EXTERNAL DAXPY, SB04MR +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + IND1 = IND - 1 +C + DO 20 I = IND + 1, N + CALL DAXPY( M, -B(IND1,I), C(1,I), 1, C(1,IND1), 1 ) + CALL DAXPY( M, -B(IND,I), C(1,I), 1, C(1,IND), 1 ) + 20 CONTINUE +C +C Construct the linear algebraic system of order 2*M. +C + K1 = -1 + M2 = 2*M + I2 = M*(M2 + 5) + K = M2 +C + DO 60 I = 1, M +C + DO 40 J = MAX( 1, I - 1 ), M + K1 = K1 + 2 + K2 = K1 + K + TEMP = A(I,J) + IF ( I.NE.J ) THEN + D(K1) = TEMP + D(K1+1) = ZERO + IF ( J.GT.I ) D(K2) = ZERO + D(K2+1) = TEMP + ELSE + D(K1) = TEMP + B(IND1,IND1) + D(K1+1) = B(IND1,IND) + D(K2) = B(IND,IND1) + D(K2+1) = TEMP + B(IND,IND) + END IF + 40 CONTINUE +C + K1 = K2 + K = K - MIN( 2, I ) +C +C Store the right hand side. +C + I2 = I2 + 2 + D(I2) = C(I,IND) + D(I2-1) = C(I,IND1) + 60 CONTINUE +C +C Solve the linear algebraic system and store the solution in C. +C + CALL SB04MR( M2, D, IPR, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = IND + ELSE + I2 = 0 +C + DO 80 I = 1, M + I2 = I2 + 2 + C(I,IND1) = D(IPR(I2-1)) + C(I,IND) = D(IPR(I2)) + 80 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB04MU *** + END diff --git a/mex/sources/libslicot/SB04MW.f b/mex/sources/libslicot/SB04MW.f new file mode 100644 index 000000000..9a56f4658 --- /dev/null +++ b/mex/sources/libslicot/SB04MW.f @@ -0,0 +1,194 @@ + SUBROUTINE SB04MW( M, D, IPR, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a linear algebraic system of order M whose coefficient +C matrix is in upper Hessenberg form, stored compactly, row-wise. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the system. M >= 0. +C +C D (input/output) DOUBLE PRECISION array, dimension +C (M*(M+1)/2+2*M) +C On entry, the first M*(M+1)/2 + M elements of this array +C must contain an upper Hessenberg matrix, stored compactly, +C row-wise, and the next M elements must contain the right +C hand side of the linear system, as set by SLICOT Library +C routine SB04MY. +C On exit, the content of this array is updated, the last M +C elements containing the solution with components +C interchanged (see IPR). +C +C IPR (output) INTEGER array, dimension (2*M) +C The leading M elements contain information about the +C row interchanges performed for solving the system. +C Specifically, the i-th component of the solution is +C specified by IPR(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if a singular matrix was encountered. +C +C METHOD +C +C Gaussian elimination with partial pivoting is used. The rows of +C the matrix are not actually permuted, only their indices are +C interchanged in array IPR. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB04AW by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, M +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION D(*) +C .. Local Scalars .. + INTEGER I, I1, IPRM, IPRM1, K, M1, M2, MPI + DOUBLE PRECISION D1, D2, MULT +C .. External Subroutines .. + EXTERNAL DAXPY +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + INFO = 0 + M1 = ( M*( M + 3 ) )/2 + M2 = M + M + MPI = M + IPRM = M1 + M1 = M + I1 = 1 +C + DO 20 I = 1, M + MPI = MPI + 1 + IPRM = IPRM + 1 + IPR(MPI) = I1 + IPR(I) = IPRM + I1 = I1 + M1 + IF ( I.GT.1 ) M1 = M1 - 1 + 20 CONTINUE +C + M1 = M - 1 + MPI = M +C +C Reduce to upper triangular form. +C + DO 40 I = 1, M1 + I1 = I + 1 + MPI = MPI + 1 + IPRM = IPR(MPI) + IPRM1 = IPR(MPI+1) + D1 = D(IPRM) + D2 = D(IPRM1) + IF ( ABS( D1 ).LE.ABS( D2 ) ) THEN +C +C Permute the row indices. +C + K = IPRM + IPR(MPI) = IPRM1 + IPRM = IPRM1 + IPRM1 = K + K = IPR(I) + IPR(I) = IPR(I1) + IPR(I1) = K + D1 = D2 + END IF +C +C Check singularity. +C + IF ( D1.EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C + MULT = -D(IPRM1)/D1 + IPRM1 = IPRM1 + 1 + IPR(MPI+1) = IPRM1 +C +C Annihilate the subdiagonal elements of the matrix. +C + D(IPR(I1)) = D(IPR(I1)) + MULT*D(IPR(I)) + CALL DAXPY( M-I, MULT, D(IPRM+1), 1, D(IPRM1), 1 ) + 40 CONTINUE +C +C Check singularity. +C + IF ( D(IPR(M2)).EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C +C Back substitution. +C + D(IPR(M)) = D(IPR(M))/D(IPR(M2)) + MPI = M2 +C + DO 80 I = M1, 1, -1 + MPI = MPI - 1 + IPRM = IPR(MPI) + IPRM1 = IPRM + MULT = ZERO +C + DO 60 I1 = I + 1, M + IPRM1 = IPRM1 + 1 + MULT = MULT + D(IPR(I1))*D(IPRM1) + 60 CONTINUE +C + D(IPR(I)) = ( D(IPR(I)) - MULT )/D(IPRM) + 80 CONTINUE +C + RETURN +C *** Last line of SB04MW *** + END diff --git a/mex/sources/libslicot/SB04MY.f b/mex/sources/libslicot/SB04MY.f new file mode 100644 index 000000000..d8e568e7d --- /dev/null +++ b/mex/sources/libslicot/SB04MY.f @@ -0,0 +1,168 @@ + SUBROUTINE SB04MY( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct and solve a linear algebraic system of order M whose +C coefficient matrix is in upper Hessenberg form. Such systems +C appear when solving Sylvester equations using the Hessenberg-Schur +C method. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix B. N >= 0. +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C IND (input) INTEGER +C The index of the column in C to be computed. IND >= 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain an +C upper Hessenberg matrix. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain a +C matrix in real Schur form. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading M-by-N part of this array contains +C the matrix C with column IND updated. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Workspace +C +C D DOUBLE PRECISION array, dimension (M*(M+1)/2+2*M) +C +C IPR INTEGER array, dimension (2*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C > 0: if INFO = IND, a singular matrix was encountered. +C +C METHOD +C +C A special linear algebraic system of order M, with coefficient +C matrix in upper Hessenberg form is constructed and solved. The +C coefficient matrix is stored compactly, row-wise. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB04AY by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INFO, IND, LDA, LDB, LDC, M, N +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) +C .. Local Scalars .. + INTEGER I, I2, J, K, K1, K2, M1 +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, SB04MW +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + DO 20 I = IND + 1, N + CALL DAXPY( M, -B(IND,I), C(1,I), 1, C(1,IND), 1 ) + 20 CONTINUE +C + M1 = M + 1 + I2 = ( M*M1 )/2 + M1 + K2 = 1 + K = M +C +C Construct the linear algebraic system of order M. +C + DO 40 I = 1, M + J = M1 - K + CALL DCOPY ( K, A(I,J), LDA, D(K2), 1 ) + K1 = K2 + K2 = K2 + K + IF ( I.GT.1 ) THEN + K1 = K1 + 1 + K = K - 1 + END IF + D(K1) = D(K1) + B(IND,IND) +C +C Store the right hand side. +C + D(I2) = C(I,IND) + I2 = I2 + 1 + 40 CONTINUE +C +C Solve the linear algebraic system and store the solution in C. +C + CALL SB04MW( M, D, IPR, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = IND + ELSE +C + DO 60 I = 1, M + C(I,IND) = D(IPR(I)) + 60 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB04MY *** + END diff --git a/mex/sources/libslicot/SB04ND.f b/mex/sources/libslicot/SB04ND.f new file mode 100644 index 000000000..b567088ac --- /dev/null +++ b/mex/sources/libslicot/SB04ND.f @@ -0,0 +1,405 @@ + SUBROUTINE SB04ND( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C, + $ LDC, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X the continuous-time Sylvester equation +C +C AX + XB = C, +C +C with at least one of the matrices A or B in Schur form and the +C other in Hessenberg or Schur form (both either upper or lower); +C A, B, C and X are N-by-N, M-by-M, N-by-M, and N-by-M matrices, +C respectively. +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHU CHARACTER*1 +C Indicates whether A and/or B is/are in Schur or +C Hessenberg form as follows: +C = 'A': A is in Schur form, B is in Hessenberg form; +C = 'B': B is in Schur form, A is in Hessenberg form; +C = 'S': Both A and B are in Schur form. +C +C ULA CHARACTER*1 +C Indicates whether A is in upper or lower Schur form or +C upper or lower Hessenberg form as follows: +C = 'U': A is in upper Hessenberg form if ABSCHU = 'B' and +C upper Schur form otherwise; +C = 'L': A is in lower Hessenberg form if ABSCHU = 'B' and +C lower Schur form otherwise. +C +C ULB CHARACTER*1 +C Indicates whether B is in upper or lower Schur form or +C upper or lower Hessenberg form as follows: +C = 'U': B is in upper Hessenberg form if ABSCHU = 'A' and +C upper Schur form otherwise; +C = 'L': B is in lower Hessenberg form if ABSCHU = 'A' and +C lower Schur form otherwise. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C coefficient matrix A of the equation. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading M-by-M part of this array must contain the +C coefficient matrix B of the equation. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading N-by-M part of this array must +C contain the coefficient matrix C of the equation. +C On exit, if INFO = 0, the leading N-by-M part of this +C array contains the solution matrix X of the problem. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity in +C the Sylvester equation. If the user sets TOL > 0, then the +C given value of TOL is used as a lower bound for the +C reciprocal condition number; a matrix whose estimated +C condition number is less than 1/TOL is considered to be +C nonsingular. If the user sets TOL <= 0, then a default +C tolerance, defined by TOLDEF = EPS, is used instead, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). +C This parameter is not referenced if ABSCHU = 'S', +C ULA = 'U', and ULB = 'U'. +C +C Workspace +C +C IWORK INTEGER array, dimension (2*MAX(M,N)) +C This parameter is not referenced if ABSCHU = 'S', +C ULA = 'U', and ULB = 'U'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C This parameter is not referenced if ABSCHU = 'S', +C ULA = 'U', and ULB = 'U'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = 0, if ABSCHU = 'S', ULA = 'U', and ULB = 'U'; +C LDWORK = 2*MAX(M,N)*(4 + 2*MAX(M,N)), otherwise. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if a (numerically) singular matrix T was encountered +C during the computation of the solution matrix X. +C That is, the estimated reciprocal condition number +C of T is less than or equal to TOL. +C +C METHOD +C +C Matrices A and B are assumed to be in (upper or lower) Hessenberg +C or Schur form (with at least one of them in Schur form). The +C solution matrix X is then computed by rows or columns via the back +C substitution scheme proposed by Golub, Nash and Van Loan (see +C [1]), which involves the solution of triangular systems of +C equations that are constructed recursively and which may be nearly +C singular if A and -B have close eigenvalues. If near singularity +C is detected, then the routine returns with the Error Indicator +C (INFO) set to 1. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C 2 2 +C The algorithm requires approximately 5M N + 0.5MN operations in +C 2 2 +C the worst case and 2.5M N + 0.5MN operations in the best case +C (where M is the order of the matrix in Hessenberg form and N is +C the order of the matrix in Schur form) and is mixed stable (see +C [1]). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04BD by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHU, ULA, ULB + INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) +C .. Local Scalars .. + CHARACTER ABSCHR + LOGICAL LABSCB, LABSCS, LULA, LULB + INTEGER FWD, I, IBEG, IEND, INCR, IPINCR, ISTEP, JWORK, + $ LDW, MAXMN + DOUBLE PRECISION SCALE, TOL1 +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DTRSYL, SB04NV, SB04NW, SB04NX, SB04NY, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 + MAXMN = MAX( M, N ) + LABSCB = LSAME( ABSCHU, 'B' ) + LABSCS = LSAME( ABSCHU, 'S' ) + LULA = LSAME( ULA, 'U' ) + LULB = LSAME( ULB, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LABSCB .AND. .NOT.LABSCS .AND. + $ .NOT.LSAME( ABSCHU, 'A' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LULA .AND. .NOT.LSAME( ULA, 'L' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LULB .AND. .NOT.LSAME( ULB, 'L' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.0 .OR. ( .NOT.( LABSCS .AND. LULA .AND. LULB ) + $ .AND. LDWORK.LT.2*MAXMN*( 4 + 2*MAXMN ) ) ) THEN + INFO = -15 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB04ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAXMN.EQ.0 ) + $ RETURN +C + IF ( LABSCS .AND. LULA .AND. LULB ) THEN +C +C If both matrices are in a real Schur form, use DTRSYL. +C + CALL DTRSYL( 'NoTranspose', 'NoTranspose', 1, N, M, A, LDA, B, + $ LDB, C, LDC, SCALE, INFO ) + IF ( SCALE.NE.ONE ) + $ INFO = 1 + RETURN + END IF +C + LDW = 2*MAXMN + JWORK = LDW*LDW + 3*LDW + 1 + TOL1 = TOL + IF ( TOL1.LE.ZERO ) + $ TOL1 = DLAMCH( 'Epsilon' ) +C +C Choose the smallest of both matrices as the one in Hessenberg +C form when possible. +C + ABSCHR = ABSCHU + IF ( LABSCS ) THEN + IF ( N.GT.M ) THEN + ABSCHR = 'A' + ELSE + ABSCHR = 'B' + END IF + END IF + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C B is in Schur form: recursion on the columns of B. +C + IF ( LULB ) THEN +C +C B is upper: forward recursion. +C + IBEG = 1 + IEND = M + FWD = 1 + INCR = 0 + ELSE +C +C B is lower: backward recursion. +C + IBEG = M + IEND = 1 + FWD = -1 + INCR = -1 + END IF + I = IBEG +C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO + 20 IF ( ( IEND - I )*FWD.GE.0 ) THEN +C +C Test for 1-by-1 or 2-by-2 diagonal block in the Schur +C form. +C + IF ( I.EQ.IEND ) THEN + ISTEP = 1 + ELSE + IF ( B(I+FWD,I).EQ.ZERO ) THEN + ISTEP = 1 + ELSE + ISTEP = 2 + END IF + END IF +C + IF ( ISTEP.EQ.1 ) THEN + CALL SB04NW( ABSCHR, ULB, N, M, C, LDC, I, B, LDB, + $ DWORK(JWORK) ) + CALL SB04NY( 'R', ULA, N, A, LDA, B(I,I), DWORK(JWORK), + $ TOL1, IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( N, DWORK(JWORK), 1, C(1,I), 1 ) + ELSE + IPINCR = I + INCR + CALL SB04NV( ABSCHR, ULB, N, M, C, LDC, IPINCR, B, LDB, + $ DWORK(JWORK) ) + CALL SB04NX( 'R', ULA, N, A, LDA, B(IPINCR,IPINCR), + $ B(IPINCR+1,IPINCR), B(IPINCR,IPINCR+1), + $ B(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, + $ IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( N, DWORK(JWORK), 2, C(1,IPINCR), 1 ) + CALL DCOPY( N, DWORK(JWORK+1), 2, C(1,IPINCR+1), 1 ) + END IF + I = I + FWD*ISTEP + GO TO 20 + END IF +C END WHILE 20 + ELSE +C +C A is in Schur form: recursion on the rows of A. +C + IF ( LULA ) THEN +C +C A is upper: backward recursion. +C + IBEG = N + IEND = 1 + FWD = -1 + INCR = -1 + ELSE +C +C A is lower: forward recursion. +C + IBEG = 1 + IEND = N + FWD = 1 + INCR = 0 + END IF + I = IBEG +C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO + 40 IF ( ( IEND - I )*FWD.GE.0 ) THEN +C +C Test for 1-by-1 or 2-by-2 diagonal block in the Schur +C form. +C + IF ( I.EQ.IEND ) THEN + ISTEP = 1 + ELSE + IF ( A(I,I+FWD).EQ.ZERO ) THEN + ISTEP = 1 + ELSE + ISTEP = 2 + END IF + END IF +C + IF ( ISTEP.EQ.1 ) THEN + CALL SB04NW( ABSCHR, ULA, N, M, C, LDC, I, A, LDA, + $ DWORK(JWORK) ) + CALL SB04NY( 'C', ULB, M, B, LDB, A(I,I), DWORK(JWORK), + $ TOL1, IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + ELSE + IPINCR = I + INCR + CALL SB04NV( ABSCHR, ULA, N, M, C, LDC, IPINCR, A, LDA, + $ DWORK(JWORK) ) + CALL SB04NX( 'C', ULB, M, B, LDB, A(IPINCR,IPINCR), + $ A(IPINCR+1,IPINCR), A(IPINCR,IPINCR+1), + $ A(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, + $ IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( M, DWORK(JWORK), 2, C(IPINCR,1), LDC ) + CALL DCOPY( M, DWORK(JWORK+1), 2, C(IPINCR+1,1), LDC ) + END IF + I = I + FWD*ISTEP + GO TO 40 + END IF +C END WHILE 40 + END IF +C + RETURN +C *** Last line of SB04ND *** + END diff --git a/mex/sources/libslicot/SB04NV.f b/mex/sources/libslicot/SB04NV.f new file mode 100644 index 000000000..bb09f2778 --- /dev/null +++ b/mex/sources/libslicot/SB04NV.f @@ -0,0 +1,165 @@ + SUBROUTINE SB04NV( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, D ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the right-hand sides D for a system of equations in +C Hessenberg form solved via SB04NX (case with 2 right-hand sides). +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHR CHARACTER*1 +C Indicates whether AB contains A or B, as follows: +C = 'A': AB contains A; +C = 'B': AB contains B. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,M) +C The leading N-by-M part of this array must contain both +C the not yet modified part of the coefficient matrix C of +C the Sylvester equation AX + XB = C, and both the currently +C computed part of the solution of the Sylvester equation. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C INDX (input) INTEGER +C The position of the first column/row of C to be used in +C the construction of the right-hand side D. +C +C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C AX + XB = C. +C +C LDAB INTEGER +C The leading dimension of array AB. +C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on +C ABSCHR = 'A' or ABSCHR = 'B', respectively). +C +C D (output) DOUBLE PRECISION array, dimension (*) +C The leading 2*N or 2*M part of this array (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the +C right-hand side stored as a matrix with two rows. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04BV by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHR, UL + INTEGER INDX, LDAB, LDC, M, N +C .. Array Arguments .. + DOUBLE PRECISION AB(LDAB,*), C(LDC,*), D(*) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV +C .. Executable Statements .. +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C Construct the 2 columns of the right-hand side. +C + CALL DCOPY( N, C(1,INDX), 1, D(1), 2 ) + CALL DCOPY( N, C(1,INDX+1), 1, D(2), 2 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX), 1, + $ ONE, D(1), 2 ) + CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX+1), + $ 1, ONE, D(2), 2 ) + END IF + ELSE + IF ( INDX.LT.M-1 ) THEN + CALL DGEMV( 'N', N, M-INDX-1, -ONE, C(1,INDX+2), LDC, + $ AB(INDX+2,INDX), 1, ONE, D(1), 2 ) + CALL DGEMV( 'N', N, M-INDX-1, -ONE, C(1,INDX+2), LDC, + $ AB(INDX+2,INDX+1), 1, ONE, D(2), 2 ) + END IF + END IF + ELSE +C +C Construct the 2 rows of the right-hand side. +C + CALL DCOPY( M, C(INDX,1), LDC, D(1), 2 ) + CALL DCOPY( M, C(INDX+1,1), LDC, D(2), 2 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.LT.N-1 ) THEN + CALL DGEMV( 'T', N-INDX-1, M, -ONE, C(INDX+2,1), LDC, + $ AB(INDX,INDX+2), LDAB, ONE, D(1), 2 ) + CALL DGEMV( 'T', N-INDX-1, M, -ONE, C(INDX+2,1), LDC, + $ AB(INDX+1,INDX+2), LDAB, ONE, D(2), 2 ) + END IF + ELSE + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX,1), + $ LDAB, ONE, D(1), 2 ) + CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX+1,1), + $ LDAB, ONE, D(2), 2 ) + END IF + END IF + END IF +C + RETURN +C *** Last line of SB04NV *** + END diff --git a/mex/sources/libslicot/SB04NW.f b/mex/sources/libslicot/SB04NW.f new file mode 100644 index 000000000..a2a52aa82 --- /dev/null +++ b/mex/sources/libslicot/SB04NW.f @@ -0,0 +1,155 @@ + SUBROUTINE SB04NW( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, D ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the right-hand side D for a system of equations in +C Hessenberg form solved via SB04NY (case with 1 right-hand side). +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHR CHARACTER*1 +C Indicates whether AB contains A or B, as follows: +C = 'A': AB contains A; +C = 'B': AB contains B. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,M) +C The leading N-by-M part of this array must contain both +C the not yet modified part of the coefficient matrix C of +C the Sylvester equation AX + XB = C, and both the currently +C computed part of the solution of the Sylvester equation. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C INDX (input) INTEGER +C The position of the column/row of C to be used in the +C construction of the right-hand side D. +C +C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C AX + XB = C. +C +C LDAB INTEGER +C The leading dimension of array AB. +C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on +C ABSCHR = 'A' or ABSCHR = 'B', respectively). +C +C D (output) DOUBLE PRECISION array, dimension (*) +C The leading N or M part of this array (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the +C right-hand side. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04BW by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHR, UL + INTEGER INDX, LDAB, LDC, M, N +C .. Array Arguments .. + DOUBLE PRECISION AB(LDAB,*), C(LDC,*), D(*) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV +C .. Executable Statements .. +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C Construct the column of the right-hand side. +C + CALL DCOPY( N, C(1,INDX), 1, D, 1 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX), 1, + $ ONE, D, 1 ) + END IF + ELSE + IF ( INDX.LT.M ) THEN + CALL DGEMV( 'N', N, M-INDX, -ONE, C(1,INDX+1), LDC, + $ AB(INDX+1,INDX), 1, ONE, D, 1 ) + END IF + END IF + ELSE +C +C Construct the row of the right-hand side. +C + CALL DCOPY( M, C(INDX,1), LDC, D, 1 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.LT.N ) THEN + CALL DGEMV( 'T', N-INDX, M, -ONE, C(INDX+1,1), LDC, + $ AB(INDX,INDX+1), LDAB, ONE, D, 1 ) + END IF + ELSE + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX,1), + $ LDAB, ONE, D, 1 ) + END IF + END IF + END IF +C + RETURN +C *** Last line of SB04NW *** + END diff --git a/mex/sources/libslicot/SB04NX.f b/mex/sources/libslicot/SB04NX.f new file mode 100644 index 000000000..ac9ecf524 --- /dev/null +++ b/mex/sources/libslicot/SB04NX.f @@ -0,0 +1,320 @@ + SUBROUTINE SB04NX( RC, UL, M, A, LDA, LAMBD1, LAMBD2, LAMBD3, + $ LAMBD4, D, TOL, IWORK, DWORK, LDDWOR, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a system of equations in Hessenberg form with two +C consecutive offdiagonals and two right-hand sides. +C +C ARGUMENTS +C +C Mode Parameters +C +C RC CHARACTER*1 +C Indicates processing by columns or rows, as follows: +C = 'R': Row transformations are applied; +C = 'C': Column transformations are applied. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain a +C matrix A in Hessenberg form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C LAMBD1, (input) DOUBLE PRECISION +C LAMBD2, These variables must contain the 2-by-2 block to be added +C LAMBD3, to the diagonal blocks of A. +C LAMBD4 +C +C D (input/output) DOUBLE PRECISION array, dimension (2*M) +C On entry, this array must contain the two right-hand +C side vectors of the Hessenberg system, stored row-wise. +C On exit, if INFO = 0, this array contains the two solution +C vectors of the Hessenberg system, stored row-wise. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the triangular factor R of the Hessenberg matrix. A matrix +C whose estimated condition number is less than 1/TOL is +C considered to be nonsingular. +C +C Workspace +C +C IWORK INTEGER array, dimension (2*M) +C +C DWORK DOUBLE PRECISION array, dimension (LDDWOR,2*M+3) +C The leading 2*M-by-2*M part of this array is used for +C computing the triangular factor of the QR decomposition +C of the Hessenberg matrix. The remaining 6*M elements are +C used as workspace for the computation of the reciprocal +C condition estimate. +C +C LDDWOR INTEGER +C The leading dimension of array DWORK. +C LDDWOR >= MAX(1,2*M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if the Hessenberg matrix is (numerically) singular. +C That is, its estimated reciprocal condition number +C is less than or equal to TOL. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04BX by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C Note that RC, UL, M and LDA must be such that the value of the +C LOGICAL variable OK in the following statement is true. +C +C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. +C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) +C .AND. +C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. +C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) +C .AND. +C ( M.GE.0 ) +C .AND. +C ( LDA.GE.MAX( 1, M ) ) +C .AND. +C ( LDDWOR.GE.MAX( 1, 2*M ) ) +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER RC, UL + INTEGER INFO, LDA, LDDWOR, M + DOUBLE PRECISION LAMBD1, LAMBD2, LAMBD3, LAMBD4, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) +C .. Local Scalars .. + CHARACTER TRANS + INTEGER J, J1, J2, M2, MJ, ML + DOUBLE PRECISION C, R, RCOND, S +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARTG, DLASET, DROT, DTRCON, DTRSV +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + M2 = M*2 + IF ( LSAME( UL, 'U' ) ) THEN +C + DO 20 J = 1, M + J2 = J*2 + ML = MIN( M, J + 1 ) + CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), + $ LDDWOR ) + CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2-1), 2 ) + CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2), 2 ) + DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + LAMBD1 + DWORK(J2,J2-1) = LAMBD3 + DWORK(J2-1,J2) = LAMBD2 + DWORK(J2,J2) = DWORK(J2,J2) + LAMBD4 + 20 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is an upper Hessenberg matrix, row transformations. +C + DO 40 J = 1, M2 - 1 + MJ = M2 - J + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(J+2,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J+1,J), DWORK(J+2,J), C, S, R ) + DWORK(J+1,J) = R + DWORK(J+2,J) = ZERO + CALL DROT( MJ, DWORK(J+1,J+1), LDDWOR, + $ DWORK(J+2,J+1), LDDWOR, C, S ) + CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) + END IF + END IF + IF ( DWORK(J+1,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) + DWORK(J,J) = R + DWORK(J+1,J) = ZERO + CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 40 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is an upper Hessenberg matrix, column transformations. +C + DO 60 J = 1, M2 - 1 + MJ = M2 - J + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(MJ+1,MJ-1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ), DWORK(MJ+1,MJ-1), C, + $ S, R ) + DWORK(MJ+1,MJ) = R + DWORK(MJ+1,MJ-1) = ZERO + CALL DROT( MJ, DWORK(1,MJ), 1, DWORK(1,MJ-1), 1, C, + $ S ) + CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) + END IF + END IF + IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ+1,MJ) = ZERO + CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, + $ S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 60 CONTINUE +C + END IF + ELSE +C + DO 80 J = 1, M + J2 = J*2 + J1 = MAX( J - 1, 1 ) + ML = MIN( M - J + 2, M ) + CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), + $ LDDWOR ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2-1), 2 ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2), 2 ) + DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + LAMBD1 + DWORK(J2,J2-1) = LAMBD3 + DWORK(J2-1,J2) = LAMBD2 + DWORK(J2,J2) = DWORK(J2,J2) + LAMBD4 + 80 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is a lower Hessenberg matrix, row transformations. +C + DO 100 J = 1, M2 - 1 + MJ = M2 - J + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(MJ-1,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ,MJ+1), DWORK(MJ-1,MJ+1), C, + $ S, R ) + DWORK(MJ,MJ+1) = R + DWORK(MJ-1,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ,1), LDDWOR, DWORK(MJ-1,1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) + END IF + END IF + IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), + $ LDDWOR, C, S) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 100 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is a lower Hessenberg matrix, column transformations. +C + DO 120 J = 1, M2 - 1 + MJ = M2 - J + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(J,J+2).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J+1), DWORK(J,J+2), C, S, R ) + DWORK(J,J+1) = R + DWORK(J,J+2) = ZERO + CALL DROT( MJ, DWORK(J+1,J+1), 1, DWORK(J+1,J+2), + $ 1, C, S ) + CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) + END IF + END IF + IF ( DWORK(J,J+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) + DWORK(J,J) = R + DWORK(J,J+1) = ZERO + CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, + $ S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 120 CONTINUE +C + END IF + END IF +C + CALL DTRCON( '1-norm', UL, 'Non-unit', M2, DWORK, LDDWOR, RCOND, + $ DWORK(1,M2+1), IWORK, INFO ) + IF ( RCOND.LE.TOL ) THEN + INFO = 1 + ELSE + CALL DTRSV( UL, TRANS, 'Non-unit', M2, DWORK, LDDWOR, D, 1 ) + END IF +C + RETURN +C *** Last line of SB04NX *** + END diff --git a/mex/sources/libslicot/SB04NY.f b/mex/sources/libslicot/SB04NY.f new file mode 100644 index 000000000..5a0b9c62b --- /dev/null +++ b/mex/sources/libslicot/SB04NY.f @@ -0,0 +1,260 @@ + SUBROUTINE SB04NY( RC, UL, M, A, LDA, LAMBDA, D, TOL, IWORK, + $ DWORK, LDDWOR, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a system of equations in Hessenberg form with one +C offdiagonal and one right-hand side. +C +C ARGUMENTS +C +C Mode Parameters +C +C RC CHARACTER*1 +C Indicates processing by columns or rows, as follows: +C = 'R': Row transformations are applied; +C = 'C': Column transformations are applied. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain a +C matrix A in Hessenberg form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C LAMBDA (input) DOUBLE PRECISION +C This variable must contain the value to be added to the +C diagonal elements of A. +C +C D (input/output) DOUBLE PRECISION array, dimension (M) +C On entry, this array must contain the right-hand side +C vector of the Hessenberg system. +C On exit, if INFO = 0, this array contains the solution +C vector of the Hessenberg system. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the triangular factor R of the Hessenberg matrix. A matrix +C whose estimated condition number is less than 1/TOL is +C considered to be nonsingular. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (LDDWOR,M+3) +C The leading M-by-M part of this array is used for +C computing the triangular factor of the QR decomposition +C of the Hessenberg matrix. The remaining 3*M elements are +C used as workspace for the computation of the reciprocal +C condition estimate. +C +C LDDWOR INTEGER +C The leading dimension of array DWORK. LDDWOR >= MAX(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if the Hessenberg matrix is (numerically) singular. +C That is, its estimated reciprocal condition number +C is less than or equal to TOL. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04BY by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C Note that RC, UL, M and LDA must be such that the value of the +C LOGICAL variable OK in the following statement is true. +C +C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. +C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) +C .AND. +C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. +C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) +C .AND. +C ( M.GE.0 ) +C .AND. +C ( LDA.GE.MAX( 1, M ) ) +C .AND. +C ( LDDWOR.GE.MAX( 1, M ) ) +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER RC, UL + INTEGER INFO, LDA, LDDWOR, M + DOUBLE PRECISION LAMBDA, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) +C .. Local Scalars .. + CHARACTER TRANS + INTEGER J, J1, MJ + DOUBLE PRECISION C, R, RCOND, S +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARTG, DROT, DTRCON, DTRSV +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + IF ( LSAME( UL, 'U' ) ) THEN +C + DO 20 J = 1, M + CALL DCOPY( MIN( J+1, M ), A(1,J), 1, DWORK(1,J), 1 ) + DWORK(J,J) = DWORK(J,J) + LAMBDA + 20 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is an upper Hessenberg matrix, row transformations. +C + DO 40 J = 1, M - 1 + MJ = M - J + IF ( DWORK(J+1,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) + DWORK(J,J) = R + DWORK(J+1,J) = ZERO + CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 40 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is an upper Hessenberg matrix, column transformations. +C + DO 60 J = 1, M - 1 + MJ = M - J + IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ+1,MJ) = ZERO + CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, + $ S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 60 CONTINUE +C + END IF + ELSE +C + DO 80 J = 1, M + J1 = MAX( J - 1, 1 ) + CALL DCOPY( M-J1+1, A(J1,J), 1, DWORK(J1,J), 1 ) + DWORK(J,J) = DWORK(J,J) + LAMBDA + 80 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is a lower Hessenberg matrix, row transformations. +C + DO 100 J = 1, M - 1 + MJ = M - J + IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 100 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is a lower Hessenberg matrix, column transformations. +C + DO 120 J = 1, M - 1 + MJ = M - J + IF ( DWORK(J,J+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) + DWORK(J,J) = R + DWORK(J,J+1) = ZERO + CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, + $ S ) +C + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 120 CONTINUE +C + END IF + END IF +C + CALL DTRCON( '1-norm', UL, 'Non-unit', M, DWORK, LDDWOR, RCOND, + $ DWORK(1,M+1), IWORK, INFO ) + IF ( RCOND.LE.TOL ) THEN + INFO = 1 + ELSE + CALL DTRSV( UL, TRANS, 'Non-unit', M, DWORK, LDDWOR, D, 1 ) + END IF +C + RETURN +C *** Last line of SB04NY *** + END diff --git a/mex/sources/libslicot/SB04OD.f b/mex/sources/libslicot/SB04OD.f new file mode 100644 index 000000000..6a11ffa76 --- /dev/null +++ b/mex/sources/libslicot/SB04OD.f @@ -0,0 +1,1028 @@ + SUBROUTINE SB04OD( REDUCE, TRANS, JOBD, M, N, A, LDA, B, LDB, C, + $ LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, P, + $ LDP, Q, LDQ, U, LDU, V, LDV, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for R and L one of the generalized Sylvester equations +C +C A * R - L * B = scale * C ) +C ) (1) +C D * R - L * E = scale * F ) +C +C or +C +C A' * R + D' * L = scale * C ) +C ) (2) +C R * B' + L * E' = scale * (-F) ) +C +C where A and D are M-by-M matrices, B and E are N-by-N matrices and +C C, F, R and L are M-by-N matrices. +C +C The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an +C output scaling factor chosen to avoid overflow. +C +C The routine also optionally computes a Dif estimate, which +C measures the separation of the spectrum of the matrix pair (A,D) +C from the spectrum of the matrix pair (B,E), Dif[(A,D),(B,E)]. +C +C ARGUMENTS +C +C MODE PARAMETERS +C +C REDUCE CHARACTER*1 +C Indicates whether the matrix pairs (A,D) and/or (B,E) are +C to be reduced to generalized Schur form as follows: +C = 'R': The matrix pairs (A,D) and (B,E) are to be reduced +C to generalized (real) Schur canonical form; +C = 'A': The matrix pair (A,D) only is to be reduced +C to generalized (real) Schur canonical form, +C and the matrix pair (B,E) already is in this form; +C = 'B': The matrix pair (B,E) only is to be reduced +C to generalized (real) Schur canonical form, +C and the matrix pair (A,D) already is in this form; +C = 'N': The matrix pairs (A,D) and (B,E) are already in +C generalized (real) Schur canonical form, as +C produced by LAPACK routine DGEES. +C +C TRANS CHARACTER*1 +C Indicates which of the equations, (1) or (2), is to be +C solved as follows: +C = 'N': The generalized Sylvester equation (1) is to be +C solved; +C = 'T': The "transposed" generalized Sylvester equation +C (2) is to be solved. +C +C JOBD CHARACTER*1 +C Indicates whether the Dif estimator is to be computed as +C follows: +C = '1': Only the one-norm-based Dif estimate is computed +C and stored in DIF; +C = '2': Only the Frobenius norm-based Dif estimate is +C computed and stored in DIF; +C = 'D': The equation (1) is solved and the one-norm-based +C Dif estimate is computed and stored in DIF; +C = 'F': The equation (1) is solved and the Frobenius norm- +C based Dif estimate is computed and stored in DIF; +C = 'N': The Dif estimator is not required and hence DIF is +C not referenced. (Solve either (1) or (2) only.) +C JOBD is not referenced if TRANS = 'T'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrices A and D and the number of rows +C of the matrices C, F, R and L. M >= 0. +C +C N (input) INTEGER +C The order of the matrices B and E and the number of +C columns of the matrices C, F, R and L. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) +C On entry, the leading M-by-M part of this array must +C contain the coefficient matrix A of the equation; A must +C be in upper quasi-triangular form if REDUCE = 'B' or 'N'. +C On exit, the leading M-by-M part of this array contains +C the upper quasi-triangular form of A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain the coefficient matrix B of the equation; B must +C be in upper quasi-triangular form if REDUCE = 'A' or 'N'. +C On exit, the leading N-by-N part of this array contains +C the upper quasi-triangular form of B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the right-hand side matrix C of the first equation +C in (1) or (2). +C On exit, if JOBD = 'N', 'D' or 'F', the leading M-by-N +C part of this array contains the solution matrix R of the +C problem; if JOBD = '1' or '2' and TRANS = 'N', the leading +C M-by-N part of this array contains the solution matrix R +C achieved during the computation of the Dif estimate. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading M-by-M part of this array must +C contain the coefficient matrix D of the equation; D must +C be in upper triangular form if REDUCE = 'B' or 'N'. +C On exit, the leading M-by-M part of this array contains +C the upper triangular form of D. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,M). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the coefficient matrix E of the equation; E must +C be in upper triangular form if REDUCE = 'A' or 'N'. +C On exit, the leading N-by-N part of this array contains +C the upper triangular form of E. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) +C On entry, the leading M-by-N part of this array must +C contain the right-hand side matrix F of the second +C equation in (1) or (2). +C On exit, if JOBD = 'N', 'D' or 'F', the leading M-by-N +C part of this array contains the solution matrix L of the +C problem; if JOBD = '1' or '2' and TRANS = 'N', the leading +C M-by-N part of this array contains the solution matrix L +C achieved during the computation of the Dif estimate. +C +C LDF INTEGER +C The leading dimension of array F. LDF >= MAX(1,M). +C +C SCALE (output) DOUBLE PRECISION +C The scaling factor in (1) or (2). If 0 < SCALE < 1, C and +C F hold the solutions R and L, respectively, to a slightly +C perturbed system (but the input or computed generalized +C (real) Schur canonical form matrices A, B, D, and E +C have not been changed). If SCALE = 0, C and F hold the +C solutions R and L, respectively, to the homogeneous system +C with C = F = 0. Normally, SCALE = 1. +C +C DIF (output) DOUBLE PRECISION +C If TRANS = 'N' and JOBD <> 'N', then DIF contains the +C value of the Dif estimator, which is an upper bound of +C -1 +C Dif[(A,D),(B,E)] = sigma_min(Z) = 1/||Z ||, in either the +C one-norm, or Frobenius norm, respectively (see METHOD). +C Otherwise, DIF is not referenced. +C +C P (output) DOUBLE PRECISION array, dimension (LDP,*) +C If REDUCE = 'R' or 'A', then the leading M-by-M part of +C this array contains the (left) transformation matrix used +C to reduce (A,D) to generalized Schur form. +C Otherwise, P is not referenced and can be supplied as a +C dummy array (i.e. set parameter LDP = 1 and declare this +C array to be P(1,1) in the calling program). +C +C LDP INTEGER +C The leading dimension of array P. +C LDP >= MAX(1,M) if REDUCE = 'R' or 'A', +C LDP >= 1 if REDUCE = 'B' or 'N'. +C +C Q (output) DOUBLE PRECISION array, dimension (LDQ,*) +C If REDUCE = 'R' or 'A', then the leading M-by-M part of +C this array contains the (right) transformation matrix used +C to reduce (A,D) to generalized Schur form. +C Otherwise, Q is not referenced and can be supplied as a +C dummy array (i.e. set parameter LDQ = 1 and declare this +C array to be Q(1,1) in the calling program). +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= MAX(1,M) if REDUCE = 'R' or 'A', +C LDQ >= 1 if REDUCE = 'B' or 'N'. +C +C U (output) DOUBLE PRECISION array, dimension (LDU,*) +C If REDUCE = 'R' or 'B', then the leading N-by-N part of +C this array contains the (left) transformation matrix used +C to reduce (B,E) to generalized Schur form. +C Otherwise, U is not referenced and can be supplied as a +C dummy array (i.e. set parameter LDU = 1 and declare this +C array to be U(1,1) in the calling program). +C +C LDU INTEGER +C The leading dimension of array U. +C LDU >= MAX(1,N) if REDUCE = 'R' or 'B', +C LDU >= 1 if REDUCE = 'A' or 'N'. +C +C V (output) DOUBLE PRECISION array, dimension (LDV,*) +C If REDUCE = 'R' or 'B', then the leading N-by-N part of +C this array contains the (right) transformation matrix used +C to reduce (B,E) to generalized Schur form. +C Otherwise, V is not referenced and can be supplied as a +C dummy array (i.e. set parameter LDV = 1 and declare this +C array to be V(1,1) in the calling program). +C +C LDV INTEGER +C The leading dimension of array V. +C LDV >= MAX(1,N) if REDUCE = 'R' or 'B', +C LDV >= 1 if REDUCE = 'A' or 'N'. +C +C Workspace +C +C IWORK INTEGER array, dimension (M+N+6) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C If TRANS = 'N' and JOBD = 'D' or 'F', then +C LDWORK = MAX(1,7*M,7*N,2*M*N) if REDUCE = 'R'; +C LDWORK = MAX(1,7*M,2*M*N) if REDUCE = 'A'; +C LDWORK = MAX(1,7*N,2*M*N) if REDUCE = 'B'; +C LDWORK = MAX(1,2*M*N) if REDUCE = 'N'. +C Otherwise, the term 2*M*N above should be omitted. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if REDUCE <> 'N' and either (A,D) and/or (B,E) +C cannot be reduced to generalized Schur form; +C = 2: if REDUCE = 'N' and either A or B is not in +C upper quasi-triangular form; +C = 3: if a singular matrix was encountered during the +C computation of the solution matrices R and L, that +C is (A,D) and (B,E) have common or close eigenvalues. +C +C METHOD +C +C For the case TRANS = 'N', and REDUCE = 'R' or 'N', the algorithm +C used by the routine consists of four steps (see [1] and [2]) as +C follows: +C +C (a) if REDUCE = 'R', then the matrix pairs (A,D) and (B,E) are +C transformed to generalized Schur form, i.e. orthogonal +C matrices P, Q, U and V are computed such that P' * A * Q +C and U' * B * V are in upper quasi-triangular form and +C P' * D * Q and U' * E * V are in upper triangular form; +C (b) if REDUCE = 'R', then the matrices C and F are transformed +C to give P' * C * V and P' * F * V respectively; +C (c) if REDUCE = 'R', then the transformed system +C +C P' * A * Q * R1 - L1 * U' * B * V = scale * P' * C * V +C P' * D * Q * R1 - L1 * U' * E * V = scale * P' * F * V +C +C is solved to give R1 and L1; otherwise, equation (1) is +C solved to give R and L directly. The Dif estimator +C is also computed if JOBD <> 'N'. +C (d) if REDUCE = 'R', then the solution is transformed back +C to give R = Q * R1 * V' and L = P * L1 * U'. +C +C By using Kronecker products, equation (1) can also be written as +C the system of linear equations Z * x = scale*y (see [1]), where +C +C | I*A I*D | +C Z = | |. +C |-B'*I -E'*I | +C +C -1 +C If JOBD <> 'N', then a lower bound on ||Z ||, in either the one- +C norm or Frobenius norm, is computed, which in most cases is +C a reliable estimate of the true value. Notice that since Z is a +C matrix of order 2 * M * N, the exact value of Dif (i.e., in the +C Frobenius norm case, the smallest singular value of Z) may be very +C expensive to compute. +C +C The case TRANS = 'N', and REDUCE = 'A' or 'B', is similar, but +C only one of the matrix pairs should be reduced and the +C calculations simplify. +C +C For the case TRANS = 'T', and REDUCE = 'R' or 'N', the algorithm +C is similar, but the steps (b), (c), and (d) are as follows: +C +C (b) if REDUCE = 'R', then the matrices C and F are transformed +C to give Q' * C * V and P' * F * U respectively; +C (c) if REDUCE = 'R', then the transformed system +C +C Q' * A' * P * R1 + Q' * D' * P * L1 = scale * Q' * C * V +C R1 * V' * B' * U + L1 * V' * E' * U = -scale * P' * F * U +C +C is solved to give R1 and L1; otherwise, equation (2) is +C solved to give R and L directly. +C (d) if REDUCE = 'R', then the solution is transformed back +C to give R = P * R1 * V' and L = P * L1 * V'. +C +C REFERENCES +C +C [1] Kagstrom, B. and Westin, L. +C Generalized Schur Methods with Condition Estimators for +C Solving the Generalized Sylvester Equation. +C IEEE Trans. Auto. Contr., 34, pp. 745-751, 1989. +C [2] Kagstrom, B. and Westin, L. +C GSYLV - Fortran Routines for the Generalized Schur Method with +C Dif Estimators for Solving the Generalized Sylvester +C Equation. +C Report UMINF-132.86, Institute of Information Processing, +C Univ. of Umea, Sweden, July 1987. +C [3] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur Method for the Problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C [4] Kagstrom, B. and Van Dooren, P. +C Additive Decomposition of a Transfer Function with respect to +C a Specified Region. +C In: "Signal Processing, Scattering and Operator Theory, and +C Numerical Methods" (Eds. M.A. Kaashoek et al.). +C Proceedings of MTNS-89, Vol. 3, pp. 469-477, Birkhauser Boston +C Inc., 1990. +C [5] Kagstrom, B. and Van Dooren, P. +C A Generalized State-space Approach for the Additive +C Decomposition of a Transfer Matrix. +C Report UMINF-91.12, Institute of Information Processing, Univ. +C of Umea, Sweden, April 1991. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. A reliable estimate for the +C condition number of Z in the Frobenius norm, is (see [1]) +C +C K(Z) = SQRT( ||A||**2 + ||B||**2 + ||C||**2 + ||D||**2 )/DIF. +C +C If mu is an upper bound on the relative error of the elements of +C the matrices A, B, C, D, E and F, then the relative error in the +C actual solution is approximately mu * K(Z). +C +C The relative error in the computed solution (due to rounding +C errors) is approximately EPS * K(Z), where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C +C FURTHER COMMENTS +C +C For applications of the generalized Sylvester equation in control +C theory, see [4] and [5]. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04CD by Bo Kagstrom and Lars +C Westin. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, Dec. 1999, +C May 2009. +C +C KEYWORDS +C +C Generalized eigenvalue problem, orthogonal transformation, real +C Schur form, Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBD, REDUCE, TRANS + INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDF, LDP, LDQ, + $ LDU, LDV, LDWORK, M, N + DOUBLE PRECISION DIF, SCALE +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), E(LDE,*), F(LDF,*), P(LDP,*), + $ Q(LDQ,*), U(LDU,*), V(LDV,*) +C .. Local Scalars .. + LOGICAL ILASCL, ILBSCL, ILDSCL, ILESCL, LJOB1, LJOB2, + $ LJOBD, LJOBDF, LJOBF, LREDRA, LREDRB, LREDUA, + $ LREDUB, LREDUC, LREDUR, LTRANN, SUFWRK + INTEGER I, IERR, IJOB, MINWRK, MN, WRKOPT + DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, DNRM, + $ DNRMTO, ENRM, ENRMTO, SAFMAX, SAFMIN, SMLNUM +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEGS, DGEMM, DGEMV, DLABAD, DLACPY, + $ DLASCL, DTGSYL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, SQRT +C .. Executable Statements .. +C + INFO = 0 + MN = MAX( M, N ) + LREDUR = LSAME( REDUCE, 'R' ) + LREDUA = LSAME( REDUCE, 'A' ) + LREDUB = LSAME( REDUCE, 'B' ) + LREDRA = LREDUR.OR.LREDUA + LREDRB = LREDUR.OR.LREDUB + LREDUC = LREDRA.OR.LREDUB + IF ( LREDUR ) THEN + MINWRK = MAX( 1, 7*MN ) + ELSE IF ( LREDUA ) THEN + MINWRK = MAX( 1, 7*M ) + ELSE IF ( LREDUB ) THEN + MINWRK = MAX( 1, 7*N ) + ELSE + MINWRK = 1 + END IF + LTRANN = LSAME( TRANS, 'N' ) + IF ( LTRANN ) THEN + LJOB1 = LSAME( JOBD, '1' ) + LJOB2 = LSAME( JOBD, '2' ) + LJOBD = LSAME( JOBD, 'D' ) + LJOBF = LSAME( JOBD, 'F' ) + LJOBDF = LJOB1.OR.LJOB2.OR.LJOBD.OR.LJOBF + IF ( LJOBD.OR.LJOBF ) MINWRK = MAX( MINWRK, 2*M*N ) + END IF +C +C Test the input scalar arguments. +C + IF( .NOT.LREDUC .AND. .NOT.LSAME( REDUCE, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LTRANN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( LTRANN ) THEN + IF( .NOT.LJOBDF .AND. .NOT.LSAME( JOBD, 'N' ) ) + $ INFO = -3 + END IF + IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -17 + ELSE IF( ( .NOT.LREDRA .AND. LDP.LT.1 ) .OR. + $ ( LREDRA .AND. LDP.LT.MAX( 1, M ) ) ) THEN + INFO = -21 + ELSE IF( ( .NOT.LREDRA .AND. LDQ.LT.1 ) .OR. + $ ( LREDRA .AND. LDQ.LT.MAX( 1, M ) ) ) THEN + INFO = -23 + ELSE IF( ( .NOT.LREDRB .AND. LDU.LT.1 ) .OR. + $ ( LREDRB .AND. LDU.LT.MAX( 1, N ) ) ) THEN + INFO = -25 + ELSE IF( ( .NOT.LREDRB .AND. LDV.LT.1 ) .OR. + $ ( LREDRB .AND. LDV.LT.MAX( 1, N ) ) ) THEN + INFO = -27 + ELSE IF( LDWORK.LT.MINWRK ) THEN + INFO = -30 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB04OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) THEN + SCALE = ONE + DWORK(1) = ONE + IF ( LTRANN ) THEN + IF ( LJOBDF ) DIF = ONE + END IF + RETURN + END IF + WRKOPT = 1 + SUFWRK = LDWORK.GE.M*N +C +C STEP 1: Reduce (A,D) and/or (B,E) to generalized Schur form. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF ( LREDUC ) THEN +C +C Get machine constants. +C + SAFMIN = DLAMCH( 'Safe minimum' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + SMLNUM = SQRT( SAFMIN ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM +C + IF ( .NOT.LREDUB ) THEN +C +C Scale A if max element outside range [SMLNUM,BIGNUM]. +C + ANRM = DLANGE( 'M', M, M, A, LDA, DWORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF + IF( ILASCL ) + $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, M, M, A, LDA, + $ IERR ) +C +C Scale D if max element outside range [SMLNUM,BIGNUM] +C + DNRM = DLANGE( 'M', M, M, D, LDD, DWORK ) + ILDSCL = .FALSE. + IF( DNRM.GT.ZERO .AND. DNRM.LT.SMLNUM ) THEN + DNRMTO = SMLNUM + ILDSCL = .TRUE. + ELSE IF( DNRM.GT.BIGNUM ) THEN + DNRMTO = BIGNUM + ILDSCL = .TRUE. + END IF + IF( ILDSCL ) + $ CALL DLASCL( 'G', 0, 0, DNRM, DNRMTO, M, M, D, LDD, + $ IERR ) +C +C Reduce (A,D) to generalized Schur form. +C Workspace: need 7*M; +C prefer 5*M + M*(NB+1). +C + CALL DGEGS( 'Vectors left', 'Vectors right', M, A, LDA, D, + $ LDD, DWORK, DWORK(M+1), DWORK(2*M+1), P, LDP, Q, + $ LDQ, DWORK(3*M+1), LDWORK-3*M, INFO ) +C +C Undo scaling +C + IF( ILASCL ) + $ CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, M, M, A, LDA, + $ IERR ) +C + IF( ILDSCL ) + $ CALL DLASCL( 'U', 0, 0, DNRMTO, DNRM, M, M, D, LDD, + $ IERR ) +C + IF ( INFO.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(3*M+1) ) + 3*M ) + END IF + IF ( .NOT.LREDUA ) THEN +C +C Scale B if max element outside range [SMLNUM,BIGNUM] +C + BNRM = DLANGE( 'M', N, N, B, LDB, DWORK ) + ILBSCL = .FALSE. + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN + BNRMTO = SMLNUM + ILBSCL = .TRUE. + ELSE IF( BNRM.GT.BIGNUM ) THEN + BNRMTO = BIGNUM + ILBSCL = .TRUE. + END IF + IF( ILBSCL ) + $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, + $ IERR ) +C +C Scale E if max element outside range [SMLNUM,BIGNUM] +C + ENRM = DLANGE( 'M', N, N, E, LDE, DWORK ) + ILESCL = .FALSE. + IF( ENRM.GT.ZERO .AND. ENRM.LT.SMLNUM ) THEN + ENRMTO = SMLNUM + ILESCL = .TRUE. + ELSE IF( ENRM.GT.BIGNUM ) THEN + ENRMTO = BIGNUM + ILESCL = .TRUE. + END IF + IF( ILESCL ) + $ CALL DLASCL( 'G', 0, 0, ENRM, ENRMTO, N, N, E, LDE, + $ IERR ) +C +C Reduce (B,E) to generalized Schur form. +C Workspace: need 7*N; +C prefer 5*N + N*(NB+1). +C + CALL DGEGS( 'Vectors left', 'Vectors right', N, B, LDB, E, + $ LDE, DWORK, DWORK(N+1), DWORK(2*N+1), U, LDU, V, + $ LDV, DWORK(3*N+1), LDWORK-3*N, INFO ) +C +C Undo scaling +C + IF( ILBSCL ) + $ CALL DLASCL( 'H', 0, 0, BNRMTO, BNRM, N, N, B, LDB, + $ IERR ) +C + IF( ILESCL ) + $ CALL DLASCL( 'U', 0, 0, ENRMTO, ENRM, N, N, E, LDE, + $ IERR ) +C + IF ( INFO.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(3*N+1) ) + 3*N ) + END IF + END IF +C + IF (.NOT.LREDUR ) THEN +C +C Set INFO = 2 if A and/or B are/is not in quasi-triangular form. +C + IF (.NOT.LREDUA ) THEN + I = 1 +C + 20 CONTINUE + IF ( I.LE.M-2 ) THEN + IF ( A(I+1,I).NE.ZERO ) THEN + IF ( A(I+2,I+1).NE.ZERO ) THEN + INFO = 2 + RETURN + ELSE + I = I + 1 + END IF + END IF + I = I + 1 + GO TO 20 + END IF + END IF +C + IF (.NOT.LREDUB ) THEN + I = 1 +C + 40 CONTINUE + IF ( I.LE.N-2 ) THEN + IF ( B(I+1,I).NE.ZERO ) THEN + IF ( B(I+2,I+1).NE.ZERO ) THEN + INFO = 2 + RETURN + ELSE + I = I + 1 + END IF + END IF + I = I + 1 + GO TO 40 + END IF + END IF + END IF +C +C STEP 2: Modify right hand sides (C,F). +C + IF ( LREDUC ) THEN + WRKOPT = MAX( WRKOPT, M*N ) + IF ( SUFWRK ) THEN +C +C Enough workspace for a BLAS 3 calculation. +C + IF ( LTRANN ) THEN +C +C Equation (1). +C + IF ( .NOT.LREDUB ) THEN + CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, + $ P, LDP, C, LDC, ZERO, DWORK, M ) + ELSE + CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) + END IF + IF ( .NOT.LREDUA ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, N, N, + $ ONE, DWORK, M, V, LDV, ZERO, C, LDC ) + ELSE + CALL DLACPY( 'Full', M, N, DWORK, M, C, LDC ) + END IF + IF ( .NOT.LREDUB ) THEN + CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, + $ P, LDP, F, LDF, ZERO, DWORK, M ) + ELSE + CALL DLACPY( 'Full', M, N, F, LDF, DWORK, M ) + END IF + IF ( .NOT.LREDUA ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, N, N, + $ ONE, DWORK, M, V, LDV, ZERO, F, LDF ) + ELSE + CALL DLACPY( 'Full', M, N, DWORK, M, F, LDF ) + END IF + ELSE +C +C Equation (2). +C + IF ( .NOT.LREDUB ) THEN + CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, + $ Q, LDQ, C, LDC, ZERO, DWORK, M ) + ELSE + CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) + END IF + IF ( .NOT.LREDUA ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, N, N, + $ ONE, DWORK, M, V, LDV, ZERO, C, LDC ) + ELSE + CALL DLACPY( 'Full', M, N, DWORK, M, C, LDC ) + END IF + IF ( .NOT.LREDUB ) THEN + CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, + $ P, LDP, F, LDF, ZERO, DWORK, M ) + ELSE + CALL DLACPY( 'Full', M, N, F, LDF, DWORK, M ) + END IF + IF ( .NOT.LREDUA ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, N, N, + $ ONE, DWORK, M, U, LDU, ZERO, F, LDF ) + ELSE + CALL DLACPY( 'Full', M, N, DWORK, M, F, LDF ) + END IF + END IF + ELSE +C +C Use a BLAS 2 calculation. +C + IF ( LTRANN ) THEN +C +C Equation (1). +C + IF ( .NOT.LREDUB ) THEN +C + DO 60 I = 1, N + CALL DGEMV( 'Transpose', M, M, ONE, P, LDP, C(1,I), + $ 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, C(1,I), 1 ) + 60 CONTINUE +C + END IF + IF ( .NOT.LREDUA ) THEN +C + DO 80 I = 1, M + CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, C(I,1), + $ LDC, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, C(I,1), LDC ) + 80 CONTINUE +C + END IF + IF ( .NOT.LREDUB ) THEN +C + DO 100 I = 1, N + CALL DGEMV( 'Transpose', M, M, ONE, P, LDP, F(1,I), + $ 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, F(1,I), 1 ) + 100 CONTINUE +C + END IF + IF ( .NOT.LREDUA ) THEN +C + DO 120 I = 1, M + CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, F(I,1), + $ LDF, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, F(I,1), LDF ) + 120 CONTINUE +C + END IF + ELSE +C +C Equation (2). +C + IF ( .NOT.LREDUB ) THEN +C + DO 140 I = 1, N + CALL DGEMV( 'Transpose', M, M, ONE, Q, LDQ, C(1,I), + $ 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, C(1,I), 1 ) + 140 CONTINUE +C + END IF + IF ( .NOT.LREDUA ) THEN +C + DO 160 I = 1, M + CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, C(I,1), + $ LDC, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, C(I,1), LDC ) + 160 CONTINUE +C + END IF + IF ( .NOT.LREDUB ) THEN +C + DO 180 I = 1, N + CALL DGEMV( 'Transpose', M, M, ONE, P, LDP, F(1,I), + $ 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, F(1,I), 1 ) + 180 CONTINUE +C + END IF + IF ( .NOT.LREDUA ) THEN +C + DO 200 I = 1, M + CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, F(I,1), + $ LDF, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, F(I,1), LDF ) + 200 CONTINUE +C + END IF + END IF + END IF + END IF +C +C STEP 3: Solve the transformed system and compute the Dif +C estimator. +C + IF ( LTRANN ) THEN + IF ( LJOBD ) THEN + IJOB = 1 + ELSE IF ( LJOBF ) THEN + IJOB = 2 + ELSE IF ( LJOB1 ) THEN + IJOB = 3 + ELSE IF ( LJOB2 ) THEN + IJOB = 4 + ELSE + IJOB = 0 + END IF + ELSE + IJOB = 0 + END IF +C +C Workspace: need 2*M*N if TRANS = 'N' and JOBD = 'D' or 'F'; +C 1, otherwise. +C + CALL DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, + $ E, LDE, F, LDF, SCALE, DIF, DWORK, LDWORK, IWORK, + $ INFO ) + IF ( INFO.NE.0 ) THEN + INFO = 3 + RETURN + END IF + IF ( LTRANN ) THEN + IF ( LJOBD.OR.LJOBF ) + $ WRKOPT = MAX( WRKOPT, 2*M*N ) + END IF +C +C STEP 4: Back transformation of the solution. +C + IF ( LREDUC ) THEN + IF (SUFWRK ) THEN +C +C Enough workspace for a BLAS 3 calculation. +C + IF ( LTRANN ) THEN +C +C Equation (1). +C + IF ( .NOT.LREDUB ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, N, M, + $ ONE, Q, LDQ, C, LDC, ZERO, DWORK, M ) + ELSE + CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) + END IF + IF ( .NOT.LREDUA ) THEN + CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE, + $ DWORK, M, V, LDV, ZERO, C, LDC ) + ELSE + CALL DLACPY( 'Full', M, N, DWORK, M, C, LDC ) + END IF + IF ( .NOT.LREDUB ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, N, M, + $ ONE, P, LDP, F, LDF, ZERO, DWORK, M ) + ELSE + CALL DLACPY( 'Full', M, N, F, LDF, DWORK, M ) + END IF + IF ( .NOT.LREDUA ) THEN + CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE, + $ DWORK, M, U, LDU, ZERO, F, LDF ) + ELSE + CALL DLACPY( 'Full', M, N, DWORK, M, F, LDF ) + END IF + ELSE +C +C Equation (2). +C + IF ( .NOT.LREDUB ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, N, M, + $ ONE, P, LDP, C, LDC, ZERO, DWORK, M ) + ELSE + CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) + END IF + IF ( .NOT.LREDUA ) THEN + CALL DGEMM( 'No transpose', 'Transpose', M, N, N, + $ ONE, DWORK, M, V, LDV, ZERO, C, LDC ) + ELSE + CALL DLACPY( 'Full', M, N, DWORK, M, C, LDC ) + END IF + IF ( .NOT.LREDUB ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, N, M, + $ ONE, P, LDP, F, LDF, ZERO, DWORK, M ) + ELSE + CALL DLACPY( 'Full', M, N, F, LDF, DWORK, M ) + END IF + IF ( .NOT.LREDUA ) THEN + CALL DGEMM( 'No transpose', 'Transpose', M, N, N, + $ ONE, DWORK, M, V, LDV, ZERO, F, LDF ) + ELSE + CALL DLACPY( 'Full', M, N, DWORK, M, F, LDF ) + END IF + END IF + ELSE +C +C Use a BLAS 2 calculation. +C + IF ( LTRANN ) THEN +C +C Equation (1). +C + IF ( .NOT.LREDUB ) THEN +C + DO 220 I = 1, N + CALL DGEMV( 'No transpose', M, M, ONE, Q, LDQ, + $ C(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, C(1,I), 1 ) + 220 CONTINUE +C + END IF + IF ( .NOT.LREDUA ) THEN +C + DO 240 I = 1, M + CALL DGEMV( 'No transpose', N, N, ONE, V, LDV, + $ C(I,1), LDC, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, C(I,1), LDC ) + 240 CONTINUE +C + END IF + IF ( .NOT.LREDUB ) THEN +C + DO 260 I = 1, N + CALL DGEMV( 'No transpose', M, M, ONE, P, LDP, + $ F(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, F(1,I), 1 ) + 260 CONTINUE +C + END IF + IF ( .NOT.LREDUA ) THEN +C + DO 280 I = 1, M + CALL DGEMV( 'No transpose', N, N, ONE, U, LDU, + $ F(I,1), LDF, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, F(I,1), LDF ) + 280 CONTINUE +C + END IF + ELSE +C +C Equation (2). +C + IF ( .NOT.LREDUB ) THEN +C + DO 300 I = 1, N + CALL DGEMV( 'No transpose', M, M, ONE, P, LDP, + $ C(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, C(1,I), 1 ) + 300 CONTINUE +C + END IF + IF ( .NOT.LREDUA ) THEN +C + DO 320 I = 1, M + CALL DGEMV( 'No transpose', N, N, ONE, V, LDV, + $ C(I,1), LDC, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, C(I,1), LDC ) + 320 CONTINUE +C + END IF + IF ( .NOT.LREDUB ) THEN +C + DO 340 I = 1, N + CALL DGEMV( 'No transpose', M, M, ONE, P, LDP, + $ F(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, F(1,I), 1 ) + 340 CONTINUE +C + END IF + IF ( .NOT.LREDUA ) THEN +C + DO 360 I = 1, M + CALL DGEMV( 'No transpose', N, N, ONE, V, LDV, + $ F(I,1), LDF, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, F(I,1), LDF ) + 360 CONTINUE +C + END IF + END IF + END IF + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB04OD *** + END diff --git a/mex/sources/libslicot/SB04OW.f b/mex/sources/libslicot/SB04OW.f new file mode 100644 index 000000000..c3d613afd --- /dev/null +++ b/mex/sources/libslicot/SB04OW.f @@ -0,0 +1,568 @@ + SUBROUTINE SB04OW( M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, + $ F, LDF, SCALE, IWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a periodic Sylvester equation +C +C A * R - L * B = scale * C (1) +C D * L - R * E = scale * F, +C +C using Level 1 and 2 BLAS, where R and L are unknown M-by-N +C matrices, (A, D), (B, E) and (C, F) are given matrix pairs of +C size M-by-M, N-by-N and M-by-N, respectively, with real entries. +C (A, D) and (B, E) must be in periodic Schur form, i.e. A, B are +C upper quasi triangular and D, E are upper triangular. The solution +C (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output scaling +C factor chosen to avoid overflow. +C +C This routine is largely based on the LAPACK routine DTGSY2 +C developed by Bo Kagstrom and Peter Poromaa. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of A and D, and the row dimension of C, F, R +C and L. M >= 0. +C +C N (input) INTEGER +C The order of B and E, and the column dimension of C, F, R +C and L. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C On entry, the leading M-by-M part of this array must +C contain the upper quasi triangular matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain the upper quasi triangular matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the right-hand-side of the first matrix equation +C in (1). +C On exit, the leading M-by-N part of this array contains +C the solution R. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,M). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading M-by-M part of this array must +C contain the upper triangular matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= MAX(1,M). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the upper triangular matrix E. +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,N). +C +C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) +C On entry, the leading M-by-N part of this array must +C contain the right-hand-side of the second matrix equation +C in (1). +C On exit, the leading M-by-N part of this array contains +C the solution L. +C +C LDF INTEGER +C The leading dimension of the array F. LDF >= MAX(1,M). +C +C SCALE (output) DOUBLE PRECISION +C On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the arrays +C C and F will hold the solutions R and L, respectively, to +C a slightly perturbed system but the input matrices A, B, D +C and E have not been changed. If SCALE = 0, C and F will +C hold solutions to the homogeneous system with C = F = 0. +C Normally, SCALE = 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (M+N+2) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: the matrix products A*D and B*E have common or very +C close eigenvalues. +C +C METHOD +C +C In matrix notation solving equation (1) corresponds to solving +C Z*x = scale*b, where Z is defined as +C +C Z = [ kron(In, A) -kron(B', Im) ] (2) +C [ -kron(E', Im) kron(In, D) ], +C +C Ik is the identity matrix of size k and X' is the transpose of X. +C kron(X, Y) is the Kronecker product between the matrices X and Y. +C In the process of solving (1), we solve a number of such systems +C where Dim(Im), Dim(In) = 1 or 2. +C +C REFERENCES +C +C [1] Kagstrom, B. +C A Direct Method for Reordering Eigenvalues in the Generalized +C Real Schur Form of a Regular Matrix Pair (A,B). M.S. Moonen +C et al (eds.), Linear Algebra for Large Scale and Real-Time +C Applications, Kluwer Academic Publ., pp. 195-218, 1993. +C +C [2] Sreedhar, J. and Van Dooren, P. +C A Schur approach for solving some periodic matrix equations. +C U. Helmke et al (eds.), Systems and Networks: Mathematical +C Theory and Applications, Akademie Verlag, Berlin, vol. 77, +C pp. 339-362, 1994. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DTGPY2). +C +C KEYWORDS +C +C Matrix equation, periodic Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER LDZ + PARAMETER ( LDZ = 8 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N + DOUBLE PRECISION SCALE +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ E(LDE,*), F(LDF,*) +C .. Local Scalars .. + INTEGER I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1, + $ K, MB, NB, P, Q, ZDIM + DOUBLE PRECISION SCALOC +C .. Local Arrays .. + INTEGER IPIV(LDZ), JPIV(LDZ) + DOUBLE PRECISION RHS(LDZ), Z(LDZ,LDZ) +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGER, DGESC2, + $ DGETC2, DLASET, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + IERR = 0 + IF ( M.LE.0 ) THEN + INFO = -1 + ELSE IF ( N.LE.0 ) THEN + INFO = -2 + ELSE IF ( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF ( LDC.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF ( LDD.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF ( LDE.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF ( LDF.LT.MAX( 1, M ) ) THEN + INFO = -14 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'SB04OW', -INFO ) + RETURN + END IF +C +C Determine block structure of A. +C + P = 0 + I = 1 + 10 CONTINUE + IF ( I.GT.M ) + $ GO TO 20 + P = P + 1 + IWORK(P) = I + IF( I.EQ.M ) + $ GO TO 20 + IF ( A(I+1,I).NE.ZERO ) THEN + I = I + 2 + ELSE + I = I + 1 + END IF + GO TO 10 + 20 CONTINUE + IWORK(P+1) = M + 1 +C +C Determine block structure of B. +C + Q = P + 1 + J = 1 + 30 CONTINUE + IF ( J.GT.N ) + $ GO TO 40 + Q = Q + 1 + IWORK(Q) = J + IF( J.EQ.N ) + $ GO TO 40 + IF ( B(J+1,J).NE.ZERO ) THEN + J = J + 2 + ELSE + J = J + 1 + END IF + GO TO 30 + 40 CONTINUE + IWORK(Q+1) = N + 1 +C +C Solve (I, J) - subsystem +C A(I,I) * R(I,J) - L(I,J) * B(J,J) = C(I,J) +C D(I,I) * L(I,J) - R(I,J) * E(J,J) = F(I,J) +C for I = P, P - 1, ..., 1; J = 1, 2, ..., Q. +C + SCALE = ONE + SCALOC = ONE + DO 120 J = P + 2, Q + JS = IWORK(J) + JSP1 = JS + 1 + JE = IWORK(J+1) - 1 + NB = JE - JS + 1 + DO 110 I = P, 1, -1 +C + IS = IWORK(I) + ISP1 = IS + 1 + IE = IWORK(I+1) - 1 + MB = IE - IS + 1 + ZDIM = MB*NB*2 +C + IF ( ( MB.EQ.1 ).AND.( NB.EQ.1 ) ) THEN +C +C Build a 2-by-2 system Z * x = RHS. +C + Z(1,1) = A(IS,IS) + Z(2,1) = -E(JS,JS) + Z(1,2) = -B(JS,JS) + Z(2,2) = D(IS,IS) +C +C Set up right hand side(s). +C + RHS(1) = C(IS,JS) + RHS(2) = F(IS,JS) +C +C Solve Z * x = RHS. +C + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF ( IERR.GT.0 ) + $ INFO = IERR +C + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF ( SCALOC.NE.ONE ) THEN + DO 50 K = 1, N + CALL DSCAL( M, SCALOC, C(1,K), 1 ) + CALL DSCAL( M, SCALOC, F(1,K), 1 ) + 50 CONTINUE + SCALE = SCALE*SCALOC + END IF +C +C Unpack solution vector(s). +C + C(IS,JS) = RHS(1) + F(IS,JS) = RHS(2) +C +C Substitute R(I,J) and L(I,J) into remaining equation. +C + IF ( I.GT.1 ) THEN + CALL DAXPY( IS-1, -RHS(1), A(1,IS), 1, C(1,JS), 1 ) + CALL DAXPY( IS-1, -RHS(2), D(1,IS), 1, F(1,JS), 1 ) + END IF + IF ( J.LT.Q ) THEN + CALL DAXPY( N-JE, RHS(2), B(JS,JE+1), LDB, C(IS,JE+1), + $ LDC ) + CALL DAXPY( N-JE, RHS(1), E(JS,JE+1), LDE, F(IS,JE+1), + $ LDF ) + END IF +C + ELSE IF ( ( MB.EQ.1 ).AND.( NB.EQ.2 ) ) THEN +C +C Build a 4-by-4 system Z * x = RHS. +C + Z(1,1) = A(IS,IS) + Z(2,1) = ZERO + Z(3,1) = -E(JS,JS) + Z(4,1) = -E(JS,JSP1) +C + Z(1,2) = ZERO + Z(2,2) = A(IS,IS) + Z(3,2) = ZERO + Z(4,2) = -E(JSP1,JSP1) +C + Z(1,3) = -B(JS,JS) + Z(2,3) = -B(JS,JSP1) + Z(3,3) = D(IS,IS) + Z(4,3) = ZERO +C + Z(1,4) = -B(JSP1,JS) + Z(2,4) = -B(JSP1,JSP1) + Z(3,4) = ZERO + Z(4,4) = D(IS,IS) +C +C Set up right hand side(s). +C + RHS(1) = C(IS,JS) + RHS(2) = C(IS,JSP1) + RHS(3) = F(IS,JS) + RHS(4) = F(IS,JSP1) +C +C Solve Z * x = RHS. +C + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF ( IERR.GT.0 ) + $ INFO = IERR +C + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF ( SCALOC.NE.ONE ) THEN + DO 60 K = 1, N + CALL DSCAL( M, SCALOC, C(1,K), 1 ) + CALL DSCAL( M, SCALOC, F(1,K), 1 ) + 60 CONTINUE + SCALE = SCALE*SCALOC + END IF +C +C Unpack solution vector(s). +C + C(IS,JS) = RHS(1) + C(IS,JSP1) = RHS(2) + F(IS,JS) = RHS(3) + F(IS,JSP1) = RHS(4) +C +C Substitute R(I,J) and L(I,J) into remaining equation. +C + IF ( I.GT.1 ) THEN + CALL DGER( IS-1, NB, -ONE, A(1,IS), 1, RHS(1), 1, + $ C(1,JS), LDC ) + CALL DGER( IS-1, NB, -ONE, D(1,IS), 1, RHS(3), 1, + $ F(1,JS), LDF ) + END IF + IF ( J.LT.Q ) THEN + CALL DAXPY( N-JE, RHS(3), B(JS,JE+1), LDB, C(IS,JE+1), + $ LDC ) + CALL DAXPY( N-JE, RHS(1), E(JS,JE+1), LDE, F(IS,JE+1), + $ LDF ) + CALL DAXPY( N-JE, RHS(4), B(JSP1,JE+1), LDB, + $ C(IS,JE+1), LDC ) + CALL DAXPY( N-JE, RHS(2), E(JSP1,JE+1), LDE, + $ F(IS,JE+1), LDF ) + END IF +C + ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN +C +C Build a 4-by-4 system Z * x = RHS. +C + Z(1,1) = A(IS,IS) + Z(2,1) = A(ISP1,IS) + Z(3,1) = -E(JS,JS) + Z(4,1) = ZERO +C + Z(1,2) = A(IS,ISP1) + Z(2,2) = A(ISP1,ISP1) + Z(3,2) = ZERO + Z(4,2) = -E(JS,JS) +C + Z(1,3) = -B(JS,JS) + Z(2,3) = ZERO + Z(3,3) = D(IS,IS) + Z(4,3) = ZERO +C + Z(1,4) = ZERO + Z(2,4) = -B(JS,JS) + Z(3,4) = D(IS,ISP1) + Z(4,4) = D(ISP1,ISP1) +C +C Set up right hand side(s). +C + RHS(1) = C(IS,JS) + RHS(2) = C(ISP1,JS) + RHS(3) = F(IS,JS) + RHS(4) = F(ISP1,JS) +C +C Solve Z * x = RHS. +C + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF ( IERR.GT.0 ) + $ INFO = IERR +C + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF ( SCALOC.NE.ONE ) THEN + DO 70 K = 1, N + CALL DSCAL( M, SCALOC, C(1,K), 1 ) + CALL DSCAL( M, SCALOC, F(1,K), 1 ) + 70 CONTINUE + SCALE = SCALE*SCALOC + END IF +C +C Unpack solution vector(s). +C + C(IS,JS) = RHS(1) + C(ISP1,JS) = RHS(2) + F(IS,JS) = RHS(3) + F(ISP1,JS) = RHS(4) +C +C Substitute R(I,J) and L(I,J) into remaining equation. +C + IF ( I.GT.1 ) THEN + CALL DGEMV( 'N', IS-1, MB, -ONE, A(1,IS), LDA, RHS(1), + $ 1, ONE, C(1,JS), 1 ) + CALL DGEMV( 'N', IS-1, MB, -ONE, D(1,IS), LDD, RHS(3), + $ 1, ONE, F(1,JS), 1 ) + END IF + IF ( J.LT.Q ) THEN + CALL DGER( MB, N-JE, ONE, RHS(3), 1, B(JS,JE+1), LDB, + $ C(IS,JE+1), LDC ) + CALL DGER( MB, N-JE, ONE, RHS(1), 1, E(JS,JE+1), LDE, + $ F(IS,JE+1), LDF ) + END IF +C + ELSE IF ( ( MB.EQ.2 ).AND.( NB.EQ.2 ) ) THEN +C +C Build an 8-by-8 system Z * x = RHS. +C + CALL DLASET( 'All', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) +C + Z(1,1) = A(IS,IS) + Z(2,1) = A(ISP1,IS) + Z(5,1) = -E(JS,JS) + Z(7,1) = -E(JS,JSP1) +C + Z(1,2) = A(IS,ISP1) + Z(2,2) = A(ISP1,ISP1) + Z(6,2) = -E(JS,JS) + Z(8,2) = -E(JS,JSP1) +C + Z(3,3) = A(IS,IS) + Z(4,3) = A(ISP1,IS) + Z(7,3) = -E(JSP1,JSP1) +C + Z(3,4) = A(IS,ISP1) + Z(4,4) = A(ISP1,ISP1) + Z(8,4) = -E(JSP1,JSP1) +C + Z(1,5) = -B(JS,JS) + Z(3,5) = -B(JS,JSP1) + Z(5,5) = D(IS,IS) +C + Z(2,6) = -B(JS,JS) + Z(4,6) = -B(JS,JSP1) + Z(5,6) = D(IS,ISP1) + Z(6,6) = D(ISP1,ISP1) +C + Z(1,7) = -B(JSP1,JS) + Z(3,7) = -B(JSP1,JSP1) + Z(7,7) = D(IS,IS) +C + Z(2,8) = -B(JSP1,JS) + Z(4,8) = -B(JSP1,JSP1) +C + Z(7,8) = D(IS,ISP1) + Z(8,8) = D(ISP1,ISP1) +C +C Set up right hand side(s). +C + K = 1 + II = MB*NB + 1 + DO 80 JJ = 0, NB - 1 + CALL DCOPY( MB, C(IS,JS+JJ), 1, RHS(K), 1 ) + CALL DCOPY( MB, F(IS,JS+JJ), 1, RHS(II), 1 ) + K = K + MB + II = II + MB + 80 CONTINUE +C +C Solve Z * x = RHS. +C + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF ( IERR.GT.0 ) + $ INFO = IERR +C + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF ( SCALOC.NE.ONE ) THEN + DO 90 K = 1, N + CALL DSCAL( M, SCALOC, C(1,K), 1 ) + CALL DSCAL( M, SCALOC, F(1,K), 1 ) + 90 CONTINUE + SCALE = SCALE*SCALOC + END IF +C +C Unpack solution vector(s). +C + K = 1 + II = MB*NB + 1 + DO 100 JJ = 0, NB - 1 + CALL DCOPY( MB, RHS(K), 1, C(IS,JS+JJ), 1 ) + CALL DCOPY( MB, RHS(II), 1, F(IS,JS+JJ), 1 ) + K = K + MB + II = II + MB + 100 CONTINUE +C +C Substitute R(I,J) and L(I,J) into remaining equation. +C + K = MB*NB + 1 + IF ( I.GT.1 ) THEN + CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, A(1,IS), + $ LDA, RHS(1), MB, ONE, C(1,JS), LDC ) + CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, D(1,IS), + $ LDD, RHS(K), MB, ONE, F(1,JS), LDF ) + END IF + IF ( J.LT.Q ) THEN + CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS(K), MB, + $ B(JS,JE+1), LDB, ONE, C(IS,JE+1), LDC ) + CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS(1), MB, + $ E(JS,JE+1), LDE, ONE, F(IS,JE+1), LDF ) + END IF +C + END IF +C + 110 CONTINUE + 120 CONTINUE + RETURN +C *** Last line of SB04OW *** + END diff --git a/mex/sources/libslicot/SB04PD.f b/mex/sources/libslicot/SB04PD.f new file mode 100644 index 000000000..a2e5899a4 --- /dev/null +++ b/mex/sources/libslicot/SB04PD.f @@ -0,0 +1,672 @@ + SUBROUTINE SB04PD( DICO, FACTA, FACTB, TRANA, TRANB, ISGN, M, N, + $ A, LDA, U, LDU, B, LDB, V, LDV, C, LDC, SCALE, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X either the real continuous-time Sylvester equation +C +C op(A)*X + ISGN*X*op(B) = scale*C, (1) +C +C or the real discrete-time Sylvester equation +C +C op(A)*X*op(B) + ISGN*X = scale*C, (2) +C +C where op(M) = M or M**T, and ISGN = 1 or -1. A is M-by-M and +C B is N-by-N; the right hand side C and the solution X are M-by-N; +C and scale is an output scale factor, set less than or equal to 1 +C to avoid overflow in X. The solution matrix X is overwritten +C onto C. +C +C If A and/or B are not (upper) quasi-triangular, that is, block +C upper triangular with 1-by-1 and 2-by-2 diagonal blocks, they are +C reduced to Schur canonical form, that is, quasi-triangular with +C each 2-by-2 diagonal block having its diagonal elements equal and +C its off-diagonal elements of opposite sign. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the equation from which X is to be determined +C as follows: +C = 'C': Equation (1), continuous-time case; +C = 'D': Equation (2), discrete-time case. +C +C FACTA CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, A and U contain the factors from the +C real Schur factorization of the matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in A and U; +C = 'S': The matrix A is quasi-triangular (or Schur). +C +C FACTB CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix B is supplied on entry, as follows: +C = 'F': On entry, B and V contain the factors from the +C real Schur factorization of the matrix B; +C = 'N': The Schur factorization of B will be computed +C and the factors will be stored in B and V; +C = 'S': The matrix B is quasi-triangular (or Schur). +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C TRANB CHARACTER*1 +C Specifies the form of op(B) to be used, as follows: +C = 'N': op(B) = B (No transpose); +C = 'T': op(B) = B**T (Transpose); +C = 'C': op(B) = B**T (Conjugate transpose = Transpose). +C +C ISGN INTEGER +C Specifies the sign of the equation as described before. +C ISGN may only be 1 or -1. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A, and the number of rows in the +C matrices X and C. M >= 0. +C +C N (input) INTEGER +C The order of the matrix B, and the number of columns in +C the matrices X and C. N >= 0. +C +C A (input or input/output) DOUBLE PRECISION array, +C dimension (LDA,M) +C On entry, the leading M-by-M part of this array must +C contain the matrix A. If FACTA = 'S', then A contains +C a quasi-triangular matrix, and if FACTA = 'F', then A +C is in Schur canonical form; the elements below the upper +C Hessenberg part of the array A are not referenced. +C On exit, if FACTA = 'N', and INFO = 0 or INFO >= M+1, the +C leading M-by-M upper Hessenberg part of this array +C contains the upper quasi-triangular matrix in Schur +C canonical form from the Schur factorization of A. The +C contents of array A is not modified if FACTA = 'F' or 'S'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,M) +C If FACTA = 'F', then U is an input argument and on entry +C the leading M-by-M part of this array must contain the +C orthogonal matrix U of the real Schur factorization of A. +C If FACTA = 'N', then U is an output argument and on exit, +C if INFO = 0 or INFO >= M+1, it contains the orthogonal +C M-by-M matrix from the real Schur factorization of A. +C If FACTA = 'S', the array U is not referenced. +C +C LDU INTEGER +C The leading dimension of array U. +C LDU >= MAX(1,M), if FACTA = 'F' or 'N'; +C LDU >= 1, if FACTA = 'S'. +C +C B (input or input/output) DOUBLE PRECISION array, +C dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix B. If FACTB = 'S', then B contains +C a quasi-triangular matrix, and if FACTB = 'F', then B +C is in Schur canonical form; the elements below the upper +C Hessenberg part of the array B are not referenced. +C On exit, if FACTB = 'N', and INFO = 0 or INFO = M+N+1, +C the leading N-by-N upper Hessenberg part of this array +C contains the upper quasi-triangular matrix in Schur +C canonical form from the Schur factorization of B. The +C contents of array B is not modified if FACTB = 'F' or 'S'. +C +C LDB (input) INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C V (input or output) DOUBLE PRECISION array, dimension +C (LDV,N) +C If FACTB = 'F', then V is an input argument and on entry +C the leading N-by-N part of this array must contain the +C orthogonal matrix V of the real Schur factorization of B. +C If FACTB = 'N', then V is an output argument and on exit, +C if INFO = 0 or INFO = M+N+1, it contains the orthogonal +C N-by-N matrix from the real Schur factorization of B. +C If FACTB = 'S', the array V is not referenced. +C +C LDV INTEGER +C The leading dimension of array V. +C LDV >= MAX(1,N), if FACTB = 'F' or 'N'; +C LDV >= 1, if FACTB = 'S'. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the right hand side matrix C. +C On exit, if INFO = 0 or INFO = M+N+1, the leading M-by-N +C part of this array contains the solution matrix X. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or M+N+1, then: DWORK(1) returns the +C optimal value of LDWORK; if FACTA = 'N', DWORK(1+i) and +C DWORK(1+M+i), i = 1,...,M, contain the real and imaginary +C parts, respectively, of the eigenvalues of A; and, if +C FACTB = 'N', DWORK(1+f+j) and DWORK(1+f+N+j), j = 1,...,N, +C with f = 2*M if FACTA = 'N', and f = 0, otherwise, contain +C the real and imaginary parts, respectively, of the +C eigenvalues of B. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, a+MAX( c, b+d, b+e ) ), +C where a = 1+2*M, if FACTA = 'N', +C a = 0, if FACTA <> 'N', +C b = 2*N, if FACTB = 'N', FACTA = 'N', +C b = 1+2*N, if FACTB = 'N', FACTA <> 'N', +C b = 0, if FACTB <> 'N', +C c = 3*M, if FACTA = 'N', +C c = M, if FACTA = 'F', +C c = 0, if FACTA = 'S', +C d = 3*N, if FACTB = 'N', +C d = N, if FACTB = 'F', +C d = 0, if FACTB = 'S', +C e = M, if DICO = 'C', FACTA <> 'S', +C e = 0, if DICO = 'C', FACTA = 'S', +C e = 2*M, if DICO = 'D'. +C An upper bound is +C LDWORK = 1+2*M+MAX( 3*M, 5*N, 2*N+2*M ). +C For good performance, LDWORK should be larger, e.g., +C LDWORK = 1+2*M+MAX( 3*M, 5*N, 2*N+2*M, 2*N+M*N ). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = i: if INFO = i, i = 1,...,M, the QR algorithm failed +C to compute all the eigenvalues of the matrix A +C (see LAPACK Library routine DGEES); the elements +C 2+i:1+M and 2+i+M:1+2*M of DWORK contain the real +C and imaginary parts, respectively, of the +C eigenvalues of A which have converged, and the +C array A contains the partially converged Schur form; +C = M+j: if INFO = M+j, j = 1,...,N, the QR algorithm +C failed to compute all the eigenvalues of the matrix +C B (see LAPACK Library routine DGEES); the elements +C 2+f+j:1+f+N and 2+f+j+N:1+f+2*N of DWORK contain the +C real and imaginary parts, respectively, of the +C eigenvalues of B which have converged, and the +C array B contains the partially converged Schur form; +C as defined for the parameter DWORK, +C f = 2*M, if FACTA = 'N', +C f = 0, if FACTA <> 'N'; +C = M+N+1: if DICO = 'C', and the matrices A and -ISGN*B +C have common or very close eigenvalues, or +C if DICO = 'D', and the matrices A and -ISGN*B have +C almost reciprocal eigenvalues (that is, if lambda(i) +C and mu(j) are eigenvalues of A and -ISGN*B, then +C lambda(i) = 1/mu(j) for some i and j); +C perturbed values were used to solve the equation +C (but the matrices A and B are unchanged). +C +C METHOD +C +C An extension and refinement of the algorithms in [1,2] is used. +C If the matrices A and/or B are not quasi-triangular (see PURPOSE), +C they are reduced to Schur canonical form +C +C A = U*S*U', B = V*T*V', +C +C where U, V are orthogonal, and S, T are block upper triangular +C with 1-by-1 and 2-by-2 blocks on their diagonal. The right hand +C side matrix C is updated accordingly, +C +C C = U'*C*V; +C +C then, the solution matrix X of the "reduced" Sylvester equation +C (with A and B in (1) or (2) replaced by S and T, respectively), +C is computed column-wise via a back substitution scheme. A set of +C equivalent linear algebraic systems of equations of order at most +C four are formed and solved using Gaussian elimination with +C complete pivoting. Finally, the solution X of the original +C equation is obtained from the updating formula +C +C X = U*X*V'. +C +C If A and/or B are already quasi-triangular (or in Schur form), the +C initial factorizations and the corresponding updating steps are +C omitted. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C The algorithm is stable and reliable, since orthogonal +C transformations and Gaussian elimination with complete pivoting +C are used. If INFO = M+N+1, the Sylvester equation is numerically +C singular. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, April 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Matrix algebra, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER DICO, FACTA, FACTB, TRANA, TRANB + INTEGER INFO, ISGN, LDA, LDB, LDC, LDU, LDV, LDWORK, M, + $ N + DOUBLE PRECISION SCALE +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), U( LDU, * ), V( LDV, * ) +C .. +C .. Local Scalars .. + LOGICAL BLAS3A, BLAS3B, BLOCKA, BLOCKB, CONT, NOFACA, + $ NOFACB, NOTRNA, NOTRNB, SCHURA, SCHURB + INTEGER AVAILW, BL, CHUNKA, CHUNKB, I, IA, IB, IERR, J, + $ JWORK, MAXWRK, MINWRK, SDIM +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + EXTERNAL LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DLACPY, DTRSYL, + $ SB04PY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters +C + CONT = LSAME( DICO, 'C' ) + NOFACA = LSAME( FACTA, 'N' ) + NOFACB = LSAME( FACTB, 'N' ) + SCHURA = LSAME( FACTA, 'S' ) + SCHURB = LSAME( FACTB, 'S' ) + NOTRNA = LSAME( TRANA, 'N' ) + NOTRNB = LSAME( TRANB, 'N' ) +C + INFO = 0 + IF( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOFACA .AND. .NOT.LSAME( FACTA, 'F' ) .AND. + $ .NOT.SCHURA ) THEN + INFO = -2 + ELSE IF( .NOT.NOFACB .AND. .NOT.LSAME( FACTB, 'F' ) .AND. + $ .NOT.SCHURB ) THEN + INFO = -3 + ELSE IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. + $ .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -4 + ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. + $ .NOT.LSAME( TRANB, 'C' ) ) THEN + INFO = -5 + ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN + INFO = -6 + ELSE IF( M.LT.0 ) THEN + INFO = -7 + ELSE IF( N.LT.0 ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDU.LT.1 .OR. ( .NOT.SCHURA .AND. LDU.LT.M ) ) THEN + INFO = -12 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDV.LT.1 .OR. ( .NOT.SCHURB .AND. LDV.LT.N ) ) THEN + INFO = -16 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -18 + ELSE + IF ( NOFACA ) THEN + IA = 1 + 2*M + MINWRK = 3*M + ELSE + IA = 0 + END IF + IF ( SCHURA ) THEN + MINWRK = 0 + ELSE IF ( .NOT.NOFACA ) THEN + MINWRK = M + END IF + IB = 0 + IF ( NOFACB ) THEN + IB = 2*N + IF ( .NOT.NOFACA ) + $ IB = IB + 1 + MINWRK = MAX( MINWRK, IB + 3*N ) + ELSE IF ( .NOT.SCHURB ) THEN + MINWRK = MAX( MINWRK, N ) + END IF + IF ( CONT ) THEN + IF ( .NOT.SCHURA ) + $ MINWRK = MAX( MINWRK, IB + M ) + ELSE + MINWRK = MAX( MINWRK, IB + 2*M ) + END IF + MINWRK = MAX( 1, IA + MINWRK ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -21 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB04PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + SCALE = ONE + DWORK( 1 ) = ONE + RETURN + END IF + MAXWRK = MINWRK +C + IF( NOFACA ) THEN +C +C Compute the Schur factorization of A. +C Workspace: need 1+5*M; +C prefer larger. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + JWORK = 2*M + 2 + IA = JWORK + AVAILW = LDWORK - JWORK + 1 + CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, A, LDA, SDIM, + $ DWORK( 2 ), DWORK( M+2 ), U, LDU, DWORK( JWORK ), + $ AVAILW, BWORK, IERR ) + IF( IERR.GT.0 ) THEN + INFO = IERR + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 ) + ELSE + JWORK = 1 + IA = 2 + AVAILW = LDWORK + END IF +C + IF( .NOT.SCHURA ) THEN +C +C Transform the right-hand side: C <-- U'*C. +C Workspace: need a+M, +C prefer a+M*N, +C where a = 1+2*M, if FACTA = 'N', +C a = 0, if FACTA <> 'N'. +C + CHUNKA = AVAILW / M + BLOCKA = MIN( CHUNKA, N ).GT.1 + BLAS3A = CHUNKA.GE.N .AND. BLOCKA +C + IF ( BLAS3A ) THEN +C +C Enough workspace for a fast BLAS 3 algorithm. +C + CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, N, M, ONE, + $ U, LDU, DWORK( JWORK ), M, ZERO, C, LDC ) + ELSE IF ( BLOCKA ) THEN +C +C Use as many columns of C as possible. +C + DO 10 J = 1, N, CHUNKA + BL = MIN( N-J+1, CHUNKA ) + CALL DLACPY( 'Full', M, BL, C( 1, J ), LDC, + $ DWORK( JWORK ), M ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, BL, M, ONE, + $ U, LDU, DWORK( JWORK ), M, ZERO, C( 1, J ), + $ LDC ) + 10 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. +C + DO 20 J = 1, N + CALL DCOPY( M, C( 1, J ), 1, DWORK( JWORK ), 1 ) + CALL DGEMV( 'Transpose', M, M, ONE, U, LDU, + $ DWORK( JWORK ), 1, ZERO, C( 1, J ), 1 ) + 20 CONTINUE +C + END IF + MAXWRK = MAX( MAXWRK, JWORK + M*N - 1 ) + END IF +C + IF( NOFACB ) THEN +C +C Compute the Schur factorization of B. +C Workspace: need 1+MAX(a-1,0)+5*N, +C prefer larger. +C + JWORK = IA + 2*N + AVAILW = LDWORK - JWORK + 1 + CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, B, LDB, SDIM, + $ DWORK( IA ), DWORK( N+IA ), V, LDV, DWORK( JWORK ), + $ AVAILW, BWORK, IERR ) + IF( IERR.GT.0 ) THEN + INFO = IERR + M + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 ) +C + IF( .NOT.SCHURA ) THEN +C +C Recompute the blocking parameters. +C + CHUNKA = AVAILW / M + BLOCKA = MIN( CHUNKA, N ).GT.1 + BLAS3A = CHUNKA.GE.N .AND. BLOCKA + END IF + END IF +C + IF( .NOT.SCHURB ) THEN +C +C Transform the right-hand side: C <-- C*V. +C Workspace: need a+b+N, +C prefer a+b+M*N, +C where b = 2*N, if FACTB = 'N', FACTA = 'N', +C b = 1+2*N, if FACTB = 'N', FACTA <> 'N', +C b = 0, if FACTB <> 'N'. +C + CHUNKB = AVAILW / N + BLOCKB = MIN( CHUNKB, M ).GT.1 + BLAS3B = CHUNKB.GE.M .AND. BLOCKB +C + IF ( BLAS3B ) THEN +C +C Enough workspace for a fast BLAS 3 algorithm. +C + CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N, ONE, + $ DWORK( JWORK ), M, V, LDV, ZERO, C, LDC ) + ELSE IF ( BLOCKB ) THEN +C +C Use as many rows of C as possible. +C + DO 30 I = 1, M, CHUNKB + BL = MIN( M-I+1, CHUNKB ) + CALL DLACPY( 'Full', BL, N, C( I, 1 ), LDC, + $ DWORK( JWORK ), BL ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, N, N, ONE, + $ DWORK( JWORK ), BL, V, LDV, ZERO, C( I, 1 ), + $ LDC ) + 30 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. +C + DO 40 I = 1, M + CALL DCOPY( N, C( I, 1 ), LDC, DWORK( JWORK ), 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, + $ DWORK( JWORK ), 1, ZERO, C( I, 1 ), LDC ) + 40 CONTINUE +C + END IF + MAXWRK = MAX( MAXWRK, JWORK + M*N - 1 ) + END IF +C +C Solve the (transformed) equation. +C Workspace for DICO = 'D': a+b+2*M. +C + IF ( CONT ) THEN + CALL DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, + $ SCALE, IERR ) + ELSE + CALL SB04PY( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, + $ SCALE, DWORK( JWORK ), IERR ) + MAXWRK = MAX( MAXWRK, JWORK + 2*M - 1 ) + END IF + IF( IERR.GT.0 ) + $ INFO = M + N + 1 +C +C Transform back the solution, if needed. +C + IF( .NOT.SCHURA ) THEN +C +C Transform the right-hand side: C <-- U*C. +C Workspace: need a+b+M; +C prefer a+b+M*N. +C + IF ( BLAS3A ) THEN +C +C Enough workspace for a fast BLAS 3 algorithm. +C + CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, ONE, + $ U, LDU, DWORK( JWORK ), M, ZERO, C, LDC ) + ELSE IF ( BLOCKA ) THEN +C +C Use as many columns of C as possible. +C + DO 50 J = 1, N, CHUNKA + BL = MIN( N-J+1, CHUNKA ) + CALL DLACPY( 'Full', M, BL, C( 1, J ), LDC, + $ DWORK( JWORK ), M ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, BL, M, ONE, + $ U, LDU, DWORK( JWORK ), M, ZERO, C( 1, J ), + $ LDC ) + 50 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. +C + DO 60 J = 1, N + CALL DCOPY( M, C( 1, J ), 1, DWORK( JWORK ), 1 ) + CALL DGEMV( 'NoTranspose', M, M, ONE, U, LDU, + $ DWORK( JWORK ), 1, ZERO, C( 1, J ), 1 ) + 60 CONTINUE +C + END IF + END IF +C + IF( .NOT.SCHURB ) THEN +C +C Transform the right-hand side: C <-- C*V'. +C Workspace: need a+b+N; +C prefer a+b+M*N. +C + IF ( BLAS3B ) THEN +C +C Enough workspace for a fast BLAS 3 algorithm. +C + CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) + CALL DGEMM( 'NoTranspose', 'Transpose', M, N, N, ONE, + $ DWORK( JWORK ), M, V, LDV, ZERO, C, LDC ) + ELSE IF ( BLOCKB ) THEN +C +C Use as many rows of C as possible. +C + DO 70 I = 1, M, CHUNKB + BL = MIN( M-I+1, CHUNKB ) + CALL DLACPY( 'Full', BL, N, C( I, 1 ), LDC, + $ DWORK( JWORK ), BL ) + CALL DGEMM( 'NoTranspose', 'Transpose', BL, N, N, ONE, + $ DWORK( JWORK ), BL, V, LDV, ZERO, C( I, 1 ), + $ LDC ) + 70 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. +C + DO 80 I = 1, M + CALL DCOPY( N, C( I, 1 ), LDC, DWORK( JWORK ), 1 ) + CALL DGEMV( 'NoTranspose', N, N, ONE, V, LDV, + $ DWORK( JWORK ), 1, ZERO, C( I, 1 ), LDC ) + 80 CONTINUE +C + END IF + END IF +C + DWORK( 1 ) = DBLE( MAXWRK ) +C + RETURN +C *** Last line of SB04PD *** + END diff --git a/mex/sources/libslicot/SB04PX.f b/mex/sources/libslicot/SB04PX.f new file mode 100644 index 000000000..99bd63d3b --- /dev/null +++ b/mex/sources/libslicot/SB04PX.f @@ -0,0 +1,468 @@ + SUBROUTINE SB04PX( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, + $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for the N1-by-N2 matrix X, 1 <= N1,N2 <= 2, in +C +C op(TL)*X*op(TR) + ISGN*X = SCALE*B, +C +C where TL is N1-by-N1, TR is N2-by-N2, B is N1-by-N2, and ISGN = 1 +C or -1. op(T) = T or T', where T' denotes the transpose of T. +C +C ARGUMENTS +C +C Mode Parameters +C +C LTRANL LOGICAL +C Specifies the form of op(TL) to be used, as follows: +C = .FALSE.: op(TL) = TL, +C = .TRUE. : op(TL) = TL'. +C +C LTRANR LOGICAL +C Specifies the form of op(TR) to be used, as follows: +C = .FALSE.: op(TR) = TR, +C = .TRUE. : op(TR) = TR'. +C +C ISGN INTEGER +C Specifies the sign of the equation as described before. +C ISGN may only be 1 or -1. +C +C Input/Output Parameters +C +C N1 (input) INTEGER +C The order of matrix TL. N1 may only be 0, 1 or 2. +C +C N2 (input) INTEGER +C The order of matrix TR. N2 may only be 0, 1 or 2. +C +C TL (input) DOUBLE PRECISION array, dimension (LDTL,N1) +C The leading N1-by-N1 part of this array must contain the +C matrix TL. +C +C LDTL INTEGER +C The leading dimension of array TL. LDTL >= MAX(1,N1). +C +C TR (input) DOUBLE PRECISION array, dimension (LDTR,N2) +C The leading N2-by-N2 part of this array must contain the +C matrix TR. +C +C LDTR INTEGER +C The leading dimension of array TR. LDTR >= MAX(1,N2). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N2) +C The leading N1-by-N2 part of this array must contain the +C right-hand side of the equation. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N1). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor. SCALE is chosen less than or equal to 1 +C to prevent the solution overflowing. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N2) +C The leading N1-by-N2 part of this array contains the +C solution of the equation. +C Note that X may be identified with B in the calling +C statement. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= MAX(1,N1). +C +C XNORM (output) DOUBLE PRECISION +C The infinity-norm of the solution. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if TL and -ISGN*TR have almost reciprocal +C eigenvalues, so TL or TR is perturbed to get a +C nonsingular equation. +C +C NOTE: In the interests of speed, this routine does not +C check the inputs for errors. +C +C METHOD +C +C The equivalent linear algebraic system of equations is formed and +C solved using Gaussian elimination with complete pivoting. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C The algorithm is stable and reliable, since Gaussian elimination +C with complete pivoting is used. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 2000. +C This is a modification and slightly more efficient version of +C SLICOT Library routine SB03MU. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Discrete-time system, Sylvester equation, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, HALF, EIGHT + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, + $ TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) +C .. +C .. Scalar Arguments .. + LOGICAL LTRANL, LTRANR + INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 + DOUBLE PRECISION SCALE, XNORM +C .. +C .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), + $ X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL BSWAP, XSWAP + INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K + DOUBLE PRECISION BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, + $ TEMP, U11, U12, U22, XMAX +C .. +C .. Local Arrays .. + LOGICAL BSWPIV( 4 ), XSWPIV( 4 ) + INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), + $ LOCU22( 4 ) + DOUBLE PRECISION BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 ) +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, IDAMAX +C .. +C .. External Subroutines .. + EXTERNAL DSWAP +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. +C .. Data statements .. + DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , + $ LOCU22 / 4, 3, 2, 1 / + DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. / + DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. / +C .. +C .. Executable Statements .. +C +C Do not check the input parameters for errors. +C + INFO = 0 + SCALE = ONE +C +C Quick return if possible. +C + IF( N1.EQ.0 .OR. N2.EQ.0 ) THEN + XNORM = ZERO + RETURN + END IF +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + SGN = ISGN +C + K = N1 + N1 + N2 - 2 + GO TO ( 10, 20, 30, 50 )K +C +C 1-by-1: TL11*X*TR11 + ISGN*X = B11. +C + 10 CONTINUE + TAU1 = TL( 1, 1 )*TR( 1, 1 ) + SGN + BET = ABS( TAU1 ) + IF( BET.LE.SMLNUM ) THEN + TAU1 = SMLNUM + BET = SMLNUM + INFO = 1 + END IF +C + GAM = ABS( B( 1, 1 ) ) + IF( SMLNUM*GAM.GT.BET ) + $ SCALE = ONE / GAM +C + X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 + XNORM = ABS( X( 1, 1 ) ) + RETURN +C +C 1-by-2: +C TL11*[X11 X12]*op[TR11 TR12] + ISGN*[X11 X12] = [B11 B12]. +C [TR21 TR22] +C + 20 CONTINUE +C + SMIN = MAX( MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), + $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) + $ *ABS( TL( 1, 1 ) )*EPS, + $ SMLNUM ) + TMP( 1 ) = TL( 1, 1 )*TR( 1, 1 ) + SGN + TMP( 4 ) = TL( 1, 1 )*TR( 2, 2 ) + SGN + IF( LTRANR ) THEN + TMP( 2 ) = TL( 1, 1 )*TR( 2, 1 ) + TMP( 3 ) = TL( 1, 1 )*TR( 1, 2 ) + ELSE + TMP( 2 ) = TL( 1, 1 )*TR( 1, 2 ) + TMP( 3 ) = TL( 1, 1 )*TR( 2, 1 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 1, 2 ) + GO TO 40 +C +C 2-by-1: +C op[TL11 TL12]*[X11]*TR11 + ISGN*[X11] = [B11]. +C [TL21 TL22] [X21] [X21] [B21] +C + 30 CONTINUE + SMIN = MAX( MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), + $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) + $ *ABS( TR( 1, 1 ) )*EPS, + $ SMLNUM ) + TMP( 1 ) = TL( 1, 1 )*TR( 1, 1 ) + SGN + TMP( 4 ) = TL( 2, 2 )*TR( 1, 1 ) + SGN + IF( LTRANL ) THEN + TMP( 2 ) = TL( 1, 2 )*TR( 1, 1 ) + TMP( 3 ) = TL( 2, 1 )*TR( 1, 1 ) + ELSE + TMP( 2 ) = TL( 2, 1 )*TR( 1, 1 ) + TMP( 3 ) = TL( 1, 2 )*TR( 1, 1 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 2, 1 ) + 40 CONTINUE +C +C Solve 2-by-2 system using complete pivoting. +C Set pivots less than SMIN to SMIN. +C + IPIV = IDAMAX( 4, TMP, 1 ) + U11 = TMP( IPIV ) + IF( ABS( U11 ).LE.SMIN ) THEN + INFO = 1 + U11 = SMIN + END IF + U12 = TMP( LOCU12( IPIV ) ) + L21 = TMP( LOCL21( IPIV ) ) / U11 + U22 = TMP( LOCU22( IPIV ) ) - U12*L21 + XSWAP = XSWPIV( IPIV ) + BSWAP = BSWPIV( IPIV ) + IF( ABS( U22 ).LE.SMIN ) THEN + INFO = 1 + U22 = SMIN + END IF + IF( BSWAP ) THEN + TEMP = BTMP( 2 ) + BTMP( 2 ) = BTMP( 1 ) - L21*TEMP + BTMP( 1 ) = TEMP + ELSE + BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 ) + END IF + IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. + $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN + SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + END IF + X2( 2 ) = BTMP( 2 ) / U22 + X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 ) + IF( XSWAP ) THEN + TEMP = X2( 2 ) + X2( 2 ) = X2( 1 ) + X2( 1 ) = TEMP + END IF + X( 1, 1 ) = X2( 1 ) + IF( N1.EQ.1 ) THEN + X( 1, 2 ) = X2( 2 ) + XNORM = ABS( X2( 1 ) ) + ABS( X2( 2 ) ) + ELSE + X( 2, 1 ) = X2( 2 ) + XNORM = MAX( ABS( X2( 1 ) ), ABS( X2( 2 ) ) ) + END IF + RETURN +C +C 2-by-2: +C op[TL11 TL12]*[X11 X12]*op[TR11 TR12] + ISGN*[X11 X12] = [B11 B12] +C [TL21 TL22] [X21 X22] [TR21 TR22] [X21 X22] [B21 B22] +C +C Solve equivalent 4-by-4 system using complete pivoting. +C Set pivots less than SMIN to SMIN. +C + 50 CONTINUE + SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), + $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) + SMIN = MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), + $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )*SMIN + SMIN = MAX( EPS*SMIN, SMLNUM ) + T16( 1, 1 ) = TL( 1, 1 )*TR( 1, 1 ) + SGN + T16( 2, 2 ) = TL( 2, 2 )*TR( 1, 1 ) + SGN + T16( 3, 3 ) = TL( 1, 1 )*TR( 2, 2 ) + SGN + T16( 4, 4 ) = TL( 2, 2 )*TR( 2, 2 ) + SGN + IF( LTRANL ) THEN + T16( 1, 2 ) = TL( 2, 1 )*TR( 1, 1 ) + T16( 2, 1 ) = TL( 1, 2 )*TR( 1, 1 ) + T16( 3, 4 ) = TL( 2, 1 )*TR( 2, 2 ) + T16( 4, 3 ) = TL( 1, 2 )*TR( 2, 2 ) + ELSE + T16( 1, 2 ) = TL( 1, 2 )*TR( 1, 1 ) + T16( 2, 1 ) = TL( 2, 1 )*TR( 1, 1 ) + T16( 3, 4 ) = TL( 1, 2 )*TR( 2, 2 ) + T16( 4, 3 ) = TL( 2, 1 )*TR( 2, 2 ) + END IF + IF( LTRANR ) THEN + T16( 1, 3 ) = TL( 1, 1 )*TR( 1, 2 ) + T16( 2, 4 ) = TL( 2, 2 )*TR( 1, 2 ) + T16( 3, 1 ) = TL( 1, 1 )*TR( 2, 1 ) + T16( 4, 2 ) = TL( 2, 2 )*TR( 2, 1 ) + ELSE + T16( 1, 3 ) = TL( 1, 1 )*TR( 2, 1 ) + T16( 2, 4 ) = TL( 2, 2 )*TR( 2, 1 ) + T16( 3, 1 ) = TL( 1, 1 )*TR( 1, 2 ) + T16( 4, 2 ) = TL( 2, 2 )*TR( 1, 2 ) + END IF + IF( LTRANL .AND. LTRANR ) THEN + T16( 1, 4 ) = TL( 2, 1 )*TR( 1, 2 ) + T16( 2, 3 ) = TL( 1, 2 )*TR( 1, 2 ) + T16( 3, 2 ) = TL( 2, 1 )*TR( 2, 1 ) + T16( 4, 1 ) = TL( 1, 2 )*TR( 2, 1 ) + ELSE IF( LTRANL .AND. .NOT.LTRANR ) THEN + T16( 1, 4 ) = TL( 2, 1 )*TR( 2, 1 ) + T16( 2, 3 ) = TL( 1, 2 )*TR( 2, 1 ) + T16( 3, 2 ) = TL( 2, 1 )*TR( 1, 2 ) + T16( 4, 1 ) = TL( 1, 2 )*TR( 1, 2 ) + ELSE IF( .NOT.LTRANL .AND. LTRANR ) THEN + T16( 1, 4 ) = TL( 1, 2 )*TR( 1, 2 ) + T16( 2, 3 ) = TL( 2, 1 )*TR( 1, 2 ) + T16( 3, 2 ) = TL( 1, 2 )*TR( 2, 1 ) + T16( 4, 1 ) = TL( 2, 1 )*TR( 2, 1 ) + ELSE + T16( 1, 4 ) = TL( 1, 2 )*TR( 2, 1 ) + T16( 2, 3 ) = TL( 2, 1 )*TR( 2, 1 ) + T16( 3, 2 ) = TL( 1, 2 )*TR( 1, 2 ) + T16( 4, 1 ) = TL( 2, 1 )*TR( 1, 2 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 2, 1 ) + BTMP( 3 ) = B( 1, 2 ) + BTMP( 4 ) = B( 2, 2 ) +C +C Perform elimination. +C + DO 100 I = 1, 3 + XMAX = ZERO +C + DO 70 IP = I, 4 +C + DO 60 JP = I, 4 + IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN + XMAX = ABS( T16( IP, JP ) ) + IPSV = IP + JPSV = JP + END IF + 60 CONTINUE +C + 70 CONTINUE +C + IF( IPSV.NE.I ) THEN + CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 ) + TEMP = BTMP( I ) + BTMP( I ) = BTMP( IPSV ) + BTMP( IPSV ) = TEMP + END IF + IF( JPSV.NE.I ) + $ CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 ) + JPIV( I ) = JPSV + IF( ABS( T16( I, I ) ).LT.SMIN ) THEN + INFO = 1 + T16( I, I ) = SMIN + END IF +C + DO 90 J = I + 1, 4 + T16( J, I ) = T16( J, I ) / T16( I, I ) + BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) +C + DO 80 K = I + 1, 4 + T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) + 80 CONTINUE +C + 90 CONTINUE +C + 100 CONTINUE +C + IF( ABS( T16( 4, 4 ) ).LT.SMIN ) + $ T16( 4, 4 ) = SMIN + IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN + SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), + $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), + $ ABS( BTMP( 4 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + BTMP( 3 ) = BTMP( 3 )*SCALE + BTMP( 4 ) = BTMP( 4 )*SCALE + END IF +C + DO 120 I = 1, 4 + K = 5 - I + TEMP = ONE / T16( K, K ) + TMP( K ) = BTMP( K )*TEMP +C + DO 110 J = K + 1, 4 + TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) + 110 CONTINUE +C + 120 CONTINUE +C + DO 130 I = 1, 3 + IF( JPIV( 4-I ).NE.4-I ) THEN + TEMP = TMP( 4-I ) + TMP( 4-I ) = TMP( JPIV( 4-I ) ) + TMP( JPIV( 4-I ) ) = TEMP + END IF + 130 CONTINUE +C + X( 1, 1 ) = TMP( 1 ) + X( 2, 1 ) = TMP( 2 ) + X( 1, 2 ) = TMP( 3 ) + X( 2, 2 ) = TMP( 4 ) + XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 3 ) ), + $ ABS( TMP( 2 ) ) + ABS( TMP( 4 ) ) ) +C + RETURN +C *** Last line of SB04PX *** + END diff --git a/mex/sources/libslicot/SB04PY.f b/mex/sources/libslicot/SB04PY.f new file mode 100644 index 000000000..46b81f880 --- /dev/null +++ b/mex/sources/libslicot/SB04PY.f @@ -0,0 +1,1111 @@ + SUBROUTINE SB04PY( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, + $ LDC, SCALE, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X the discrete-time Sylvester equation +C +C op(A)*X*op(B) + ISGN*X = scale*C, +C +C where op(A) = A or A**T, A and B are both upper quasi-triangular, +C and ISGN = 1 or -1. A is M-by-M and B is N-by-N; the right hand +C side C and the solution X are M-by-N; and scale is an output scale +C factor, set less than or equal to 1 to avoid overflow in X. The +C solution matrix X is overwritten onto C. +C +C A and B must be in Schur canonical form (as returned by LAPACK +C Library routine DHSEQR), that is, block upper triangular with +C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has +C its diagonal elements equal and its off-diagonal elements of +C opposite sign. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C TRANB CHARACTER*1 +C Specifies the form of op(B) to be used, as follows: +C = 'N': op(B) = B (No transpose); +C = 'T': op(B) = B**T (Transpose); +C = 'C': op(B) = B**T (Conjugate transpose = Transpose). +C +C ISGN INTEGER +C Specifies the sign of the equation as described before. +C ISGN may only be 1 or -1. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A, and the number of rows in the +C matrices X and C. M >= 0. +C +C N (input) INTEGER +C The order of the matrix B, and the number of columns in +C the matrices X and C. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain the +C upper quasi-triangular matrix A, in Schur canonical form. +C The part of A below the first sub-diagonal is not +C referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain the +C upper quasi-triangular matrix B, in Schur canonical form. +C The part of B below the first sub-diagonal is not +C referenced. +C +C LDB (input) INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the right hand side matrix C. +C On exit, if INFO >= 0, the leading M-by-N part of this +C array contains the solution matrix X. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (2*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: A and -ISGN*B have almost reciprocal eigenvalues; +C perturbed values were used to solve the equation +C (but the matrices A and B are unchanged). +C +C METHOD +C +C The solution matrix X is computed column-wise via a back +C substitution scheme, an extension and refinement of the algorithm +C in [1], similar to that used in [2] for continuous-time Sylvester +C equations. A set of equivalent linear algebraic systems of +C equations of order at most four are formed and solved using +C Gaussian elimination with complete pivoting. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C The algorithm is stable and reliable, since Gaussian elimination +C with complete pivoting is used. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2000. +C D. Sima, University of Bucharest, April 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C Partly based on the routine SYLSV, A. Varga, 1992. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Discrete-time system, matrix algebra, Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER TRANA, TRANB + INTEGER INFO, ISGN, LDA, LDB, LDC, M, N + DOUBLE PRECISION SCALE +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ) +C .. +C .. Local Scalars .. + LOGICAL NOTRNA, NOTRNB + INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT, + $ MNK1, MNK2, MNL1, MNL2 + DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, P11, P12, P21, P22, + $ SCALOC, SGN, SMIN, SMLNUM, SUMR, XNORM +C .. +C .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT, DLAMCH, DLANGE + EXTERNAL DDOT, DLAMCH, DLANGE, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DLABAD, DLALN2, DSCAL, SB04PX, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters +C + NOTRNA = LSAME( TRANA, 'N' ) + NOTRNB = LSAME( TRANB, 'N' ) +C + INFO = 0 + IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. + $ .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. + $ .NOT.LSAME( TRANB, 'C' ) ) THEN + INFO = -2 + ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB04PY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + SCALE = ONE + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'Precision' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM*DBLE( M*N ) / EPS + BIGNUM = ONE / SMLNUM +C + SMIN = MAX( SMLNUM, EPS*DLANGE( 'M', M, M, A, LDA, DUM ), + $ EPS*DLANGE( 'M', N, N, B, LDB, DUM ) ) +C + SGN = ISGN +C + IF( NOTRNA .AND. NOTRNB ) THEN +C +C Solve A*X*B + ISGN*X = scale*C. +C +C The (K,L)th block of X is determined starting from +C bottom-left corner column by column by +C +C A(K,K)*X(K,L)*B(L,L) + ISGN*X(K,L) = C(K,L) - R(K,L) +C +C where +C M +C R(K,L) = { SUM [A(K,J)*X(J,L)] } * B(L,L) + +C J=K+1 +C M L-1 +C SUM { A(K,J) * SUM [X(J,I)*B(I,L)] }. +C J=K I=1 +C +C Start column loop (index = L) +C L1 (L2) : column index of the first (last) row of X(K,L). +C + LNEXT = 1 +C + DO 60 L = 1, N + IF( L.LT.LNEXT ) + $ GO TO 60 + L1 = L + IF( L.EQ.N ) THEN + L2 = L + ELSE + IF( B( L+1, L ).NE.ZERO ) THEN + L2 = L + 1 + ELSE + L2 = L + END IF + LNEXT = L2 + 1 + END IF +C +C Start row loop (index = K) +C K1 (K2): row index of the first (last) row of X(K,L). +C + KNEXT = M +C + DO 50 K = M, 1, -1 + IF( K.GT.KNEXT ) + $ GO TO 50 + K2 = K + IF( K.EQ.1 ) THEN + K1 = K + ELSE + IF( A( K, K-1 ).NE.ZERO ) THEN + K1 = K - 1 + ELSE + K1 = K + END IF + KNEXT = K1 - 1 + END IF +C + MNK1 = MIN( K1+1, M ) + MNK2 = MIN( K2+1, M ) + P11 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L1 ), 1 ) + DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), + $ 1 ) +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN +C + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) + SCALOC = ONE +C + A11 = A( K1, K1 )*B( L1, L1 ) + SGN + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 10 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 10 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), + $ 1 ) + DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), + $ 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, B( L1, L1 ), + $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 20 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 20 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + P12 = DDOT( M-K1, A( K1, MNK1 ), LDA, C( MNK1, L2 ), + $ 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L2, L1 ) ) +C + DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ B( 1, L2 ), 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + + $ P12*B( L2, L2 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ), + $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 30 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 30 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), + $ 1 ) + P12 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L2 ), + $ 1 ) + P22 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L2 ), + $ 1 ) +C + DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), + $ 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L2, L1 ) ) +C + DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ B( 1, L2 ), 1 ) + DWORK( K2+M ) = DDOT( L1-1, C( K2, 1 ), LDC, + $ B( 1, L2 ), 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + + $ P12*B( L2, L2 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + + $ P22*B( L2, L1 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L1, L2 ) + + $ P22*B( L2, L2 ) ) +C + CALL SB04PX( .FALSE., .FALSE., ISGN, 2, 2, + $ A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC, + $ 2, SCALOC, X, 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 40 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 40 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + END IF +C + 50 CONTINUE +C + 60 CONTINUE +C + ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN +C +C Solve A'*X*B + ISGN*X = scale*C. +C +C The (K,L)th block of X is determined starting from +C upper-left corner column by column by +C +C A(K,K)'*X(K,L)*B(L,L) + ISGN*X(K,L) = C(K,L) - R(K,L) +C +C where +C K-1 +C R(K,L) = { SUM [A(J,K)'*X(J,L)] } * B(L,L) + +C J=1 +C K L-1 +C SUM A(J,K)' * { SUM [X(J,I)*B(I,L)] }. +C J=1 I=1 +C +C Start column loop (index = L) +C L1 (L2): column index of the first (last) row of X(K,L). +C + LNEXT = 1 +C + DO 120 L = 1, N + IF( L.LT.LNEXT ) + $ GO TO 120 + L1 = L + IF( L.EQ.N ) THEN + L2 = L + ELSE + IF( B( L+1, L ).NE.ZERO ) THEN + L2 = L + 1 + ELSE + L2 = L + END IF + LNEXT = L2 + 1 + END IF +C +C Start row loop (index = K) +C K1 (K2): row index of the first (last) row of X(K,L). +C + KNEXT = 1 +C + DO 110 K = 1, M + IF( K.LT.KNEXT ) + $ GO TO 110 + K1 = K + IF( K.EQ.M ) THEN + K2 = K + ELSE + IF( A( K+1, K ).NE.ZERO ) THEN + K2 = K + 1 + ELSE + K2 = K + END IF + KNEXT = K2 + 1 + END IF +C + P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1), + $ 1 ) +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN +C + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) + SCALOC = ONE +C + A11 = A( K1, K1 )*B( L1, L1 ) + SGN + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 70 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 70 CONTINUE +C + CALL DSCAL( K1, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, + $ B( 1, L1), 1 ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, B( L1, L1 ), + $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 80 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 80 CONTINUE +C + CALL DSCAL( K2, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L2, L1 ) ) +C + DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ B( 1, L2 ), 1 ) + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) + VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + + $ P12*B( L2, L2 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ), + $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 90 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 90 CONTINUE +C + CALL DSCAL( K1, SCALOC, DWORK, 1 ) + CALL DSCAL( K1, SCALOC, DWORK( M+1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) +C + DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, + $ B( 1, L1), 1 ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L2, L1 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + + $ P22*B( L2, L1 ) ) +C + DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ B( 1, L2 ), 1 ) + DWORK( K2+M ) = DDOT( L1-1, C( K2, 1 ), LDC, + $ B( 1, L2 ), 1 ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + + $ P12*B( L2, L2 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK( M+1 ), 1 ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L1, L2 ) + + $ P22*B( L2, L2 ) ) +C + CALL SB04PX( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ), + $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, + $ 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 100 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 100 CONTINUE +C + CALL DSCAL( K2, SCALOC, DWORK, 1 ) + CALL DSCAL( K2, SCALOC, DWORK( M+1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + END IF +C + 110 CONTINUE +C + 120 CONTINUE +C + ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN +C +C Solve A'*X*B' + ISGN*X = scale*C. +C +C The (K,L)th block of X is determined starting from +C top-right corner column by column by +C +C A(K,K)'*X(K,L)*B(L,L)' + ISGN*X(K,L) = C(K,L) - R(K,L) +C +C where +C K-1 +C R(K,L) = { SUM [A(J,K)'*X(J,L)] } * B(L,L)' + +C J=1 +C K N +C SUM A(J,K)' * { SUM [X(J,I)*B(L,I)'] }. +C J=1 I=L+1 +C +C Start column loop (index = L) +C L1 (L2): column index of the first (last) row of X(K,L). +C + LNEXT = N +C + DO 180 L = N, 1, -1 + IF( L.GT.LNEXT ) + $ GO TO 180 + L2 = L + IF( L.EQ.1 ) THEN + L1 = L + ELSE + IF( B( L, L-1 ).NE.ZERO ) THEN + L1 = L - 1 + ELSE + L1 = L + END IF + LNEXT = L1 - 1 + END IF +C +C Start row loop (index = K) +C K1 (K2): row index of the first (last) row of X(K,L). +C + KNEXT = 1 +C + DO 170 K = 1, M + IF( K.LT.KNEXT ) + $ GO TO 170 + K1 = K + IF( K.EQ.M ) THEN + K2 = K + ELSE + IF( A( K+1, K ).NE.ZERO ) THEN + K2 = K + 1 + ELSE + K2 = K + END IF + KNEXT = K2 + 1 + END IF +C + MNL1 = MIN( L1+1, N ) + MNL2 = MIN( L2+1, N ) + P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + DWORK( K1 ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L1, MNL2 ), LDB ) +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) + SCALOC = ONE +C + A11 = A( K1, K1 )*B( L1, L1 ) + SGN + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 130 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 130 CONTINUE +C + CALL DSCAL( K1, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + DWORK( K2 ) = DDOT( N-L1, C( K2, MNL1 ), LDC, + $ B( L1, MNL1 ), LDB ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, B( L1, L1 ), + $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 140 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 140 CONTINUE +C + CALL DSCAL( K2, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L1, L2 ) ) +C + DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) + VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + + $ P12*B( L2, L2 ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ), + $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 150 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 150 CONTINUE +C + CALL DSCAL( K1, SCALOC, DWORK, 1 ) + CALL DSCAL( K1, SCALOC, DWORK(M+1), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) +C + DWORK( K2 ) = DDOT( N-L2, C( K2, MNL2 ), LDC, + $ B( L1, MNL2 ), LDB ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L1, L2 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + + $ P22*B( L1, L2 ) ) +C + DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + DWORK( K2+M ) = DDOT( N-L2, C( K2, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + + $ P12*B( L2, L2 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK( M+1 ), 1 ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L2, L1 ) + + $ P22*B( L2, L2 ) ) +C + CALL SB04PX( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ), + $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, + $ 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 160 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 160 CONTINUE +C + CALL DSCAL( K2, SCALOC, DWORK, 1 ) + CALL DSCAL( K2, SCALOC, DWORK(M+1), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + END IF +C + 170 CONTINUE +C + 180 CONTINUE +C + ELSE +C +C Solve A*X*B' + ISGN*X = scale*C. +C +C The (K,L)th block of X is determined starting from +C bottom-right corner column by column by +C +C A(K,K)*X(K,L)*B(L,L)' + ISGN*X(K,L) = C(K,L) - R(K,L) +C +C where +C M +C R(K,L) = { SUM [A(K,J)*X(J,L)] } * B(L,L)' + +C J=K+1 +C M N +C SUM { A(K,J) * SUM [X(J,I)*B(L,I)'] }. +C J=K I=L+1 +C +C Start column loop (index = L) +C L1 (L2): column index of the first (last) row of X(K,L). +C + LNEXT = N +C + DO 240 L = N, 1, -1 + IF( L.GT.LNEXT ) + $ GO TO 240 + L2 = L + IF( L.EQ.1 ) THEN + L1 = L + ELSE + IF( B( L, L-1 ).NE.ZERO ) THEN + L1 = L - 1 + ELSE + L1 = L + END IF + LNEXT = L1 - 1 + END IF +C +C Start row loop (index = K) +C K1 (K2): row index of the first (last) row of X(K,L). +C + KNEXT = M +C + DO 230 K = M, 1, -1 + IF( K.GT.KNEXT ) + $ GO TO 230 + K2 = K + IF( K.EQ.1 ) THEN + K1 = K + ELSE + IF( A( K, K-1 ).NE.ZERO ) THEN + K1 = K - 1 + ELSE + K1 = K + END IF + KNEXT = K1 - 1 + END IF +C + MNK1 = MIN( K1+1, M ) + MNK2 = MIN( K2+1, M ) + MNL1 = MIN( L1+1, N ) + MNL2 = MIN( L2+1, N ) + P11 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L1 ), 1 ) + DWORK( K1 ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L1, MNL2 ), LDB ) +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN +C + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) + SCALOC = ONE +C + A11 = A( K1, K1 )*B( L1, L1 ) + SGN + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 190 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 190 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), + $ 1 ) + DWORK( K2 ) = DDOT( N-L1, C( K2, MNL1 ), LDC, + $ B( L1, MNL1 ), LDB ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, B( L1, L1 ), + $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 200 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 200 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + P12 = DDOT( M-K1, A( K1, MNK1 ), LDA, C( MNK1, L2 ), + $ 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L1, L2 ) ) +C + DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + + $ P12*B( L2, L2 ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ), + $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 210 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 210 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), + $ 1 ) + P12 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L2 ), + $ 1 ) + P22 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L2 ), + $ 1 ) +C + DWORK( K2 ) = DDOT( N-L2, C( K2, MNL2 ), LDC, + $ B( L1, MNL2 ), LDB ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L1, L2 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + + $ P22*B( L1, L2 ) ) +C + DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + DWORK( K2+M ) = DDOT( N-L2, C( K2, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + + $ P12*B( L2, L2 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L2, L1 ) + + $ P22*B( L2, L2 ) ) +C + CALL SB04PX( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ), + $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, + $ 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 220 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 220 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + END IF +C + 230 CONTINUE +C + 240 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB04PY *** + END diff --git a/mex/sources/libslicot/SB04QD.f b/mex/sources/libslicot/SB04QD.f new file mode 100644 index 000000000..29ceae423 --- /dev/null +++ b/mex/sources/libslicot/SB04QD.f @@ -0,0 +1,376 @@ + SUBROUTINE SB04QD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X the discrete-time Sylvester equation +C +C X + AXB = C, +C +C where A, B, C and X are general N-by-N, M-by-M, N-by-M and +C N-by-M matrices respectively. A Hessenberg-Schur method, which +C reduces A to upper Hessenberg form, H = U'AU, and B' to real +C Schur form, S = Z'B'Z (with U, Z orthogonal matrices), is used. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the coefficient matrix A of the equation. +C On exit, the leading N-by-N upper Hessenberg part of this +C array contains the matrix H, and the remainder of the +C leading N-by-N part, together with the elements 2,3,...,N +C of array DWORK, contain the orthogonal transformation +C matrix U (stored in factored form). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading M-by-M part of this array must +C contain the coefficient matrix B of the equation. +C On exit, the leading M-by-M part of this array contains +C the quasi-triangular Schur factor S of the matrix B'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading N-by-M part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading N-by-M part of this array contains +C the solution matrix X of the problem. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,M) +C The leading M-by-M part of this array contains the +C orthogonal matrix Z used to transform B' to real upper +C Schur form. +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= MAX(1,M). +C +C Workspace +C +C IWORK INTEGER array, dimension (4*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2), DWORK(3),..., DWORK(N) contain +C the scalar factors of the elementary reflectors used to +C reduce A to upper Hessenberg form, as returned by LAPACK +C Library routine DGEHRD. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = MAX(1, 2*N*N + 9*N, 5*M, N + M). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, 1 <= i <= M, the QR algorithm failed to +C compute all the eigenvalues of B (see LAPACK Library +C routine DGEES); +C > M: if a singular matrix was encountered whilst solving +C for the (INFO-M)-th column of matrix X. +C +C METHOD +C +C The matrix A is transformed to upper Hessenberg form H = U'AU by +C the orthogonal transformation matrix U; matrix B' is transformed +C to real upper Schur form S = Z'B'Z using the orthogonal +C transformation matrix Z. The matrix C is also multiplied by the +C transformations, F = U'CZ, and the solution matrix Y of the +C transformed system +C +C Y + HYS' = F +C +C is computed by back substitution. Finally, the matrix Y is then +C multiplied by the orthogonal transformation matrices, X = UYZ', in +C order to obtain the solution matrix X to the original problem. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C [2] Sima, V. +C Algorithms for Linear-quadratic Optimization. +C Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C 3 3 2 2 +C The algorithm requires about (5/3) N + 10 M + 5 N M + 2.5 M N +C operations and is backward stable. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000, Aug. 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2000. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER BL, CHUNK, I, IEIG, IFAIL, IHI, ILO, IND, ITAU, + $ JWORK, SDIM, WRKOPT +C .. Local Scalars .. + LOGICAL BLAS3, BLOCK +C .. Local Arrays .. + LOGICAL BWORK(1) +C .. External Functions .. + LOGICAL SELECT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEHRD, DGEMM, DGEMV, DLACPY, + $ DORMHR, DSWAP, SB04QU, SB04QY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDZ.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDWORK.LT.MAX( 1, 2*N*N + 9*N, 5*M, N + M ) ) THEN + INFO = -13 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB04QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + ILO = 1 + IHI = N + WRKOPT = 2*N*N + 9*N +C +C Step 1 : Reduce A to upper Hessenberg and B' to quasi-upper +C triangular. That is, H = U' * A * U (store U in factored +C form) and S = Z' * B' * Z (save Z). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + DO 20 I = 2, M + CALL DSWAP( I-1, B(1,I), 1, B(I,1), LDB ) + 20 CONTINUE +C +C Workspace: need 5*M; +C prefer larger. +C + IEIG = M + 1 + JWORK = IEIG + M + CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, B, LDB, + $ SDIM, DWORK, DWORK(IEIG), Z, LDZ, DWORK(JWORK), + $ LDWORK-JWORK+1, BWORK, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Workspace: need 2*N; +C prefer N + N*NB. +C + ITAU = 2 + JWORK = ITAU + N - 1 + CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Step 2 : Form F = ( U' * C ) * Z. Use BLAS 3, if enough space. +C +C Workspace: need N + M; +C prefer N + M*NB. +C + CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ IFAIL ) + WRKOPT = MAX( WRKOPT, MAX( INT( DWORK(JWORK) ), N*M )+JWORK-1 ) +C + CHUNK = ( LDWORK - JWORK + 1 ) / M + BLOCK = MIN( CHUNK, N ).GT.1 + BLAS3 = CHUNK.GE.N .AND. BLOCK +C + IF ( BLAS3 ) THEN + CALL DGEMM( 'No transpose', 'No transpose', N, M, M, ONE, C, + $ LDC, Z, LDZ, ZERO, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) +C + ELSE IF ( BLOCK ) THEN +C +C Use as many rows of C as possible. +C + DO 40 I = 1, N, CHUNK + BL = MIN( N-I+1, CHUNK ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, M, M, ONE, + $ C(I,1), LDC, Z, LDZ, ZERO, DWORK(JWORK), BL ) + CALL DLACPY( 'Full', BL, M, DWORK(JWORK), BL, C(I,1), LDC ) + 40 CONTINUE +C + ELSE +C + DO 60 I = 1, N + CALL DGEMV( 'Transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, + $ ZERO, DWORK(JWORK), 1 ) + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + 60 CONTINUE +C + END IF +C +C Step 3 : Solve Y + H * Y * S' = F for Y. +C + IND = M + 80 CONTINUE +C + IF ( IND.GT.1 ) THEN + IF ( B(IND,IND-1).EQ.ZERO ) THEN +C +C Solve a special linear algebraic system of order N. +C Workspace: N*(N+1)/2 + 3*N. +C + CALL SB04QY( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + IND = IND - 1 + ELSE +C +C Solve a special linear algebraic system of order 2*N. +C Workspace: 2*N*N + 9*N; +C + CALL SB04QU( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + IND = IND - 2 + END IF + GO TO 80 + ELSE IF ( IND.EQ.1 ) THEN +C +C Solve a special linear algebraic system of order N. +C Workspace: N*(N+1)/2 + 3*N; +C + CALL SB04QY( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + END IF +C +C Step 4 : Form C = ( U * Y ) * Z'. Use BLAS 3, if enough space. +C +C Workspace: need N + M; +C prefer N + M*NB. +C + CALL DORMHR( 'Left', 'No transpose', N, M, ILO, IHI, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( BLAS3 ) THEN + CALL DGEMM( 'No transpose', 'Transpose', N, M, M, ONE, C, LDC, + $ Z, LDZ, ZERO, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) +C + ELSE IF ( BLOCK ) THEN +C +C Use as many rows of C as possible. +C + DO 100 I = 1, N, CHUNK + BL = MIN( N-I+1, CHUNK ) + CALL DGEMM( 'NoTranspose', 'Transpose', BL, M, M, ONE, + $ C(I,1), LDC, Z, LDZ, ZERO, DWORK(JWORK), BL ) + CALL DLACPY( 'Full', BL, M, DWORK(JWORK), BL, C(I,1), LDC ) + 100 CONTINUE +C + ELSE +C + DO 120 I = 1, N + CALL DGEMV( 'No transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, + $ ZERO, DWORK(JWORK), 1 ) + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + 120 CONTINUE + END IF +C + RETURN +C *** Last line of SB04QD *** + END diff --git a/mex/sources/libslicot/SB04QR.f b/mex/sources/libslicot/SB04QR.f new file mode 100644 index 000000000..77231d322 --- /dev/null +++ b/mex/sources/libslicot/SB04QR.f @@ -0,0 +1,224 @@ + SUBROUTINE SB04QR( M, D, IPR, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a linear algebraic system of order M whose coefficient +C matrix has zeros below the third subdiagonal and zero elements on +C the third subdiagonal with even column indices. The matrix is +C stored compactly, row-wise. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the system. M >= 0, M even. +C Note that parameter M should have twice the value in the +C original problem (see SLICOT Library routine SB04QU). +C +C D (input/output) DOUBLE PRECISION array, dimension +C (M*M/2+4*M) +C On entry, the first M*M/2 + 3*M elements of this array +C must contain the coefficient matrix, stored compactly, +C row-wise, and the next M elements must contain the right +C hand side of the linear system, as set by SLICOT Library +C routine SB04QU. +C On exit, the content of this array is updated, the last M +C elements containing the solution with components +C interchanged (see IPR). +C +C IPR (output) INTEGER array, dimension (2*M) +C The leading M elements contain information about the +C row interchanges performed for solving the system. +C Specifically, the i-th component of the solution is +C specified by IPR(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if a singular matrix was encountered. +C +C METHOD +C +C Gaussian elimination with partial pivoting is used. The rows of +C the matrix are not actually permuted, only their indices are +C interchanged in array IPR. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C [2] Sima, V. +C Algorithms for Linear-quadratic Optimization. +C Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, M +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION D(*) +C .. Local Scalars .. + INTEGER I, I1, I2, IPRM, IPRM1, J, K, L, M1, MPI, MPI1, + $ MPI2 + DOUBLE PRECISION D1, D2, D3, DMAX +C .. External Subroutines .. + EXTERNAL DAXPY +C .. Intrinsic Functions .. + INTRINSIC ABS, MOD +C .. Executable Statements .. +C + INFO = 0 + I2 = M*M/2 + 3*M + MPI = M + IPRM = I2 + M1 = M + I1 = 1 +C + DO 20 I = 1, M + MPI = MPI + 1 + IPRM = IPRM + 1 + IPR(MPI) = I1 + IPR(I) = IPRM + I1 = I1 + M1 + IF ( I.GE.4 .AND. MOD( I, 2 ).EQ.0 ) M1 = M1 - 2 + 20 CONTINUE +C + M1 = M - 1 + MPI1 = M + 1 +C +C Reduce to upper triangular form. +C + DO 80 I = 1, M1 + MPI = MPI1 + MPI1 = MPI1 + 1 + IPRM = IPR(MPI) + D1 = D(IPRM) + I1 = 3 + IF ( MOD( I, 2 ).EQ.0 ) I1 = 2 + IF ( I.EQ.M1 ) I1 = 1 + MPI2 = MPI + I1 + L = 0 + DMAX = ABS( D1 ) +C + DO 40 J = MPI1, MPI2 + D2 = D(IPR(J)) + D3 = ABS( D2 ) + IF ( D3.GT.DMAX ) THEN + DMAX = D3 + D1 = D2 + L = J - MPI + END IF + 40 CONTINUE +C +C Check singularity. +C + IF ( DMAX.EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C + IF ( L.GT.0 ) THEN +C +C Permute the row indices. +C + K = IPRM + J = MPI + L + IPRM = IPR(J) + IPR(J) = K + IPR(MPI) = IPRM + K = IPR(I) + I2 = I + L + IPR(I) = IPR(I2) + IPR(I2) = K + END IF + IPRM = IPRM + 1 +C +C Annihilate the subdiagonal elements of the matrix. +C + I2 = I + D3 = D(IPR(I)) +C + DO 60 J = MPI1, MPI2 + I2 = I2 + 1 + IPRM1 = IPR(J) + DMAX = -D(IPRM1)/D1 + D(IPR(I2)) = D(IPR(I2)) + DMAX*D3 + CALL DAXPY( M-I, DMAX, D(IPRM), 1, D(IPRM1+1), 1 ) + IPR(J) = IPR(J) + 1 + 60 CONTINUE +C + 80 CONTINUE +C + MPI = M + M + IPRM = IPR(MPI) +C +C Check singularity. +C + IF ( D(IPRM).EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C +C Back substitution. +C + D(IPR(M)) = D(IPR(M))/D(IPRM) +C + DO 120 I = M1, 1, -1 + MPI = MPI - 1 + IPRM = IPR(MPI) + IPRM1 = IPRM + DMAX = ZERO +C + DO 100 K = I+1, M + IPRM1 = IPRM1 + 1 + DMAX = DMAX + D(IPR(K))*D(IPRM1) + 100 CONTINUE +C + D(IPR(I)) = ( D(IPR(I)) - DMAX )/D(IPRM) + 120 CONTINUE +C + RETURN +C *** Last line of SB04QR *** + END diff --git a/mex/sources/libslicot/SB04QU.f b/mex/sources/libslicot/SB04QU.f new file mode 100644 index 000000000..2a53f1e3b --- /dev/null +++ b/mex/sources/libslicot/SB04QU.f @@ -0,0 +1,218 @@ + SUBROUTINE SB04QU( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct and solve a linear algebraic system of order 2*M +C whose coefficient matrix has zeros below the third subdiagonal, +C and zero elements on the third subdiagonal with even column +C indices. Such systems appear when solving discrete-time Sylvester +C equations using the Hessenberg-Schur method. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix B. N >= 0. +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C IND (input) INTEGER +C IND and IND - 1 specify the indices of the columns in C +C to be computed. IND > 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain an +C upper Hessenberg matrix. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain a +C matrix in real Schur form. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading M-by-N part of this array contains +C the matrix C with columns IND-1 and IND updated. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Workspace +C +C D DOUBLE PRECISION array, dimension (2*M*M+8*M) +C +C IPR INTEGER array, dimension (4*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C > 0: if INFO = IND, a singular matrix was encountered. +C +C METHOD +C +C A special linear algebraic system of order 2*M, whose coefficient +C matrix has zeros below the third subdiagonal and zero elements on +C the third subdiagonal with even column indices, is constructed and +C solved. The coefficient matrix is stored compactly, row-wise. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C [2] Sima, V. +C Algorithms for Linear-quadratic Optimization. +C Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, IND, LDA, LDB, LDC, M, N +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) +C .. Local Scalars .. + INTEGER I, I2, IND1, J, K, K1, K2, M2 + DOUBLE PRECISION TEMP +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DTRMV, SB04QR +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + IND1 = IND - 1 +C + IF ( IND.LT.N ) THEN + DUM(1) = ZERO + CALL DCOPY ( M, DUM, 0, D, 1 ) + DO 10 I = IND + 1, N + CALL DAXPY ( M, B(IND1,I), C(1,I), 1, D, 1 ) + 10 CONTINUE +C + DO 20 I = 2, M + C(I,IND1) = C(I,IND1) - A(I,I-1)*D(I-1) + 20 CONTINUE + CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, + $ D, 1 ) + DO 30 I = 1, M + C(I,IND1) = C(I,IND1) - D(I) + 30 CONTINUE +C + CALL DCOPY ( M, DUM, 0, D, 1 ) + DO 40 I = IND + 1, N + CALL DAXPY ( M, B(IND,I), C(1,I), 1, D, 1 ) + 40 CONTINUE +C + DO 50 I = 2, M + C(I,IND) = C(I,IND) - A(I,I-1)*D(I-1) + 50 CONTINUE + CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, + $ D, 1 ) + DO 60 I = 1, M + C(I,IND) = C(I,IND) - D(I) + 60 CONTINUE + END IF +C +C Construct the linear algebraic system of order 2*M. +C + K1 = -1 + M2 = 2*M + I2 = M2*(M + 3) + K = M2 +C + DO 80 I = 1, M +C + DO 70 J = MAX( 1, I - 1 ), M + K1 = K1 + 2 + K2 = K1 + K + TEMP = A(I,J) + D(K1) = TEMP * B(IND1,IND1) + D(K1+1) = TEMP * B(IND1,IND) + D(K2) = TEMP * B(IND,IND1) + D(K2+1) = TEMP * B(IND,IND) + IF ( I.EQ.J ) THEN + D(K1) = D(K1) + ONE + D(K2+1) = D(K2+1) + ONE + END IF + 70 CONTINUE +C + K1 = K2 + IF ( I.GT.1 ) K = K - 2 +C +C Store the right hand side. +C + I2 = I2 + 2 + D(I2) = C(I,IND) + D(I2-1) = C(I,IND1) + 80 CONTINUE +C +C Solve the linear algebraic system and store the solution in C. +C + CALL SB04QR( M2, D, IPR, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = IND + ELSE + I2 = 0 +C + DO 90 I = 1, M + I2 = I2 + 2 + C(I,IND1) = D(IPR(I2-1)) + C(I,IND) = D(IPR(I2)) + 90 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB04QU *** + END diff --git a/mex/sources/libslicot/SB04QY.f b/mex/sources/libslicot/SB04QY.f new file mode 100644 index 000000000..f351a2f4e --- /dev/null +++ b/mex/sources/libslicot/SB04QY.f @@ -0,0 +1,185 @@ + SUBROUTINE SB04QY( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct and solve a linear algebraic system of order M whose +C coefficient matrix is in upper Hessenberg form. Such systems +C appear when solving discrete-time Sylvester equations using the +C Hessenberg-Schur method. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix B. N >= 0. +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C IND (input) INTEGER +C The index of the column in C to be computed. IND >= 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain an +C upper Hessenberg matrix. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain a +C matrix in real Schur form. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading M-by-N part of this array contains +C the matrix C with column IND updated. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Workspace +C +C D DOUBLE PRECISION array, dimension (M*(M+1)/2+2*M) +C +C IPR INTEGER array, dimension (2*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C > 0: if INFO = IND, a singular matrix was encountered. +C +C METHOD +C +C A special linear algebraic system of order M, with coefficient +C matrix in upper Hessenberg form is constructed and solved. The +C coefficient matrix is stored compactly, row-wise. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C [2] Sima, V. +C Algorithms for Linear-quadratic Optimization. +C Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, IND, LDA, LDB, LDC, M, N +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) +C .. Local Scalars .. + INTEGER I, I2, J, K, K1, K2, M1 +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSCAL, DTRMV, SB04MW +C .. Executable Statements .. +C + IF ( IND.LT.N ) THEN + DUM(1) = ZERO + CALL DCOPY ( M, DUM, 0, D, 1 ) + DO 10 I = IND + 1, N + CALL DAXPY ( M, B(IND,I), C(1,I), 1, D, 1 ) + 10 CONTINUE + DO 20 I = 2, M + C(I,IND) = C(I,IND) - A(I,I-1)*D(I-1) + 20 CONTINUE + CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, + $ D, 1 ) + DO 30 I = 1, M + C(I,IND) = C(I,IND) - D(I) + 30 CONTINUE + END IF +C + M1 = M + 1 + I2 = ( M*M1 )/2 + M1 + K2 = 1 + K = M +C +C Construct the linear algebraic system of order M. +C + DO 40 I = 1, M + J = M1 - K + CALL DCOPY ( K, A(I,J), LDA, D(K2), 1 ) + CALL DSCAL ( K, B(IND,IND), D(K2), 1 ) + K1 = K2 + K2 = K2 + K + IF ( I.GT.1 ) THEN + K1 = K1 + 1 + K = K - 1 + END IF + D(K1) = D(K1) + ONE +C +C Store the right hand side. +C + D(I2) = C(I,IND) + I2 = I2 + 1 + 40 CONTINUE +C +C Solve the linear algebraic system and store the solution in C. +C + CALL SB04MW( M, D, IPR, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = IND + ELSE +C + DO 50 I = 1, M + C(I,IND) = D(IPR(I)) + 50 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB04QY *** + END diff --git a/mex/sources/libslicot/SB04RD.f b/mex/sources/libslicot/SB04RD.f new file mode 100644 index 000000000..6fd6feaec --- /dev/null +++ b/mex/sources/libslicot/SB04RD.f @@ -0,0 +1,406 @@ + SUBROUTINE SB04RD( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C, + $ LDC, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X the discrete-time Sylvester equation +C +C X + AXB = C, +C +C with at least one of the matrices A or B in Schur form and the +C other in Hessenberg or Schur form (both either upper or lower); +C A, B, C and X are N-by-N, M-by-M, N-by-M, and N-by-M matrices, +C respectively. +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHU CHARACTER*1 +C Indicates whether A and/or B is/are in Schur or +C Hessenberg form as follows: +C = 'A': A is in Schur form, B is in Hessenberg form; +C = 'B': B is in Schur form, A is in Hessenberg form; +C = 'S': Both A and B are in Schur form. +C +C ULA CHARACTER*1 +C Indicates whether A is in upper or lower Schur form or +C upper or lower Hessenberg form as follows: +C = 'U': A is in upper Hessenberg form if ABSCHU = 'B' and +C upper Schur form otherwise; +C = 'L': A is in lower Hessenberg form if ABSCHU = 'B' and +C lower Schur form otherwise. +C +C ULB CHARACTER*1 +C Indicates whether B is in upper or lower Schur form or +C upper or lower Hessenberg form as follows: +C = 'U': B is in upper Hessenberg form if ABSCHU = 'A' and +C upper Schur form otherwise; +C = 'L': B is in lower Hessenberg form if ABSCHU = 'A' and +C lower Schur form otherwise. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C coefficient matrix A of the equation. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading M-by-M part of this array must contain the +C coefficient matrix B of the equation. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading N-by-M part of this array must +C contain the coefficient matrix C of the equation. +C On exit, if INFO = 0, the leading N-by-M part of this +C array contains the solution matrix X of the problem. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity in +C the Sylvester equation. If the user sets TOL > 0, then the +C given value of TOL is used as a lower bound for the +C reciprocal condition number; a matrix whose estimated +C condition number is less than 1/TOL is considered to be +C nonsingular. If the user sets TOL <= 0, then a default +C tolerance, defined by TOLDEF = EPS, is used instead, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). +C This parameter is not referenced if ABSCHU = 'S', +C ULA = 'U', and ULB = 'U'. +C +C Workspace +C +C IWORK INTEGER array, dimension (2*MAX(M,N)) +C This parameter is not referenced if ABSCHU = 'S', +C ULA = 'U', and ULB = 'U'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = 2*N, if ABSCHU = 'S', ULA = 'U', and ULB = 'U'; +C LDWORK = 2*MAX(M,N)*(4 + 2*MAX(M,N)), otherwise. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if a (numerically) singular matrix T was encountered +C during the computation of the solution matrix X. +C That is, the estimated reciprocal condition number +C of T is less than or equal to TOL. +C +C METHOD +C +C Matrices A and B are assumed to be in (upper or lower) Hessenberg +C or Schur form (with at least one of them in Schur form). The +C solution matrix X is then computed by rows or columns via the back +C substitution scheme proposed by Golub, Nash and Van Loan (see +C [1]), which involves the solution of triangular systems of +C equations that are constructed recursively and which may be nearly +C singular if A and -B have almost reciprocal eigenvalues. If near +C singularity is detected, then the routine returns with the Error +C Indicator (INFO) set to 1. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C [2] Sima, V. +C Algorithms for Linear-quadratic Optimization. +C Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C 2 2 +C The algorithm requires approximately 5M N + 0.5MN operations in +C 2 2 +C the worst case and 2.5M N + 0.5MN operations in the best case +C (where M is the order of the matrix in Hessenberg form and N is +C the order of the matrix in Schur form) and is mixed stable (see +C [1]). +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHU, ULA, ULB + INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) +C .. Local Scalars .. + CHARACTER ABSCHR + LOGICAL LABSCB, LABSCS, LULA, LULB + INTEGER FWD, I, IBEG, IEND, INCR, IPINCR, ISTEP, JWORK, + $ LDW, MAXMN + DOUBLE PRECISION SCALE, TOL1 +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, SB04PY, SB04RV, SB04RW, SB04RX, SB04RY, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 + MAXMN = MAX( M, N ) + LABSCB = LSAME( ABSCHU, 'B' ) + LABSCS = LSAME( ABSCHU, 'S' ) + LULA = LSAME( ULA, 'U' ) + LULB = LSAME( ULB, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LABSCB .AND. .NOT.LABSCS .AND. + $ .NOT.LSAME( ABSCHU, 'A' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LULA .AND. .NOT.LSAME( ULA, 'L' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LULB .AND. .NOT.LSAME( ULB, 'L' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.2*N .OR. + $ ( LDWORK.LT.2*MAXMN*( 4 + 2*MAXMN ) .AND. + $ .NOT.( LABSCS .AND. LULA .AND. LULB ) ) ) THEN + INFO = -15 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB04RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAXMN.EQ.0 ) + $ RETURN +C + IF ( LABSCS .AND. LULA .AND. LULB ) THEN +C +C If both matrices are in a real Schur form, use SB04PY. +C + CALL SB04PY( 'NoTranspose', 'NoTranspose', 1, N, M, A, LDA, + $ B, LDB, C, LDC, SCALE, DWORK, INFO ) + IF ( SCALE.NE.ONE ) + $ INFO = 1 + RETURN + END IF +C + LDW = 2*MAXMN + JWORK = LDW*LDW + 3*LDW + 1 + TOL1 = TOL + IF ( TOL1.LE.ZERO ) + $ TOL1 = DLAMCH( 'Epsilon' ) +C +C Choose the smallest of both matrices as the one in Hessenberg +C form when possible. +C + ABSCHR = ABSCHU + IF ( LABSCS ) THEN + IF ( N.GT.M ) THEN + ABSCHR = 'A' + ELSE + ABSCHR = 'B' + END IF + END IF + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C B is in Schur form: recursion on the columns of B. +C + IF ( LULB ) THEN +C +C B is upper: forward recursion. +C + IBEG = 1 + IEND = M + FWD = 1 + INCR = 0 + ELSE +C +C B is lower: backward recursion. +C + IBEG = M + IEND = 1 + FWD = -1 + INCR = -1 + END IF + I = IBEG +C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO + 20 IF ( ( IEND - I )*FWD.GE.0 ) THEN +C +C Test for 1-by-1 or 2-by-2 diagonal block in the Schur +C form. +C + IF ( I.EQ.IEND ) THEN + ISTEP = 1 + ELSE + IF ( B(I+FWD,I).EQ.ZERO ) THEN + ISTEP = 1 + ELSE + ISTEP = 2 + END IF + END IF +C + IF ( ISTEP.EQ.1 ) THEN + CALL SB04RW( ABSCHR, ULB, N, M, C, LDC, I, B, LDB, + $ A, LDA, DWORK(JWORK), DWORK ) + CALL SB04RY( 'R', ULA, N, A, LDA, B(I,I), DWORK(JWORK), + $ TOL1, IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( N, DWORK(JWORK), 1, C(1,I), 1 ) + ELSE + IPINCR = I + INCR + CALL SB04RV( ABSCHR, ULB, N, M, C, LDC, IPINCR, B, LDB, + $ A, LDA, DWORK(JWORK), DWORK ) + CALL SB04RX( 'R', ULA, N, A, LDA, B(IPINCR,IPINCR), + $ B(IPINCR+1,IPINCR), B(IPINCR,IPINCR+1), + $ B(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, + $ IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( N, DWORK(JWORK), 2, C(1,IPINCR), 1 ) + CALL DCOPY( N, DWORK(JWORK+1), 2, C(1,IPINCR+1), 1 ) + END IF + I = I + FWD*ISTEP + GO TO 20 + END IF +C END WHILE 20 + ELSE +C +C A is in Schur form: recursion on the rows of A. +C + IF ( LULA ) THEN +C +C A is upper: backward recursion. +C + IBEG = N + IEND = 1 + FWD = -1 + INCR = -1 + ELSE +C +C A is lower: forward recursion. +C + IBEG = 1 + IEND = N + FWD = 1 + INCR = 0 + END IF + I = IBEG +C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO + 40 IF ( ( IEND - I )*FWD.GE.0 ) THEN +C +C Test for 1-by-1 or 2-by-2 diagonal block in the Schur +C form. +C + IF ( I.EQ.IEND ) THEN + ISTEP = 1 + ELSE + IF ( A(I,I+FWD).EQ.ZERO ) THEN + ISTEP = 1 + ELSE + ISTEP = 2 + END IF + END IF +C + IF ( ISTEP.EQ.1 ) THEN + CALL SB04RW( ABSCHR, ULA, N, M, C, LDC, I, A, LDA, + $ B, LDB, DWORK(JWORK), DWORK ) + CALL SB04RY( 'C', ULB, M, B, LDB, A(I,I), DWORK(JWORK), + $ TOL1, IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + ELSE + IPINCR = I + INCR + CALL SB04RV( ABSCHR, ULA, N, M, C, LDC, IPINCR, A, LDA, + $ B, LDB, DWORK(JWORK), DWORK ) + CALL SB04RX( 'C', ULB, M, B, LDB, A(IPINCR,IPINCR), + $ A(IPINCR+1,IPINCR), A(IPINCR,IPINCR+1), + $ A(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, + $ IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( M, DWORK(JWORK), 2, C(IPINCR,1), LDC ) + CALL DCOPY( M, DWORK(JWORK+1), 2, C(IPINCR+1,1), LDC ) + END IF + I = I + FWD*ISTEP + GO TO 40 + END IF +C END WHILE 40 + END IF +C + RETURN +C *** Last line of SB04RD *** + END diff --git a/mex/sources/libslicot/SB04RV.f b/mex/sources/libslicot/SB04RV.f new file mode 100644 index 000000000..a385fb8ae --- /dev/null +++ b/mex/sources/libslicot/SB04RV.f @@ -0,0 +1,198 @@ + SUBROUTINE SB04RV( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, BA, + $ LDBA, D, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the right-hand sides D for a system of equations in +C quasi-Hessenberg form solved via SB04RX (case with 2 right-hand +C sides). +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHR CHARACTER*1 +C Indicates whether AB contains A or B, as follows: +C = 'A': AB contains A; +C = 'B': AB contains B. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,M) +C The leading N-by-M part of this array must contain both +C the not yet modified part of the coefficient matrix C of +C the Sylvester equation X + AXB = C, and both the currently +C computed part of the solution of the Sylvester equation. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C INDX (input) INTEGER +C The position of the first column/row of C to be used in +C the construction of the right-hand side D. +C +C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C X + AXB = C. +C +C LDAB INTEGER +C The leading dimension of array AB. +C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on +C ABSCHR = 'A' or ABSCHR = 'B', respectively). +C +C BA (input) DOUBLE PRECISION array, dimension (LDBA,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C X + AXB = C, the matrix not contained in AB. +C +C LDBA INTEGER +C The leading dimension of array BA. +C LDBA >= MAX(1,N) or LDBA >= MAX(1,M) (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively). +C +C D (output) DOUBLE PRECISION array, dimension (*) +C The leading 2*N or 2*M part of this array (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the +C right-hand side stored as a matrix with two rows. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C where LDWORK is equal to 2*N or 2*M (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively). +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHR, UL + INTEGER INDX, LDAB, LDBA, LDC, M, N +C .. Array Arguments .. + DOUBLE PRECISION AB(LDAB,*), BA(LDBA,*), C(LDC,*), D(*), DWORK(*) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV +C .. Executable Statements .. +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C Construct the 2 columns of the right-hand side. +C + CALL DCOPY( N, C(1,INDX), 1, D(1), 2 ) + CALL DCOPY( N, C(1,INDX+1), 1, D(2), 2 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX), 1, + $ ZERO, DWORK, 1 ) + CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX+1), + $ 1, ZERO, DWORK(N+1), 1 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, + $ D(1), 2 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK(N+1), 1, + $ ONE, D(2), 2 ) + END IF + ELSE + IF ( INDX.LT.M-1 ) THEN + CALL DGEMV( 'N', N, M-INDX-1, ONE, C(1,INDX+2), LDC, + $ AB(INDX+2,INDX), 1, ZERO, DWORK, 1 ) + CALL DGEMV( 'N', N, M-INDX-1, ONE, C(1,INDX+2), LDC, + $ AB(INDX+2,INDX+1), 1, ZERO, DWORK(N+1), 1 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, + $ D(1), 2 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK(N+1), 1, + $ ONE, D(2), 2 ) + END IF + END IF + ELSE +C +C Construct the 2 rows of the right-hand side. +C + CALL DCOPY( M, C(INDX,1), LDC, D(1), 2 ) + CALL DCOPY( M, C(INDX+1,1), LDC, D(2), 2 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.LT.N-1 ) THEN + CALL DGEMV( 'T', N-INDX-1, M, ONE, C(INDX+2,1), LDC, + $ AB(INDX,INDX+2), LDAB, ZERO, DWORK, 1 ) + CALL DGEMV( 'T', N-INDX-1, M, ONE, C(INDX+2,1), LDC, + $ AB(INDX+1,INDX+2), LDAB, ZERO, DWORK(M+1), + $ 1 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, + $ D(1), 2 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK(M+1), 1, + $ ONE, D(2), 2 ) + END IF + ELSE + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX,1), + $ LDAB, ZERO, DWORK, 1 ) + CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX+1,1), + $ LDAB, ZERO, DWORK(M+1), 1 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, + $ D(1), 2 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK(M+1), 1, + $ ONE, D(2), 2 ) + END IF + END IF + END IF +C + RETURN +C *** Last line of SB04RV *** + END diff --git a/mex/sources/libslicot/SB04RW.f b/mex/sources/libslicot/SB04RW.f new file mode 100644 index 000000000..9dc815c67 --- /dev/null +++ b/mex/sources/libslicot/SB04RW.f @@ -0,0 +1,178 @@ + SUBROUTINE SB04RW( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, BA, + $ LDBA, D, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the right-hand side D for a system of equations in +C Hessenberg form solved via SB04RY (case with 1 right-hand side). +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHR CHARACTER*1 +C Indicates whether AB contains A or B, as follows: +C = 'A': AB contains A; +C = 'B': AB contains B. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,M) +C The leading N-by-M part of this array must contain both +C the not yet modified part of the coefficient matrix C of +C the Sylvester equation X + AXB = C, and both the currently +C computed part of the solution of the Sylvester equation. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C INDX (input) INTEGER +C The position of the column/row of C to be used in the +C construction of the right-hand side D. +C +C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C X + AXB = C. +C +C LDAB INTEGER +C The leading dimension of array AB. +C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on +C ABSCHR = 'A' or ABSCHR = 'B', respectively). +C +C BA (input) DOUBLE PRECISION array, dimension (LDBA,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C X + AXB = C, the matrix not contained in AB. +C +C LDBA INTEGER +C The leading dimension of array BA. +C LDBA >= MAX(1,N) or LDBA >= MAX(1,M) (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively). +C +C D (output) DOUBLE PRECISION array, dimension (*) +C The leading N or M part of this array (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the +C right-hand side. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C where LDWORK is equal to N or M (depending on ABSCHR = 'B' +C or ABSCHR = 'A', respectively). +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHR, UL + INTEGER INDX, LDAB, LDBA, LDC, M, N +C .. Array Arguments .. + DOUBLE PRECISION AB(LDAB,*), BA(LDBA,*), C(LDC,*), D(*), DWORK(*) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV +C .. Executable Statements .. +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C Construct the column of the right-hand side. +C + CALL DCOPY( N, C(1,INDX), 1, D, 1 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX), 1, + $ ZERO, DWORK, 1 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, + $ ONE, D, 1 ) + END IF + ELSE + IF ( INDX.LT.M ) THEN + CALL DGEMV( 'N', N, M-INDX, ONE, C(1,INDX+1), LDC, + $ AB(INDX+1,INDX), 1, ZERO, DWORK, 1 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, D, + $ 1 ) + END IF + END IF + ELSE +C +C Construct the row of the right-hand side. +C + CALL DCOPY( M, C(INDX,1), LDC, D, 1 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.LT.N ) THEN + CALL DGEMV( 'T', N-INDX, M, ONE, C(INDX+1,1), LDC, + $ AB(INDX,INDX+1), LDAB, ZERO, DWORK, 1 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, D, + $ 1 ) + END IF + ELSE + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX,1), + $ LDAB, ZERO, DWORK, 1 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, D, + $ 1 ) + END IF + END IF + END IF +C + RETURN +C *** Last line of SB04RW *** + END diff --git a/mex/sources/libslicot/SB04RX.f b/mex/sources/libslicot/SB04RX.f new file mode 100644 index 000000000..e84bb188d --- /dev/null +++ b/mex/sources/libslicot/SB04RX.f @@ -0,0 +1,375 @@ + SUBROUTINE SB04RX( RC, UL, M, A, LDA, LAMBD1, LAMBD2, LAMBD3, + $ LAMBD4, D, TOL, IWORK, DWORK, LDDWOR, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a system of equations in quasi-Hessenberg form +C (Hessenberg form plus two consecutive offdiagonals) with two +C right-hand sides. +C +C ARGUMENTS +C +C Mode Parameters +C +C RC CHARACTER*1 +C Indicates processing by columns or rows, as follows: +C = 'R': Row transformations are applied; +C = 'C': Column transformations are applied. +C +C UL CHARACTER*1 +C Indicates whether A is upper or lower Hessenberg matrix, +C as follows: +C = 'U': A is upper Hessenberg; +C = 'L': A is lower Hessenberg. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain a +C matrix A in Hessenberg form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C LAMBD1, (input) DOUBLE PRECISION +C LAMBD2, These variables must contain the 2-by-2 block to be +C LAMBD3, multiplied to the elements of A. +C LAMBD4 +C +C D (input/output) DOUBLE PRECISION array, dimension (2*M) +C On entry, this array must contain the two right-hand +C side vectors of the quasi-Hessenberg system, stored +C row-wise. +C On exit, if INFO = 0, this array contains the two solution +C vectors of the quasi-Hessenberg system, stored row-wise. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the triangular factor R of the quasi-Hessenberg matrix. +C A matrix whose estimated condition number is less +C than 1/TOL is considered to be nonsingular. +C +C Workspace +C +C IWORK INTEGER array, dimension (2*M) +C +C DWORK DOUBLE PRECISION array, dimension (LDDWOR,2*M+3) +C The leading 2*M-by-2*M part of this array is used for +C computing the triangular factor of the QR decomposition +C of the quasi-Hessenberg matrix. The remaining 6*M elements +C are used as workspace for the computation of the +C reciprocal condition estimate. +C +C LDDWOR INTEGER +C The leading dimension of array DWORK. +C LDDWOR >= MAX(1,2*M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if the quasi-Hessenberg matrix is (numerically) +C singular. That is, its estimated reciprocal +C condition number is less than or equal to TOL. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C Note that RC, UL, M, LDA, and LDDWOR must be such that the value +C of the LOGICAL variable OK in the following statement is true. +C +C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. +C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) +C .AND. +C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. +C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) +C .AND. +C ( M.GE.0 ) +C .AND. +C ( LDA.GE.MAX( 1, M ) ) +C .AND. +C ( LDDWOR.GE.MAX( 1, 2*M ) ) +C +C These conditions are not checked by the routine. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER RC, UL + INTEGER INFO, LDA, LDDWOR, M + DOUBLE PRECISION LAMBD1, LAMBD2, LAMBD3, LAMBD4, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) +C .. Local Scalars .. + CHARACTER TRANS + INTEGER J, J1, J2, M2, MJ, ML + DOUBLE PRECISION C, R, RCOND, S +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARTG, DLASET, DROT, DSCAL, DTRCON, + $ DTRSV +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN, MOD +C .. Executable Statements .. +C + INFO = 0 +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + M2 = M*2 + IF ( LSAME( UL, 'U' ) ) THEN +C + DO 20 J = 1, M + J2 = J*2 + ML = MIN( M, J + 1 ) + CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), + $ LDDWOR ) + CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2-1), 2 ) + CALL DSCAL( ML, LAMBD1, DWORK(1,J2-1), 2 ) + CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2-1), 2 ) + CALL DSCAL( ML, LAMBD3, DWORK(2,J2-1), 2 ) + CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2), 2 ) + CALL DSCAL( ML, LAMBD2, DWORK(1,J2), 2 ) + CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2), 2 ) + CALL DSCAL( ML, LAMBD4, DWORK(2,J2), 2 ) +C + DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + ONE + DWORK(J2,J2) = DWORK(J2,J2) + ONE + 20 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is an upper Hessenberg matrix, row transformations. +C + DO 40 J = 1, M2 - 1 + MJ = M2 - J + IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN + IF ( DWORK(J+3,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J+2,J), DWORK(J+3,J), C, S, R ) + DWORK(J+2,J) = R + DWORK(J+3,J) = ZERO + CALL DROT( MJ, DWORK(J+2,J+1), LDDWOR, + $ DWORK(J+3,J+1), LDDWOR, C, S ) + CALL DROT( 1, D(J+2), 1, D(J+3), 1, C, S ) + END IF + END IF + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(J+2,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J+1,J), DWORK(J+2,J), C, S, R ) + DWORK(J+1,J) = R + DWORK(J+2,J) = ZERO + CALL DROT( MJ, DWORK(J+1,J+1), LDDWOR, + $ DWORK(J+2,J+1), LDDWOR, C, S ) + CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) + END IF + END IF + IF ( DWORK(J+1,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) + DWORK(J,J) = R + DWORK(J+1,J) = ZERO + CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 40 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is an upper Hessenberg matrix, column transformations. +C + DO 60 J = 1, M2 - 1 + MJ = M2 - J + IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN + IF ( DWORK(MJ+1,MJ-2).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ-1), DWORK(MJ+1,MJ-2), C, + $ S, R ) + DWORK(MJ+1,MJ-1) = R + DWORK(MJ+1,MJ-2) = ZERO + CALL DROT( MJ, DWORK(1,MJ-1), 1, DWORK(1,MJ-2), 1, + $ C, S ) + CALL DROT( 1, D(MJ-1), 1, D(MJ-2), 1, C, S ) + END IF + END IF + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(MJ+1,MJ-1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ), DWORK(MJ+1,MJ-1), C, + $ S, R ) + DWORK(MJ+1,MJ) = R + DWORK(MJ+1,MJ-1) = ZERO + CALL DROT( MJ, DWORK(1,MJ), 1, DWORK(1,MJ-1), 1, C, + $ S ) + CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) + END IF + END IF + IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ+1,MJ) = ZERO + CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, + $ S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 60 CONTINUE +C + END IF + ELSE +C + DO 80 J = 1, M + J2 = J*2 + J1 = MAX( J - 1, 1 ) + ML = MIN( M - J + 2, M ) + CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), + $ LDDWOR ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2-1), 2 ) + CALL DSCAL( ML, LAMBD1, DWORK(J1*2-1,J2-1), 2 ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2-1), 2 ) + CALL DSCAL( ML, LAMBD3, DWORK(J1*2,J2-1), 2 ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2), 2 ) + CALL DSCAL( ML, LAMBD2, DWORK(J1*2-1,J2), 2 ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2), 2 ) + CALL DSCAL( ML, LAMBD4, DWORK(J1*2,J2), 2 ) +C + DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + ONE + DWORK(J2,J2) = DWORK(J2,J2) + ONE + 80 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is a lower Hessenberg matrix, row transformations. +C + DO 100 J = 1, M2 - 1 + MJ = M2 - J + IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN + IF ( DWORK(MJ-2,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ-1,MJ+1), DWORK(MJ-2,MJ+1), C, + $ S, R ) + DWORK(MJ-1,MJ+1) = R + DWORK(MJ-2,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ-1,1), LDDWOR, + $ DWORK(MJ-2,1), LDDWOR, C, S ) + CALL DROT( 1, D(MJ-1), 1, D(MJ-2), 1, C, S ) + END IF + END IF + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(MJ-1,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ,MJ+1), DWORK(MJ-1,MJ+1), C, + $ S, R ) + DWORK(MJ,MJ+1) = R + DWORK(MJ-1,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ,1), LDDWOR, DWORK(MJ-1,1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) + END IF + END IF + IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), + $ LDDWOR, C, S) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 100 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is a lower Hessenberg matrix, column transformations. +C + DO 120 J = 1, M2 - 1 + MJ = M2 - J + IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN + IF ( DWORK(J,J+3).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J+2), DWORK(J,J+3), C, S, R ) + DWORK(J,J+2) = R + DWORK(J,J+3) = ZERO + CALL DROT( MJ, DWORK(J+1,J+2), 1, DWORK(J+1,J+3), + $ 1, C, S ) + CALL DROT( 1, D(J+2), 1, D(J+3), 1, C, S ) + END IF + END IF + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(J,J+2).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J+1), DWORK(J,J+2), C, S, R ) + DWORK(J,J+1) = R + DWORK(J,J+2) = ZERO + CALL DROT( MJ, DWORK(J+1,J+1), 1, DWORK(J+1,J+2), + $ 1, C, S ) + CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) + END IF + END IF + IF ( DWORK(J,J+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) + DWORK(J,J) = R + DWORK(J,J+1) = ZERO + CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, + $ S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 120 CONTINUE +C + END IF + END IF +C + CALL DTRCON( '1-norm', UL, 'Non-unit', M2, DWORK, LDDWOR, RCOND, + $ DWORK(1,M2+1), IWORK, INFO ) + IF ( RCOND.LE.TOL ) THEN + INFO = 1 + ELSE + CALL DTRSV( UL, TRANS, 'Non-unit', M2, DWORK, LDDWOR, D, 1 ) + END IF +C + RETURN +C *** Last line of SB04RX *** + END diff --git a/mex/sources/libslicot/SB04RY.f b/mex/sources/libslicot/SB04RY.f new file mode 100644 index 000000000..2ea8fd91e --- /dev/null +++ b/mex/sources/libslicot/SB04RY.f @@ -0,0 +1,261 @@ + SUBROUTINE SB04RY( RC, UL, M, A, LDA, LAMBDA, D, TOL, IWORK, + $ DWORK, LDDWOR, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a system of equations in Hessenberg form with one +C right-hand side. +C +C ARGUMENTS +C +C Mode Parameters +C +C RC CHARACTER*1 +C Indicates processing by columns or rows, as follows: +C = 'R': Row transformations are applied; +C = 'C': Column transformations are applied. +C +C UL CHARACTER*1 +C Indicates whether A is upper or lower Hessenberg matrix, +C as follows: +C = 'U': A is upper Hessenberg; +C = 'L': A is lower Hessenberg. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain a +C matrix A in Hessenberg form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C LAMBDA (input) DOUBLE PRECISION +C This variable must contain the value to be multiplied with +C the elements of A. +C +C D (input/output) DOUBLE PRECISION array, dimension (M) +C On entry, this array must contain the right-hand side +C vector of the Hessenberg system. +C On exit, if INFO = 0, this array contains the solution +C vector of the Hessenberg system. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the triangular factor R of the Hessenberg matrix. A matrix +C whose estimated condition number is less than 1/TOL is +C considered to be nonsingular. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (LDDWOR,M+3) +C The leading M-by-M part of this array is used for +C computing the triangular factor of the QR decomposition +C of the Hessenberg matrix. The remaining 3*M elements are +C used as workspace for the computation of the reciprocal +C condition estimate. +C +C LDDWOR INTEGER +C The leading dimension of array DWORK. LDDWOR >= MAX(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if the Hessenberg matrix is (numerically) singular. +C That is, its estimated reciprocal condition number +C is less than or equal to TOL. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C Note that RC, UL, M, LDA, and LDDWOR must be such that the value +C of the LOGICAL variable OK in the following statement is true. +C +C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. +C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) +C .AND. +C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. +C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) +C .AND. +C ( M.GE.0 ) +C .AND. +C ( LDA.GE.MAX( 1, M ) ) +C .AND. +C ( LDDWOR.GE.MAX( 1, M ) ) +C +C These conditions are not checked by the routine. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER RC, UL + INTEGER INFO, LDA, LDDWOR, M + DOUBLE PRECISION LAMBDA, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) +C .. Local Scalars .. + CHARACTER TRANS + INTEGER J, J1, MJ + DOUBLE PRECISION C, R, RCOND, S +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARTG, DROT, DSCAL, DTRCON, DTRSV +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + IF ( LSAME( UL, 'U' ) ) THEN +C + DO 20 J = 1, M + CALL DCOPY( MIN( J+1, M ), A(1,J), 1, DWORK(1,J), 1 ) + CALL DSCAL( MIN( J+1, M ), LAMBDA, DWORK(1,J), 1 ) + DWORK(J,J) = DWORK(J,J) + ONE + 20 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is an upper Hessenberg matrix, row transformations. +C + DO 40 J = 1, M - 1 + MJ = M - J + IF ( DWORK(J+1,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) + DWORK(J,J) = R + DWORK(J+1,J) = ZERO + CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 40 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is an upper Hessenberg matrix, column transformations. +C + DO 60 J = 1, M - 1 + MJ = M - J + IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ+1,MJ) = ZERO + CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, + $ S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 60 CONTINUE +C + END IF + ELSE +C + DO 80 J = 1, M + J1 = MAX( J - 1, 1 ) + CALL DCOPY( M-J1+1, A(J1,J), 1, DWORK(J1,J), 1 ) + CALL DSCAL( M-J1+1, LAMBDA, DWORK(J1,J), 1 ) + DWORK(J,J) = DWORK(J,J) + ONE + 80 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is a lower Hessenberg matrix, row transformations. +C + DO 100 J = 1, M - 1 + MJ = M - J + IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 100 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is a lower Hessenberg matrix, column transformations. +C + DO 120 J = 1, M - 1 + MJ = M - J + IF ( DWORK(J,J+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) + DWORK(J,J) = R + DWORK(J,J+1) = ZERO + CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, + $ S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 120 CONTINUE +C + END IF + END IF +C + CALL DTRCON( '1-norm', UL, 'Non-unit', M, DWORK, LDDWOR, RCOND, + $ DWORK(1,M+1), IWORK, INFO ) + IF ( RCOND.LE.TOL ) THEN + INFO = 1 + ELSE + CALL DTRSV( UL, TRANS, 'Non-unit', M, DWORK, LDDWOR, D, 1 ) + END IF +C + RETURN +C *** Last line of SB04RY *** + END diff --git a/mex/sources/libslicot/SB06ND.f b/mex/sources/libslicot/SB06ND.f new file mode 100644 index 000000000..3ea986376 --- /dev/null +++ b/mex/sources/libslicot/SB06ND.f @@ -0,0 +1,325 @@ + SUBROUTINE SB06ND( N, M, KMAX, A, LDA, B, LDB, KSTAIR, U, LDU, F, + $ LDF, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the minimum norm feedback matrix F to perform +C "deadbeat control" on a (A,B)-pair of a state-space model (which +C must be preliminarily reduced to upper "staircase" form using +C SLICOT Library routine AB01OD) such that the matrix R = A + BFU' +C is nilpotent. +C (The transformation matrix U reduces R to upper Schur form with +C zero blocks on its diagonal (of dimension KSTAIR(i)) and +C therefore contains bases for the i-th controllable subspaces, +C where i = 1,...,KMAX). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e. the order of the +C matrix A. N >= 0. +C +C M (input) INTEGER +C The actual input dimension. M >= 0. +C +C KMAX (input) INTEGER +C The number of "stairs" in the staircase form as produced +C by SLICOT Library routine AB01OD. 0 <= KMAX <= N. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the transformed state-space matrix of the +C (A,B)-pair with triangular stairs, as produced by SLICOT +C Library routine AB01OD (with option STAGES = 'A'). +C On exit, the leading N-by-N part of this array contains +C the matrix U'AU + U'BF. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the transformed triangular input matrix of the +C (A,B)-pair as produced by SLICOT Library routine AB01OD +C (with option STAGES = 'A'). +C On exit, the leading N-by-M part of this array contains +C the matrix U'B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C KSTAIR (input) INTEGER array, dimension (KMAX) +C The leading KMAX elements of this array must contain the +C dimensions of each "stair" as produced by SLICOT Library +C routine AB01OD. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) +C On entry, the leading N-by-N part of this array must +C contain either a transformation matrix (e.g. from a +C previous call to other SLICOT routine) or be initialised +C as the identity matrix. +C On exit, the leading N-by-N part of this array contains +C the product of the input matrix U and the state-space +C transformation matrix which reduces A + BFU' to real +C Schur form. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,N). +C +C F (output) DOUBLE PRECISION array, dimension (LDF,N) +C The leading M-by-N part of this array contains the +C deadbeat feedback matrix F. +C +C LDF INTEGER +C The leading dimension of array F. LDF >= MAX(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Starting from the (A,B)-pair in "staircase form" with "triangular" +C stairs, dimensions KSTAIR(i+1) x KSTAIR(i), (described by the +C vector KSTAIR): +C +C | B | A * . . . * | +C | 1| 11 . . | +C | | A A . . | +C | | 21 22 . . | +C | | . . . | +C [ B | A ] = | | . . * | +C | | . . | +C | 0 | 0 | +C | | A A | +C | | r,r-1 rr | +C +C where the i-th diagonal block of A has dimension KSTAIR(i), for +C i = 1,2,...,r, the feedback matrix F is constructed recursively in +C r steps (where the number of "stairs" r is given by KMAX). In each +C step a unitary state-space transformation U and a part of F are +C updated in order to achieve the final form: +C +C | 0 A * . . . * | +C | 12 . . | +C | . . | +C | 0 A . . | +C | 23 . . | +C | . . | +C [ U'AU + U'BF ] = | . . * | . +C | . . | +C | | +C | A | +C | r-1,r| +C | | +C | 0 | +C +C +C REFERENCES +C +C [1] Van Dooren, P. +C Deadbeat control: a special inverse eigenvalue problem. +C BIT, 24, pp. 681-699, 1984. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O((N + M) * N**2) operations and is mixed +C numerical stable (see [1]). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB06BD by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C 1997, December 10; 2003, September 27. +C +C KEYWORDS +C +C Canonical form, deadbeat control, eigenvalue assignment, feedback +C control, orthogonal transformation, real Schur form, staircase +C form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, KMAX, LDA, LDB, LDF, LDU, M, N +C .. Array Arguments .. + INTEGER KSTAIR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*), U(LDU,*) +C .. Local Scalars .. + INTEGER J, J0, JCUR, JKCUR, JMKCUR, KCUR, KK, KMIN, + $ KSTEP, MKCUR, NCONT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLACPY, DLARFG, DLASET, DLATZM, + $ DTRSM, XERBLA +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( KMAX.LT.0 .OR. KMAX.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -12 + ELSE + NCONT = 0 +C + DO 10 KK = 1, KMAX + NCONT = NCONT + KSTAIR(KK) + 10 CONTINUE +C + IF( NCONT.GT.N ) + $ INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB06ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + DO 120 KMIN = 1, KMAX + JCUR = NCONT + KSTEP = KMAX - KMIN +C +C Triangularize bottom part of A (if KSTEP > 0). +C + DO 40 KK = KMAX, KMAX - KSTEP + 1, -1 + KCUR = KSTAIR(KK) +C +C Construct Ukk and store in Fkk. +C + DO 20 J = 1, KCUR + JMKCUR = JCUR - KCUR + CALL DCOPY( KCUR, A(JCUR,JMKCUR), LDA, F(1,JCUR), 1 ) + CALL DLARFG( KCUR+1, A(JCUR,JCUR), F(1,JCUR), 1, + $ DWORK(JCUR) ) + CALL DLASET( 'Full', 1, KCUR, ZERO, ZERO, A(JCUR,JMKCUR), + $ LDA ) +C +C Backmultiply A and U with Ukk. +C + CALL DLATZM( 'Right', JCUR-1, KCUR+1, F(1,JCUR), 1, + $ DWORK(JCUR), A(1,JCUR), A(1,JMKCUR), LDA, + $ DWORK ) +C + CALL DLATZM( 'Right', N, KCUR+1, F(1,JCUR), 1, + $ DWORK(JCUR), U(1,JCUR), U(1,JMKCUR), LDU, + $ DWORK(N+1) ) + JCUR = JCUR - 1 + 20 CONTINUE +C + 40 CONTINUE +C +C Eliminate diagonal block Aii by feedback Fi. +C + KCUR = KSTAIR(KMIN) + J0 = JCUR - KCUR + 1 + MKCUR = M - KCUR + 1 +C +C Solve for Fi and add B x Fi to A. +C + CALL DLACPY( 'Full', KCUR, KCUR, A(J0,J0), LDA, F(MKCUR,J0), + $ LDF ) + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', KCUR, + $ KCUR, -ONE, B(J0,MKCUR), LDB, F(MKCUR,J0), LDF ) + IF ( J0.GT.1 ) + $ CALL DGEMM( 'No transpose', 'No transpose', J0-1, KCUR, + $ KCUR, ONE, B(1,MKCUR), LDB, F(MKCUR,J0), LDF, + $ ONE, A(1,J0), LDA ) + CALL DLASET( 'Full', KCUR, KCUR, ZERO, ZERO, A(J0,J0), LDA ) + CALL DLASET( 'Full', M-KCUR, KCUR, ZERO, ZERO, F(1,J0), LDF ) +C + IF ( KSTEP.NE.0 ) THEN + JKCUR = NCONT +C +C Premultiply A with Ukk. +C + DO 80 KK = KMAX, KMAX - KSTEP + 1, -1 + KCUR = KSTAIR(KK) + JCUR = JKCUR - KCUR +C + DO 60 J = 1, KCUR + CALL DLATZM( 'Left', KCUR+1, N-JCUR+1, F(1,JKCUR), 1, + $ DWORK(JKCUR), A(JKCUR,JCUR), + $ A(JCUR,JCUR), LDA, DWORK(N+1) ) + JCUR = JCUR - 1 + JKCUR = JKCUR - 1 + 60 CONTINUE +C + 80 CONTINUE +C +C Premultiply B with Ukk. +C + JCUR = JCUR + KCUR + JKCUR = JCUR + KCUR +C + DO 100 J = M, M - KCUR + 1, -1 + CALL DLATZM( 'Left', KCUR+1, M-J+1, F(1,JKCUR), 1, + $ DWORK(JKCUR), B(JKCUR,J), B(JCUR,J), LDB, + $ DWORK(N+1) ) + JCUR = JCUR - 1 + JKCUR = JKCUR - 1 + 100 CONTINUE +C + END IF + 120 CONTINUE +C + IF ( NCONT.NE.N ) + $ CALL DLASET( 'Full', M, N-NCONT, ZERO, ZERO, F(1,NCONT+1), + $ LDF ) +C + RETURN +C *** Last line of SB06ND *** + END diff --git a/mex/sources/libslicot/SB08CD.f b/mex/sources/libslicot/SB08CD.f new file mode 100644 index 000000000..ed703beb5 --- /dev/null +++ b/mex/sources/libslicot/SB08CD.f @@ -0,0 +1,355 @@ + SUBROUTINE SB08CD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ NQ, NR, BR, LDBR, DR, LDDR, TOL, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct, for a given system G = (A,B,C,D), an output +C injection matrix H, an orthogonal transformation matrix Z, and a +C gain matrix V, such that the systems +C +C Q = (Z'*(A+H*C)*Z, Z'*(B+H*D), V*C*Z, V*D) +C and +C R = (Z'*(A+H*C)*Z, Z'*H, V*C*Z, V) +C +C provide a stable left coprime factorization of G in the form +C -1 +C G = R * Q, +C +C where G, Q and R are the corresponding transfer-function matrices +C and the denominator R is co-inner, that is, R(s)*R'(-s) = I in +C the continuous-time case, or R(z)*R'(1/z) = I in the discrete-time +C case. The Z matrix is not explicitly computed. +C +C Note: G must have no observable poles on the imaginary axis +C for a continuous-time system, or on the unit circle for a +C discrete-time system. If the given state-space representation +C is not detectable, the undetectable part of the original +C system is automatically deflated and the order of the systems +C Q and R is accordingly reduced. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the state vector, i.e. the order of the +C matrix A, and also the number of rows of the matrices B +C and BR, and the number of columns of the matrix C. +C N >= 0. +C +C M (input) INTEGER +C The dimension of input vector, i.e. the number of columns +C of the matrices B and D. M >= 0. +C +C P (input) INTEGER +C The dimension of output vector, i.e. the number of rows +C of the matrices C, D and DR, and the number of columns +C of the matrices BR and DR. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. The matrix A must not +C have observable eigenvalues on the imaginary axis, if +C DICO = 'C', or on the unit circle, if DICO = 'D'. +C On exit, the leading NQ-by-NQ part of this array contains +C the leading NQ-by-NQ part of the matrix Z'*(A+H*C)*Z, the +C state dynamics matrix of the numerator factor Q, in a +C real Schur form. The leading NR-by-NR part of this matrix +C represents the state dynamics matrix of a minimal +C realization of the denominator factor R. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,MAX(M,P)) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix. +C On exit, the leading NQ-by-M part of this array contains +C the leading NQ-by-M part of the matrix Z'*(B+H*D), the +C input/state matrix of the numerator factor Q. +C The remaining part of this array is needed as workspace. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-NQ part of this array contains +C the leading P-by-NQ part of the matrix V*C*Z, the +C state/output matrix of the numerator factor Q. +C The first NR columns of this array represent the +C state/output matrix of a minimal realization of the +C denominator factor R. +C The remaining part of this array is needed as workspace. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,M,P), if N > 0. +C LDC >= 1, if N = 0. +C +C D (input/output) DOUBLE PRECISION array, dimension +C (LDD,MAX(M,P)) +C On entry, the leading P-by-M part of this array must +C contain the input/output matrix. +C On exit, the leading P-by-M part of this array contains +C the matrix V*D representing the input/output matrix +C of the numerator factor Q. +C The remaining part of this array is needed as workspace. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,M,P). +C +C NQ (output) INTEGER +C The order of the resulting factors Q and R. +C Generally, NQ = N - NS, where NS is the number of +C unobservable eigenvalues outside the stability region. +C +C NR (output) INTEGER +C The order of the minimal realization of the factor R. +C Generally, NR is the number of observable eigenvalues +C of A outside the stability region (the number of modified +C eigenvalues). +C +C BR (output) DOUBLE PRECISION array, dimension (LDBR,P) +C The leading NQ-by-P part of this array contains the +C leading NQ-by-P part of the output injection matrix +C Z'*H, which reflects the eigenvalues of A lying outside +C the stable region to values which are symmetric with +C respect to the imaginary axis (if DICO = 'C') or the unit +C circle (if DICO = 'D'). The first NR rows of this matrix +C form the input/state matrix of a minimal realization of +C the denominator factor R. +C +C LDBR INTEGER +C The leading dimension of array BR. LDBR >= MAX(1,N). +C +C DR (output) DOUBLE PRECISION array, dimension (LDDR,P) +C The leading P-by-P part of this array contains the lower +C triangular matrix V representing the input/output matrix +C of the denominator factor R. +C +C LDDR INTEGER +C The leading dimension of array DR. LDDR >= MAX(1,P). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The absolute tolerance level below which the elements of +C C are considered zero (used for observability tests). +C If the user sets TOL <= 0, then an implicitly computed, +C default tolerance, defined by TOLDEF = N*EPS*NORM(C), +C is used instead, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH) and NORM(C) denotes +C the infinity-norm of C. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LDWORK >= MAX( 1, P*N + MAX( N*(N+5),P*(P+2),4*P,4*M ) ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = K: K violations of the numerical stability condition +C NORM(H) <= 10*NORM(A)/NORM(C) occured during the +C assignment of eigenvalues. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the ordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + H*C)*Z +C along the diagonal; +C = 3: if DICO = 'C' and the matrix A has an observable +C eigenvalue on the imaginary axis, or DICO = 'D' and +C A has an observable eigenvalue on the unit circle. +C +C METHOD +C +C The subroutine uses the right coprime factorization algorithm with +C inner denominator of [1] applied to G'. +C +C REFERENCES +C +C [1] Varga A. +C A Schur method for computing coprime factorizations with +C inner denominators and applications in model reduction. +C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires no more than 14N floating point +C operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine LCFID. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C May 2003, A. Varga, DLR Oberpfaffenhofen. +C Nov 2003, A. Varga, DLR Oberpfaffenhofen. +C +C KEYWORDS +C +C Coprime factorization, eigenvalue, eigenvalue assignment, +C feedback control, pole placement, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO + INTEGER INFO, IWARN, LDA, LDB, LDBR, LDC, LDD, LDDR, + $ LDWORK, M, N, NQ, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), BR(LDBR,*), C(LDC,*), + $ D(LDD,*), DR(LDDR,*), DWORK(*) +C .. Local Scalars .. + INTEGER I, KBR, KW +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External subroutines .. + EXTERNAL AB07MD, DLASET, DSWAP, MA02AD, MA02BD, SB08DD, + $ TB01XD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT.LSAME( DICO, 'C' ) .AND. + $ .NOT.LSAME( DICO, 'D' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAX( M, P ) ) ) + $ THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, M, P ) ) THEN + INFO = -12 + ELSE IF( LDBR.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDDR.LT.MAX( 1, P ) ) THEN + INFO = -18 + ELSE IF( LDWORK.LT.MAX( 1, P*N + MAX( N*(N+5), P*(P+2), 4*P, + $ 4*M ) ) ) THEN + INFO = -21 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'SB08CD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, P ).EQ.0 ) THEN + NQ = 0 + NR = 0 + DWORK(1) = ONE + CALL DLASET( 'Full', P, P, ZERO, ONE, DR, LDDR ) + RETURN + END IF +C +C Compute the dual system G' = (A',C',B',D'). +C + CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ INFO ) +C +C Compute the right coprime factorization with inner +C denominator of G'. +C +C Workspace needed: P*N; +C Additional workspace: need MAX( N*(N+5), P*(P+2), 4*P, 4*M ); +C prefer larger. +C + KBR = 1 + KW = KBR + P*N + CALL SB08DD( DICO, N, P, M, A, LDA, B, LDB, C, LDC, D, LDD, + $ NQ, NR, DWORK(KBR), P, DR, LDDR, TOL, DWORK(KW), + $ LDWORK-KW+1, IWARN, INFO ) + IF( INFO.EQ.0 ) THEN +C +C Determine the elements of the left coprime factorization from +C those of the computed right coprime factorization and make the +C state-matrix upper real Schur. +C + CALL TB01XD( 'D', NQ, P, M, MAX( 0, NQ-1 ), MAX( 0, NQ-1 ), + $ A, LDA, B, LDB, C, LDC, D, LDD, INFO ) +C + CALL MA02AD( 'Full', P, NQ, DWORK(KBR), P, BR, LDBR ) + CALL MA02BD( 'Left', NQ, P, BR, LDBR ) +C + DO 10 I = 2, P + CALL DSWAP( I-1, DR(I,1), LDDR, DR(1,I), 1 ) + 10 CONTINUE +C + END IF +C + DWORK(1) = DWORK(KW) + DBLE( KW-1 ) +C + RETURN +C *** Last line of SB08CD *** + END diff --git a/mex/sources/libslicot/SB08DD.f b/mex/sources/libslicot/SB08DD.f new file mode 100644 index 000000000..e88c9028d --- /dev/null +++ b/mex/sources/libslicot/SB08DD.f @@ -0,0 +1,583 @@ + SUBROUTINE SB08DD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ NQ, NR, CR, LDCR, DR, LDDR, TOL, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct, for a given system G = (A,B,C,D), a feedback matrix +C F, an orthogonal transformation matrix Z, and a gain matrix V, +C such that the systems +C +C Q = (Z'*(A+B*F)*Z, Z'*B*V, (C+D*F)*Z, D*V) +C and +C R = (Z'*(A+B*F)*Z, Z'*B*V, F*Z, V) +C +C provide a stable right coprime factorization of G in the form +C -1 +C G = Q * R , +C +C where G, Q and R are the corresponding transfer-function matrices +C and the denominator R is inner, that is, R'(-s)*R(s) = I in the +C continuous-time case, or R'(1/z)*R(z) = I in the discrete-time +C case. The Z matrix is not explicitly computed. +C +C Note: G must have no controllable poles on the imaginary axis +C for a continuous-time system, or on the unit circle for a +C discrete-time system. If the given state-space representation +C is not stabilizable, the unstabilizable part of the original +C system is automatically deflated and the order of the systems +C Q and R is accordingly reduced. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the state vector, i.e. the order of the +C matrix A, and also the number of rows of the matrix B and +C the number of columns of the matrices C and CR. N >= 0. +C +C M (input) INTEGER +C The dimension of input vector, i.e. the number of columns +C of the matrices B, D and DR and the number of rows of the +C matrices CR and DR. M >= 0. +C +C P (input) INTEGER +C The dimension of output vector, i.e. the number of rows +C of the matrices C and D. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. The matrix A must not +C have controllable eigenvalues on the imaginary axis, if +C DICO = 'C', or on the unit circle, if DICO = 'D'. +C On exit, the leading NQ-by-NQ part of this array contains +C the leading NQ-by-NQ part of the matrix Z'*(A+B*F)*Z, the +C state dynamics matrix of the numerator factor Q, in a +C real Schur form. The trailing NR-by-NR part of this matrix +C represents the state dynamics matrix of a minimal +C realization of the denominator factor R. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix. +C On exit, the leading NQ-by-M part of this array contains +C the leading NQ-by-M part of the matrix Z'*B*V, the +C input/state matrix of the numerator factor Q. The last +C NR rows of this matrix form the input/state matrix of +C a minimal realization of the denominator factor R. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-NQ part of this array contains +C the leading P-by-NQ part of the matrix (C+D*F)*Z, +C the state/output matrix of the numerator factor Q. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the input/output matrix. +C On exit, the leading P-by-M part of this array contains +C the matrix D*V representing the input/output matrix +C of the numerator factor Q. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NQ (output) INTEGER +C The order of the resulting factors Q and R. +C Generally, NQ = N - NS, where NS is the number of +C uncontrollable eigenvalues outside the stability region. +C +C NR (output) INTEGER +C The order of the minimal realization of the factor R. +C Generally, NR is the number of controllable eigenvalues +C of A outside the stability region (the number of modified +C eigenvalues). +C +C CR (output) DOUBLE PRECISION array, dimension (LDCR,N) +C The leading M-by-NQ part of this array contains the +C leading M-by-NQ part of the feedback matrix F*Z, which +C reflects the eigenvalues of A lying outside the stable +C region to values which are symmetric with respect to the +C imaginary axis (if DICO = 'C') or the unit circle (if +C DICO = 'D'). The last NR columns of this matrix form the +C state/output matrix of a minimal realization of the +C denominator factor R. +C +C LDCR INTEGER +C The leading dimension of array CR. LDCR >= MAX(1,M). +C +C DR (output) DOUBLE PRECISION array, dimension (LDDR,M) +C The leading M-by-M part of this array contains the upper +C triangular matrix V of order M representing the +C input/output matrix of the denominator factor R. +C +C LDDR INTEGER +C The leading dimension of array DR. LDDR >= MAX(1,M). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The absolute tolerance level below which the elements of +C B are considered zero (used for controllability tests). +C If the user sets TOL <= 0, then an implicitly computed, +C default tolerance, defined by TOLDEF = N*EPS*NORM(B), +C is used instead, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH) and NORM(B) denotes +C the 1-norm of B. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LDWORK >= MAX( 1, N*(N+5), M*(M+2), 4*M, 4*P ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = K: K violations of the numerical stability condition +C NORM(F) <= 10*NORM(A)/NORM(B) occured during the +C assignment of eigenvalues. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the ordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + B*F)*Z +C along the diagonal; +C = 3: if DICO = 'C' and the matrix A has a controllable +C eigenvalue on the imaginary axis, or DICO = 'D' +C and A has a controllable eigenvalue on the unit +C circle. +C +C METHOD +C +C The subroutine is based on the factorization algorithm of [1]. +C +C REFERENCES +C +C [1] Varga A. +C A Schur method for computing coprime factorizations with inner +C denominators and applications in model reduction. +C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires no more than 14N floating point +C operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine RCFID. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C Feb. 1999, May 2003, A. Varga, DLR Oberpfaffenhofen. +C +C KEYWORDS +C +C Coprime factorization, eigenvalue, eigenvalue assignment, +C feedback control, pole placement, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TEN, ZERO + PARAMETER ( ONE = 1.0D0, TEN = 1.0D1, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO + INTEGER INFO, IWARN, LDA, LDB, LDC, LDCR, LDD, LDDR, + $ LDWORK, M, N, NQ, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), CR(LDCR,*), + $ D(LDD,*), DR(LDDR,*), DWORK(*) +C .. Local Scalars .. + LOGICAL DISCR + INTEGER I, IB, IB1, J, K, KFI, KV, KW, KWI, KWR, KZ, L, + $ L1, NB, NCUR, NFP, NLOW, NSUP + DOUBLE PRECISION ALPHA, BNORM, CS, PR, RMAX, SM, SN, TOLER, + $ WRKOPT, X, Y +C .. Local Arrays .. + DOUBLE PRECISION Z(4,4) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE + LOGICAL LSAME + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLAEXC, DLANV2, DLASET, DROT, + $ DTRMM, DTRMV, SB01FY, TB01LD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDCR.LT.MAX( 1, M ) ) THEN + INFO = -16 + ELSE IF( LDDR.LT.MAX( 1, M ) ) THEN + INFO = -18 + ELSE IF( LDWORK.LT.MAX( 1, N*(N+5), M*(M+2), 4*M, 4*P ) ) THEN + INFO = -21 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'SB08DD', -INFO ) + RETURN + END IF +C +C Set DR = I and quick return if possible. +C + NR = 0 + IF( MIN( M, P ).GT.0 ) + $ CALL DLASET( 'Full', M, M, ZERO, ONE, DR, LDDR ) + IF( MIN( N, M ).EQ.0 ) THEN + NQ = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Set F = 0 in the array CR. +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, CR, LDCR ) +C +C Compute the norm of B and set the default tolerance if necessary. +C + BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) + TOLER = TOL + IF( TOLER.LE.ZERO ) + $ TOLER = DBLE( N ) * BNORM * DLAMCH( 'Epsilon' ) + IF( BNORM.LE.TOLER ) THEN + NQ = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Compute the bound for the numerical stability condition. +C + RMAX = TEN * DLANGE( '1-norm', N, N, A, LDA, DWORK ) / BNORM +C +C Allocate working storage. +C + KZ = 1 + KWR = KZ + N*N + KWI = KWR + N + KW = KWI + N +C +C Reduce A to an ordered real Schur form using an orthogonal +C similarity transformation A <- Z'*A*Z and accumulate the +C transformations in Z. The separation of spectrum of A is +C performed such that the leading NFP-by-NFP submatrix of A +C corresponds to the "stable" eigenvalues which will be not +C modified. The bottom (N-NFP)-by-(N-NFP) diagonal block of A +C corresponds to the "unstable" eigenvalues to be modified. +C Apply the transformation to B and C: B <- Z'*B and C <- C*Z. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + IF( DISCR ) THEN + ALPHA = ONE + ELSE + ALPHA = ZERO + END IF + CALL TB01LD( DICO, 'Stable', 'General', N, M, P, ALPHA, A, LDA, + $ B, LDB, C, LDC, NFP, DWORK(KZ), N, DWORK(KWR), + $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, INFO ) + IF( INFO.NE.0 ) + $ RETURN +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C +C Perform the pole assignment if there exist "unstable" eigenvalues. +C + NQ = N + IF( NFP.LT.N ) THEN + KV = 1 + KFI = KV + M*M + KW = KFI + 2*M +C +C Set the limits for the bottom diagonal block. +C + NLOW = NFP + 1 + NSUP = N +C +C WHILE (NLOW <= NSUP) DO + 10 IF( NLOW.LE.NSUP ) THEN +C +C Main loop for assigning one or two poles. +C +C Determine the dimension of the last block. +C + IB = 1 + IF( NLOW.LT.NSUP ) THEN + IF( A(NSUP,NSUP-1).NE.ZERO ) IB = 2 + END IF + L = NSUP - IB + 1 +C +C Check the controllability of the last block. +C + IF( DLANGE( '1-norm', IB, M, B(L,1), LDB, DWORK(KW) ) + $ .LE.TOLER ) THEN +C +C Deflate the uncontrollable block and resume the main +C loop. +C + NSUP = NSUP - IB + ELSE +C +C Determine the M-by-IB feedback matrix FI which assigns +C the selected IB poles for the pair +C ( A(L:L+IB-1,L:L+IB-1), B(L:L+IB-1,1:M) ). +C +C Workspace needed: M*(M+2). +C + CALL SB01FY( DISCR, IB, M, A(L,L), LDA, B(L,1), LDB, + $ DWORK(KFI), M, DWORK(KV), M, INFO ) + IF( INFO.EQ.2 ) THEN + INFO = 3 + RETURN + END IF +C +C Check for possible numerical instability. +C + IF( DLANGE( '1-norm', M, IB, DWORK(KFI), M, DWORK(KW) ) + $ .GT.RMAX ) IWARN = IWARN + 1 +C +C Update the state matrix A <-- A + B*[0 FI]. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NSUP, IB, M, + $ ONE, B, LDB, DWORK(KFI), M, ONE, A(1,L), + $ LDA ) +C +C Update the feedback matrix F <-- F + V*[0 FI] in CR. +C + IF( DISCR ) + $ CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', + $ M, IB, ONE, DR, LDDR, DWORK(KFI), M ) + K = KFI + DO 30 J = L, L + IB - 1 + DO 20 I = 1, M + CR(I,J) = CR(I,J) + DWORK(K) + K = K + 1 + 20 CONTINUE + 30 CONTINUE +C + IF( DISCR ) THEN +C +C Update the input matrix B <-- B*V. +C + CALL DTRMM( 'Right', 'Upper', 'NoTranspose', + $ 'NonUnit', N, M, ONE, DWORK(KV), M, B, + $ LDB ) +C +C Update the feedthrough matrix DR <-- DR*V. +C + K = KV + DO 40 I = 1, M + CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', + $ M-I+1, DWORK(K), M, DR(I,I), LDDR ) + K = K + M + 1 + 40 CONTINUE + END IF +C + IF( IB.EQ.2 ) THEN +C +C Put the 2x2 block in a standard form. +C + L1 = L + 1 + CALL DLANV2( A(L,L), A(L,L1), A(L1,L), A(L1,L1), + $ X, Y, PR, SM, CS, SN ) +C +C Apply the transformation to A, B, C and F. +C + IF( L1.LT.NSUP ) + $ CALL DROT( NSUP-L1, A(L,L1+1), LDA, A(L1,L1+1), + $ LDA, CS, SN ) + CALL DROT( L-1, A(1,L), 1, A(1,L1), 1, CS, SN ) + CALL DROT( M, B(L,1), LDB, B(L1,1), LDB, CS, SN ) + IF( P.GT.0 ) + $ CALL DROT( P, C(1,L), 1, C(1,L1), 1, CS, SN ) + CALL DROT( M, CR(1,L), 1, CR(1,L1), 1, CS, SN ) + END IF + IF( NLOW+IB.LE.NSUP ) THEN +C +C Move the last block(s) to the leading position(s) of +C the bottom block. +C +C Workspace: need MAX(4*N, 4*M, 4*P). +C + NCUR = NSUP - IB +C WHILE (NCUR >= NLOW) DO + 50 IF( NCUR.GE.NLOW ) THEN +C +C Loop for positioning of the last block. +C +C Determine the dimension of the current block. +C + IB1 = 1 + IF( NCUR.GT.NLOW ) THEN + IF( A(NCUR,NCUR-1).NE.ZERO ) IB1 = 2 + END IF + NB = IB1 + IB +C +C Initialize the local transformation matrix Z. +C + CALL DLASET( 'Full', NB, NB, ZERO, ONE, Z, 4 ) + L = NCUR - IB1 + 1 +C +C Exchange two adjacent blocks and accumulate the +C transformations in Z. +C + CALL DLAEXC( .TRUE., NB, A(L,L), LDA, Z, 4, 1, IB1, + $ IB, DWORK, INFO ) + IF( INFO.NE.0 ) THEN + INFO = 2 + RETURN + END IF +C +C Apply the transformation to the rest of A. +C + L1 = L + NB + IF( L1.LE.NSUP ) THEN + CALL DGEMM( 'Transpose', 'NoTranspose', NB, + $ NSUP-L1+1, NB, ONE, Z, 4, A(L,L1), + $ LDA, ZERO, DWORK, NB ) + CALL DLACPY( 'Full', NB, NSUP-L1+1, DWORK, NB, + $ A(L,L1), LDA ) + END IF + CALL DGEMM( 'NoTranspose', 'NoTranspose', L-1, NB, + $ NB, ONE, A(1,L), LDA, Z, 4, ZERO, + $ DWORK, N ) + CALL DLACPY( 'Full', L-1, NB, DWORK, N, A(1,L), + $ LDA ) +C +C Apply the transformation to B, C and F. +C + CALL DGEMM( 'Transpose', 'NoTranspose', NB, M, NB, + $ ONE, Z, 4, B(L,1), LDB, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'Full', NB, M, DWORK, NB, B(L,1), + $ LDB ) +C + IF( P.GT.0 ) THEN + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NB, + $ NB, ONE, C(1,L), LDC, Z, 4, ZERO, + $ DWORK, P ) + CALL DLACPY( 'Full', P, NB, DWORK, P, + $ C(1,L), LDC ) + END IF +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, NB, + $ NB, ONE, CR(1,L), LDCR, Z, 4, ZERO, + $ DWORK, M ) + CALL DLACPY( 'Full', M, NB, DWORK, M, CR(1,L), + $ LDCR ) +C + NCUR = NCUR - IB1 + GO TO 50 + END IF +C END WHILE 50 +C + END IF + NLOW = NLOW + IB + END IF + GO TO 10 + END IF +C END WHILE 10 +C + NQ = NSUP + NR = NSUP - NFP +C +C Annihilate the elements below the first subdiagonal of A. +C + IF( NQ.GT.2 ) + $ CALL DLASET( 'Lower', NQ-2, NQ-2, ZERO, ZERO, A(3,1), LDA ) + END IF +C +C Compute C <-- CQ = C + D*F and D <-- DQ = D*DR. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NQ, M, ONE, D, LDD, + $ CR, LDCR, ONE, C, LDC ) + IF( DISCR ) + $ CALL DTRMM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', P, M, + $ ONE, DR, LDDR, D, LDD ) +C + DWORK(1) = MAX( WRKOPT, DBLE( MAX( M*(M+2), 4*M, 4*P ) ) ) +C + RETURN +C *** Last line of SB08DD *** + END diff --git a/mex/sources/libslicot/SB08ED.f b/mex/sources/libslicot/SB08ED.f new file mode 100644 index 000000000..b171c4a16 --- /dev/null +++ b/mex/sources/libslicot/SB08ED.f @@ -0,0 +1,359 @@ + SUBROUTINE SB08ED( DICO, N, M, P, ALPHA, A, LDA, B, LDB, C, LDC, + $ D, LDD, NQ, NR, BR, LDBR, DR, LDDR, TOL, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct, for a given system G = (A,B,C,D), an output +C injection matrix H and an orthogonal transformation matrix Z, such +C that the systems +C +C Q = (Z'*(A+H*C)*Z, Z'*(B+H*D), C*Z, D) +C and +C R = (Z'*(A+H*C)*Z, Z'*H, C*Z, I) +C +C provide a stable left coprime factorization of G in the form +C -1 +C G = R * Q, +C +C where G, Q and R are the corresponding transfer-function matrices. +C The resulting state dynamics matrix of the systems Q and R has +C eigenvalues lying inside a given stability domain. +C The Z matrix is not explicitly computed. +C +C Note: If the given state-space representation is not detectable, +C the undetectable part of the original system is automatically +C deflated and the order of the systems Q and R is accordingly +C reduced. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the state vector, i.e. the order of the +C matrix A, and also the number of rows of the matrices B +C and BR, and the number of columns of the matrix C. +C N >= 0. +C +C M (input) INTEGER +C The dimension of input vector, i.e. the number of columns +C of the matrices B and D. M >= 0. +C +C P (input) INTEGER +C The dimension of output vector, i.e. the number of rows +C of the matrices C, D and DR, and the number of columns of +C the matrices BR and DR. P >= 0. +C +C ALPHA (input) DOUBLE PRECISION array, dimension (2) +C ALPHA(1) contains the desired stability degree to be +C assigned for the eigenvalues of A+H*C, and ALPHA(2) +C the stability margin. The eigenvalues outside the +C ALPHA(2)-stability region will be assigned to have the +C real parts equal to ALPHA(1) < 0 and unmodified +C imaginary parts for a continuous-time system +C (DICO = 'C'), or moduli equal to 0 <= ALPHA(2) < 1 +C for a discrete-time system (DICO = 'D'). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading NQ-by-NQ part of this array contains +C the leading NQ-by-NQ part of the matrix Z'*(A+H*C)*Z, the +C state dynamics matrix of the numerator factor Q, in a +C real Schur form. The leading NR-by-NR part of this matrix +C represents the state dynamics matrix of a minimal +C realization of the denominator factor R. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,MAX(M,P)) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix of the system. +C On exit, the leading NQ-by-M part of this array contains +C the leading NQ-by-M part of the matrix Z'*(B+H*D), the +C input/state matrix of the numerator factor Q. +C The remaining part of this array is needed as workspace. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix of the system. +C On exit, the leading P-by-NQ part of this array contains +C the leading P-by-NQ part of the matrix C*Z, the +C state/output matrix of the numerator factor Q. +C The first NR columns of this array represent the +C state/output matrix of a minimal realization of the +C denominator factor R. +C The remaining part of this array is needed as workspace. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,M,P), if N > 0. +C LDC >= 1, if N = 0. +C +C D (input) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) +C The leading P-by-M part of this array must contain the +C input/output matrix. D represents also the input/output +C matrix of the numerator factor Q. +C This array is modified internally, but restored on exit. +C The remaining part of this array is needed as workspace. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,M,P). +C +C NQ (output) INTEGER +C The order of the resulting factors Q and R. +C Generally, NQ = N - NS, where NS is the number of +C unobservable eigenvalues outside the stability region. +C +C NR (output) INTEGER +C The order of the minimal realization of the factor R. +C Generally, NR is the number of observable eigenvalues +C of A outside the stability region (the number of modified +C eigenvalues). +C +C BR (output) DOUBLE PRECISION array, dimension (LDBR,P) +C The leading NQ-by-P part of this array contains the +C leading NQ-by-P part of the output injection matrix +C Z'*H, which moves the eigenvalues of A lying outside +C the ALPHA-stable region to values on the ALPHA-stability +C boundary. The first NR rows of this matrix form the +C input/state matrix of a minimal realization of the +C denominator factor R. +C +C LDBR INTEGER +C The leading dimension of array BR. LDBR >= MAX(1,N). +C +C DR (output) DOUBLE PRECISION array, dimension (LDDR,P) +C The leading P-by-P part of this array contains an +C identity matrix representing the input/output matrix +C of the denominator factor R. +C +C LDDR INTEGER +C The leading dimension of array DR. LDDR >= MAX(1,P). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The absolute tolerance level below which the elements of +C C are considered zero (used for observability tests). +C If the user sets TOL <= 0, then an implicitly computed, +C default tolerance, defined by TOLDEF = N*EPS*NORM(C), +C is used instead, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH) and NORM(C) denotes +C the infinity-norm of C. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LDWORK >= MAX( 1, N*P + MAX( N*(N+5), 5*P, 4*M ) ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = K: K violations of the numerical stability condition +C NORM(H) <= 10*NORM(A)/NORM(C) occured during the +C assignment of eigenvalues. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the ordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + H*C)*Z +C along the diagonal. +C +C METHOD +C +C The subroutine uses the right coprime factorization algorithm +C of [1] applied to G'. +C +C REFERENCES +C +C [1] Varga A. +C Coprime factors model reduction method based on +C square-root balancing-free techniques. +C System Analysis, Modelling and Simulation, +C vol. 11, pp. 303-311, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires no more than 14N floating point +C operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine LCFS. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C May 2003, A. Varga, DLR Oberpfaffenhofen. +C Nov 2003, A. Varga, DLR Oberpfaffenhofen. +C Sep. 2005, A. Varga, German Aerospace Center. +C +C KEYWORDS +C +C Coprime factorization, eigenvalue, eigenvalue assignment, +C feedback control, pole placement, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO + INTEGER INFO, IWARN, LDA, LDB, LDBR, LDC, LDD, LDDR, + $ LDWORK, M, N, NQ, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ALPHA(*), B(LDB,*), BR(LDBR,*), + $ C(LDC,*), D(LDD,*), DR(LDDR,*), DWORK(*) +C .. Local Scalars .. + LOGICAL DISCR + INTEGER KBR, KW +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External subroutines .. + EXTERNAL AB07MD, DLASET, MA02AD, MA02BD, SB08FD, TB01XD, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT.( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( ( DISCR .AND. ( ALPHA(1).LT.ZERO .OR. ALPHA(1).GE.ONE + $ .OR. ALPHA(2).LT.ZERO .OR. ALPHA(2).GE.ONE ) ) + $ .OR. + $ ( .NOT.DISCR .AND. ( ALPHA(1).GE.ZERO .OR. ALPHA(2).GE.ZERO ) + $ ) ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAX( M, P ) ) ) + $ THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, M, P ) ) THEN + INFO = -13 + ELSE IF( LDBR.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDDR.LT.MAX( 1, P ) ) THEN + INFO = -19 + ELSE IF( LDWORK.LT.MAX( 1, N*P + MAX( N*(N+5), 5*P, 4*M ) ) ) THEN + INFO = -22 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'SB08ED', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, P ).EQ.0 ) THEN + NQ = 0 + NR = 0 + DWORK(1) = ONE + CALL DLASET( 'Full', P, P, ZERO, ONE, DR, LDDR ) + RETURN + END IF +C +C Compute the dual system G' = (A',C',B',D'). +C + CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ INFO ) +C +C Compute the right coprime factorization of G' with +C prescribed stability degree. +C +C Workspace needed: P*N; +C Additional workspace: need MAX( N*(N+5), 5*P, 4*M ); +C prefer larger. +C + KBR = 1 + KW = KBR + P*N + CALL SB08FD( DICO, N, P, M, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD, + $ NQ, NR, DWORK(KBR), P, DR, LDDR, TOL, DWORK(KW), + $ LDWORK-KW+1, IWARN, INFO ) + IF( INFO.EQ.0 ) THEN +C +C Determine the elements of the left coprime factorization from +C those of the computed right coprime factorization and make the +C state-matrix upper real Schur. +C + CALL TB01XD( 'D', NQ, P, M, MAX( 0, NQ-1 ), MAX( 0, NQ-1 ), + $ A, LDA, B, LDB, C, LDC, D, LDD, INFO ) +C + CALL MA02AD( 'Full', P, NQ, DWORK(KBR), P, BR, LDBR ) + CALL MA02BD( 'Left', NQ, P, BR, LDBR ) +C + END IF +C + DWORK(1) = DWORK(KW) + DBLE( KW-1 ) +C + RETURN +C *** Last line of SB08ED *** + END diff --git a/mex/sources/libslicot/SB08FD.f b/mex/sources/libslicot/SB08FD.f new file mode 100644 index 000000000..54a21b1d9 --- /dev/null +++ b/mex/sources/libslicot/SB08FD.f @@ -0,0 +1,630 @@ + SUBROUTINE SB08FD( DICO, N, M, P, ALPHA, A, LDA, B, LDB, C, LDC, + $ D, LDD, NQ, NR, CR, LDCR, DR, LDDR, TOL, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct, for a given system G = (A,B,C,D), a feedback +C matrix F and an orthogonal transformation matrix Z, such that +C the systems +C +C Q = (Z'*(A+B*F)*Z, Z'*B, (C+D*F)*Z, D) +C and +C R = (Z'*(A+B*F)*Z, Z'*B, F*Z, I) +C +C provide a stable right coprime factorization of G in the form +C -1 +C G = Q * R , +C +C where G, Q and R are the corresponding transfer-function matrices. +C The resulting state dynamics matrix of the systems Q and R has +C eigenvalues lying inside a given stability domain. +C The Z matrix is not explicitly computed. +C +C Note: If the given state-space representation is not stabilizable, +C the unstabilizable part of the original system is automatically +C deflated and the order of the systems Q and R is accordingly +C reduced. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the state vector, i.e. the order of the +C matrix A, and also the number of rows of the matrix B and +C the number of columns of the matrices C and CR. N >= 0. +C +C M (input) INTEGER +C The dimension of input vector, i.e. the number of columns +C of the matrices B, D and DR and the number of rows of the +C matrices CR and DR. M >= 0. +C +C P (input) INTEGER +C The dimension of output vector, i.e. the number of rows +C of the matrices C and D. P >= 0. +C +C ALPHA (input) DOUBLE PRECISION array, dimension (2) +C ALPHA(1) contains the desired stability degree to be +C assigned for the eigenvalues of A+B*F, and ALPHA(2) +C the stability margin. The eigenvalues outside the +C ALPHA(2)-stability region will be assigned to have the +C real parts equal to ALPHA(1) < 0 and unmodified +C imaginary parts for a continuous-time system +C (DICO = 'C'), or moduli equal to 0 <= ALPHA(2) < 1 +C for a discrete-time system (DICO = 'D'). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading NQ-by-NQ part of this array contains +C the leading NQ-by-NQ part of the matrix Z'*(A+B*F)*Z, the +C state dynamics matrix of the numerator factor Q, in a +C real Schur form. The trailing NR-by-NR part of this matrix +C represents the state dynamics matrix of a minimal +C realization of the denominator factor R. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix. +C On exit, the leading NQ-by-M part of this array contains +C the leading NQ-by-M part of the matrix Z'*B, the +C input/state matrix of the numerator factor Q. The last +C NR rows of this matrix form the input/state matrix of +C a minimal realization of the denominator factor R. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-NQ part of this array contains +C the leading P-by-NQ part of the matrix (C+D*F)*Z, +C the state/output matrix of the numerator factor Q. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C input/output matrix. D represents also the input/output +C matrix of the numerator factor Q. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NQ (output) INTEGER +C The order of the resulting factors Q and R. +C Generally, NQ = N - NS, where NS is the number of +C uncontrollable eigenvalues outside the stability region. +C +C NR (output) INTEGER +C The order of the minimal realization of the factor R. +C Generally, NR is the number of controllable eigenvalues +C of A outside the stability region (the number of modified +C eigenvalues). +C +C CR (output) DOUBLE PRECISION array, dimension (LDCR,N) +C The leading M-by-NQ part of this array contains the +C leading M-by-NQ part of the feedback matrix F*Z, which +C moves the eigenvalues of A lying outside the ALPHA-stable +C region to values which are on the ALPHA-stability +C boundary. The last NR columns of this matrix form the +C state/output matrix of a minimal realization of the +C denominator factor R. +C +C LDCR INTEGER +C The leading dimension of array CR. LDCR >= MAX(1,M). +C +C DR (output) DOUBLE PRECISION array, dimension (LDDR,M) +C The leading M-by-M part of this array contains an +C identity matrix representing the input/output matrix +C of the denominator factor R. +C +C LDDR INTEGER +C The leading dimension of array DR. LDDR >= MAX(1,M). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The absolute tolerance level below which the elements of +C B are considered zero (used for controllability tests). +C If the user sets TOL <= 0, then an implicitly computed, +C default tolerance, defined by TOLDEF = N*EPS*NORM(B), +C is used instead, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH) and NORM(B) denotes +C the 1-norm of B. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LWORK >= MAX( 1, N*(N+5), 5*M, 4*P ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = K: K violations of the numerical stability condition +C NORM(F) <= 10*NORM(A)/NORM(B) occured during the +C assignment of eigenvalues. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the ordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + B*F)*Z +C along the diagonal. +C +C METHOD +C +C The subroutine is based on the factorization algorithm of [1]. +C +C REFERENCES +C +C [1] Varga A. +C Coprime factors model reduction method based on +C square-root balancing-free techniques. +C System Analysis, Modelling and Simulation, +C vol. 11, pp. 303-311, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires no more than 14N floating point +C operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine RCFS. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C Mar. 2003, May 2003, A. Varga, German Aerospace Center. +C May 2003, V. Sima, Research Institute for Informatics, Bucharest. +C Sep. 2005, A. Varga, German Aerospace Center. +C +C KEYWORDS +C +C Coprime factorization, eigenvalue, eigenvalue assignment, +C feedback control, pole placement, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TEN, ZERO + PARAMETER ( ONE = 1.0D0, TEN = 1.0D1, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO + INTEGER INFO, IWARN, LDA, LDB, LDC, LDCR, LDD, LDDR, + $ LDWORK, M, N, NQ, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ALPHA(*), B(LDB,*), C(LDC,*), + $ CR(LDCR,*), D(LDD,*), DR(LDDR,*), DWORK(*) +C .. Local Scalars .. + LOGICAL DISCR + INTEGER I, IB, IB1, J, K, KFI, KG, KW, KWI, KWR, KZ, L, + $ L1, NB, NCUR, NCUR1, NFP, NLOW, NMOVES, NSUP + DOUBLE PRECISION BNORM, CS, PR, RMAX, SM, SN, TOLER, WRKOPT, X, Y +C .. Local Arrays .. + DOUBLE PRECISION A2(2,2), Z(4,4) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 + LOGICAL LSAME + EXTERNAL DLAMCH, DLANGE, DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLAEXC, DLANV2, DLASET, DROT, + $ SB01BY, TB01LD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT +C +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( ( DISCR .AND. ( ALPHA(1).LT.ZERO .OR. ALPHA(1).GE.ONE + $ .OR. ALPHA(2).LT.ZERO .OR. ALPHA(2).GE.ONE ) ) + $ .OR. + $ ( .NOT.DISCR .AND. ( ALPHA(1).GE.ZERO .OR. ALPHA(2).GE.ZERO ) + $ ) ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDCR.LT.MAX( 1, M ) ) THEN + INFO = -17 + ELSE IF( LDDR.LT.MAX( 1, M ) ) THEN + INFO = -19 + ELSE IF( LDWORK.LT.MAX( 1, N*(N+5), 5*M, 4*P ) ) THEN + INFO = -22 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'SB08FD', -INFO ) + RETURN + END IF +C +C Set DR = I and quick return if possible. +C + NR = 0 + CALL DLASET( 'Full', M, M, ZERO, ONE, DR, LDDR ) + IF( MIN( N, M ).EQ.0 ) THEN + NQ = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Set F = 0 in the array CR. +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, CR, LDCR ) +C +C Compute the norm of B and set the default tolerance if necessary. +C + BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) + TOLER = TOL + IF( TOLER.LE.ZERO ) + $ TOLER = DBLE( N ) * BNORM * DLAMCH( 'Epsilon' ) + IF( BNORM.LE.TOLER ) THEN + NQ = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Compute the bound for the numerical stability condition. +C + RMAX = TEN * DLANGE( '1-norm', N, N, A, LDA, DWORK ) / BNORM +C +C Allocate working storage. +C + KZ = 1 + KWR = KZ + N*N + KWI = KWR + N + KW = KWI + N +C +C Reduce A to an ordered real Schur form using an orthogonal +C similarity transformation A <- Z'*A*Z and accumulate the +C transformations in Z. The separation of spectrum of A is +C performed such that the leading NFP-by-NFP submatrix of A +C corresponds to the "stable" eigenvalues which will be not +C modified. The bottom (N-NFP)-by-(N-NFP) diagonal block of A +C corresponds to the "unstable" eigenvalues to be modified. +C Apply the transformation to B and C: B <- Z'*B and C <- C*Z. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01LD( DICO, 'Stable', 'General', N, M, P, ALPHA(2), A, LDA, + $ B, LDB, C, LDC, NFP, DWORK(KZ), N, DWORK(KWR), + $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, INFO ) + IF( INFO.NE.0 ) + $ RETURN +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C +C Perform the pole assignment if there exist "unstable" eigenvalues. +C + NQ = N + IF( NFP.LT.N ) THEN + KG = 1 + KFI = KG + 2*M + KW = KFI + 2*M +C +C Set the limits for the bottom diagonal block. +C + NLOW = NFP + 1 + NSUP = N +C +C WHILE (NLOW <= NSUP) DO + 10 IF( NLOW.LE.NSUP ) THEN +C +C Main loop for assigning one or two poles. +C +C Determine the dimension of the last block. +C + IB = 1 + IF( NLOW.LT.NSUP ) THEN + IF( A(NSUP,NSUP-1).NE.ZERO ) IB = 2 + END IF + L = NSUP - IB + 1 +C +C Save the last IB rows of B in G. +C + CALL DLACPY( 'Full', IB, M, B(L,1), LDB, DWORK(KG), IB ) +C +C Check the controllability of the last block. +C + IF( DLANGE( '1-norm', IB, M, DWORK(KG), IB, DWORK(KW) ) + $ .LE.TOLER )THEN +C +C Deflate the uncontrollable block and resume the +C main loop. +C + NSUP = NSUP - IB + ELSE +C +C Form the IBxIB matrix A2 from the last diagonal block and +C set the pole(s) to be assigned. +C + A2(1,1) = A(L,L) + IF( IB.EQ.1 ) THEN + SM = ALPHA(1) + IF( DISCR ) SM = SIGN( ALPHA(1), A2(1,1) ) + PR = ALPHA(1) + ELSE + A2(1,2) = A(L,NSUP) + A2(2,1) = A(NSUP,L) + A2(2,2) = A(NSUP,NSUP) + SM = ALPHA(1) + ALPHA(1) + PR = ALPHA(1)*ALPHA(1) + IF( DISCR ) THEN + X = A2(1,1) + Y = SQRT( ABS( A2(1,2)*A2(2,1) ) ) + SM = SM * X / DLAPY2( X, Y ) + ELSE + PR = PR - A2(1,2)*A2(2,1) + END IF + END IF +C +C Determine the M-by-IB feedback matrix FI which assigns +C the selected IB poles for the pair (A2,G). +C +C Workspace needed: 5*M. +C + CALL SB01BY( IB, M, SM, PR, A2, DWORK(KG), DWORK(KFI), + $ TOLER, DWORK(KW), INFO ) + IF( INFO.NE.0 ) THEN +C +C Uncontrollable 2x2 block with double real eigenvalues +C which due to roundoff appear as a pair of complex +C conjugated eigenvalues. +C One of them can be elliminated using the information +C in DWORK(KFI) and DWORK(KFI+M). +C + CS = DWORK(KFI) + SN = -DWORK(KFI+M) +C +C Apply the Givens transformation to A, B, C and F. +C + L1 = L + 1 + CALL DROT( NSUP-L+1, A(L1,L), LDA, A(L,L), + $ LDA, CS, SN ) + CALL DROT( L1, A(1,L1), 1, A(1,L), 1, CS, SN ) + CALL DROT( M, B(L1,1), LDB, B(L,1), LDB, CS, SN ) + IF( P.GT.0 ) + $ CALL DROT( P, C(1,L1), 1, C(1,L), 1, CS, SN ) + CALL DROT( M, CR(1,L1), 1, CR(1,L), 1, CS, SN ) +C +C Deflate the uncontrollable block and resume the +C main loop. +C + A(L1,L) = ZERO + NSUP = NSUP - 1 + INFO = 0 + GO TO 10 + END IF +C +C Check for possible numerical instability. +C + IF( DLANGE( '1-norm', M, IB, DWORK(KFI), M, DWORK(KW) ) + $ .GT.RMAX ) IWARN = IWARN + 1 +C +C Update the feedback matrix F <-- F + [0 FI] in CR. +C + K = KFI + DO 30 J = L, L + IB - 1 + DO 20 I = 1, M + CR(I,J) = CR(I,J) + DWORK(K) + K = K + 1 + 20 CONTINUE + 30 CONTINUE +C +C Update the state matrix A <-- A + B*[0 FI]. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NSUP, IB, M, + $ ONE, B, LDB, DWORK(KFI), M, ONE, A(1,L), + $ LDA ) + IF( IB.EQ.2 ) THEN +C +C Try to split the 2x2 block and standardize it. +C + L1 = L + 1 + CALL DLANV2( A(L,L), A(L,L1), A(L1,L), A(L1,L1), + $ X, Y, PR, SM, CS, SN ) +C +C Apply the transformation to A, B, C and F. +C + IF( L1.LT.NSUP ) + $ CALL DROT( NSUP-L1, A(L,L1+1), LDA, A(L1,L1+1), + $ LDA, CS, SN ) + CALL DROT( L-1, A(1,L), 1, A(1,L1), 1, CS, SN ) + CALL DROT( M, B(L,1), LDB, B(L1,1), LDB, CS, SN ) + IF( P.GT.0 ) + $ CALL DROT( P, C(1,L), 1, C(1,L1), 1, CS, SN ) + CALL DROT( M, CR(1,L), 1, CR(1,L1), 1, CS, SN ) + END IF + IF( NLOW+IB.LE.NSUP ) THEN +C +C Move the last block(s) to the leading position(s) of +C the bottom block. +C +C Workspace: need MAX(4*N, 4*M, 4*P). +C + NCUR1 = NSUP - IB + NMOVES = 1 + IF( IB.EQ.2 .AND. A(NSUP,NSUP-1).EQ.ZERO ) THEN + IB = 1 + NMOVES = 2 + END IF +C +C WHILE (NMOVES > 0) DO + 40 IF( NMOVES.GT.0 ) THEN + NCUR = NCUR1 +C +C WHILE (NCUR >= NLOW) DO + 50 IF( NCUR.GE.NLOW ) THEN +C +C Loop for positioning of the last block. +C +C Determine the dimension of the current block. +C + IB1 = 1 + IF( NCUR.GT.NLOW ) THEN + IF( A(NCUR,NCUR-1).NE.ZERO ) IB1 = 2 + END IF + NB = IB1 + IB +C +C Initialize the local transformation matrix Z. +C + CALL DLASET( 'Full', NB, NB, ZERO, ONE, Z, 4 ) + L = NCUR - IB1 + 1 +C +C Exchange two adjacent blocks and accumulate the +C transformations in Z. +C + CALL DLAEXC( .TRUE., NB, A(L,L), LDA, Z, 4, 1, + $ IB1, IB, DWORK, INFO ) + IF( INFO.NE.0 ) THEN + INFO = 2 + RETURN + END IF +C +C Apply the transformation to the rest of A. +C + L1 = L + NB + IF( L1.LE.NSUP ) THEN + CALL DGEMM( 'Transpose', 'NoTranspose', NB, + $ NSUP-L1+1, NB, ONE, Z, 4, + $ A(L,L1), LDA, ZERO, DWORK, NB ) + CALL DLACPY( 'Full', NB, NSUP-L1+1, DWORK, + $ NB, A(L,L1), LDA ) + END IF + CALL DGEMM( 'NoTranspose', 'NoTranspose', L-1, + $ NB, NB, ONE, A(1,L), LDA, Z, 4, + $ ZERO, DWORK, N ) + CALL DLACPY( 'Full', L-1, NB, DWORK, N, A(1,L), + $ LDA ) +C +C Apply the transformation to B, C and F. +C + CALL DGEMM( 'Transpose', 'NoTranspose', NB, M, + $ NB, ONE, Z, 4, B(L,1), LDB, ZERO, + $ DWORK, NB ) + CALL DLACPY( 'Full', NB, M, DWORK, NB, B(L,1), + $ LDB ) +C + IF( P.GT.0 ) THEN + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, + $ NB, NB, ONE, C(1,L), LDC, Z, 4, + $ ZERO, DWORK, P ) + CALL DLACPY( 'Full', P, NB, DWORK, P, + $ C(1,L), LDC ) + END IF +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, NB, + $ NB, ONE, CR(1,L), LDCR, Z, 4, ZERO, + $ DWORK, M ) + CALL DLACPY( 'Full', M, NB, DWORK, M, CR(1,L), + $ LDCR ) +C + NCUR = NCUR - IB1 + GO TO 50 + END IF +C END WHILE 50 +C + NMOVES = NMOVES - 1 + NCUR1 = NCUR1 + 1 + NLOW = NLOW + IB + GO TO 40 + END IF +C END WHILE 40 +C + ELSE + NLOW = NLOW + IB + END IF + END IF + GO TO 10 + END IF +C END WHILE 10 +C + NQ = NSUP + NR = NSUP - NFP +C +C Annihilate the elements below the first subdiagonal of A. +C + IF( NQ.GT.2 ) + $ CALL DLASET( 'Lower', NQ-2, NQ-2, ZERO, ZERO, A(3,1), LDA ) + END IF +C +C Compute C <-- CQ = C + D*F. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NQ, M, ONE, D, LDD, + $ CR, LDCR, ONE, C, LDC ) +C + DWORK(1) = MAX( WRKOPT, DBLE( MAX( 5*M, 4*P ) ) ) +C + RETURN +C *** Last line of SB08FD *** + END diff --git a/mex/sources/libslicot/SB08GD.f b/mex/sources/libslicot/SB08GD.f new file mode 100644 index 000000000..0368fdf78 --- /dev/null +++ b/mex/sources/libslicot/SB08GD.f @@ -0,0 +1,256 @@ + SUBROUTINE SB08GD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, BR, + $ LDBR, DR, LDDR, IWORK, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the state-space representation for the system +C G = (A,B,C,D) from the factors Q = (AQR,BQ,CQR,DQ) and +C R = (AQR,BR,CQR,DR) of its left coprime factorization +C -1 +C G = R * Q, +C +C where G, Q and R are the corresponding transfer-function matrices. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. Also the number of rows of the +C matrices B and BR and the number of columns of the matrix +C C. N represents the order of the systems Q and R. N >= 0. +C +C M (input) INTEGER +C The dimension of input vector, i.e. the number of columns +C of the matrices B and D. M >= 0. +C +C P (input) INTEGER +C The dimension of output vector, i.e. the number of rows of +C the matrices C, D and DR and the number of columns of the +C matrices BR and DR. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix AQR of the systems +C Q and R. +C On exit, the leading N-by-N part of this array contains +C the state dynamics matrix of the system G. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix BQ of the system Q. +C On exit, the leading N-by-M part of this array contains +C the input/state matrix of the system G. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix CQR of the systems +C Q and R. +C On exit, the leading P-by-N part of this array contains +C the state/output matrix of the system G. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the input/output matrix DQ of the system Q. +C On exit, the leading P-by-M part of this array contains +C the input/output matrix of the system G. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C BR (input) DOUBLE PRECISION array, dimension (LDBR,P) +C The leading N-by-P part of this array must contain the +C input/state matrix BR of the system R. +C +C LDBR INTEGER +C The leading dimension of array BR. LDBR >= MAX(1,N). +C +C DR (input/output) DOUBLE PRECISION array, dimension (LDDR,P) +C On entry, the leading P-by-P part of this array must +C contain the input/output matrix DR of the system R. +C On exit, the leading P-by-P part of this array contains +C the LU factorization of the matrix DR, as computed by +C LAPACK Library routine DGETRF. +C +C LDDR INTEGER +C The leading dimension of array DR. LDDR >= MAX(1,P). +C +C Workspace +C +C IWORK INTEGER array, dimension (P) +C +C DWORK DOUBLE PRECISION array, dimension (MAX(1,4*P)) +C On exit, DWORK(1) contains an estimate of the reciprocal +C condition number of the matrix DR. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the matrix DR is singular; +C = 2: the matrix DR is numerically singular (warning); +C the calculations continued. +C +C METHOD +C +C The subroutine computes the matrices of the state-space +C representation G = (A,B,C,D) by using the formulas: +C +C -1 -1 +C A = AQR - BR * DR * CQR, C = DR * CQR, +C -1 -1 +C B = BQ - BR * DR * DQ, D = DR * DQ. +C +C REFERENCES +C +C [1] Varga A. +C Coprime factors model reduction method based on +C square-root balancing-free techniques. +C System Analysis, Modelling and Simulation, +C vol. 11, pp. 303-311, 1993. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine LCFI. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C +C KEYWORDS +C +C Coprime factorization, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDBR, LDC, LDD, LDDR, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), BR(LDBR,*), C(LDC,*), + $ D(LDD,*), DR(LDDR,*), DWORK(*) + INTEGER IWORK(*) +C .. Local Scalars + DOUBLE PRECISION DRNORM, RCOND +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE +C .. External Subroutines .. + EXTERNAL DGECON, DGEMM, DGETRF, DGETRS, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Check the scalar input parameters. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDBR.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDDR.LT.MAX( 1, P ) ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'SB08GD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( P.EQ.0 )THEN + DWORK(1) = ONE + RETURN + END IF +C +C Factor the matrix DR. First, compute the 1-norm. +C + DRNORM = DLANGE( '1-norm', P, P, DR, LDDR, DWORK ) + CALL DGETRF( P, P, DR, LDDR, IWORK, INFO ) + IF( INFO.NE.0 ) THEN + INFO = 1 + DWORK(1) = ZERO + RETURN + END IF +C -1 +C Compute C = DR * CQR. +C + CALL DGETRS( 'NoTranspose', P, N, DR, LDDR, IWORK, C, LDC, INFO ) +C -1 +C Compute A = AQR - BR * DR * CQR. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, P, -ONE, BR, LDBR, + $ C, LDC, ONE, A, LDA ) +C -1 +C Compute D = DR * DQ. +C + CALL DGETRS( 'NoTranspose', P, M, DR, LDDR, IWORK, D, LDD, INFO ) +C -1 +C Compute B = BQ - BR * DR * DQ. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, P, -ONE, BR, LDBR, + $ D, LDD, ONE, B, LDB ) +C +C Estimate the reciprocal condition number of DR. +C Workspace 4*P. +C + CALL DGECON( '1-norm', P, DR, LDDR, DRNORM, RCOND, DWORK, IWORK, + $ INFO ) + IF( RCOND.LE.DLAMCH( 'Epsilon' ) ) + $ INFO = 2 +C + DWORK(1) = RCOND +C + RETURN +C *** Last line of SB08GD *** + END diff --git a/mex/sources/libslicot/SB08HD.f b/mex/sources/libslicot/SB08HD.f new file mode 100644 index 000000000..b1a2227d9 --- /dev/null +++ b/mex/sources/libslicot/SB08HD.f @@ -0,0 +1,267 @@ + SUBROUTINE SB08HD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, CR, + $ LDCR, DR, LDDR, IWORK, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the state-space representation for the system +C G = (A,B,C,D) from the factors Q = (AQR,BQR,CQ,DQ) and +C R = (AQR,BQR,CR,DR) of its right coprime factorization +C -1 +C G = Q * R , +C +C where G, Q and R are the corresponding transfer-function matrices. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. Also the number of rows of the +C matrix B and the number of columns of the matrices C and +C CR. N represents the order of the systems Q and R. +C N >= 0. +C +C M (input) INTEGER +C The dimension of input vector. Also the number of columns +C of the matrices B, D and DR and the number of rows of the +C matrices CR and DR. M >= 0. +C +C P (input) INTEGER +C The dimension of output vector. Also the number of rows +C of the matrices C and D. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix AQR of the systems +C Q and R. +C On exit, the leading N-by-N part of this array contains +C the state dynamics matrix of the system G. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix BQR of the systems Q and R. +C On exit, the leading N-by-M part of this array contains +C the input/state matrix of the system G. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix CQ of the system Q. +C On exit, the leading P-by-N part of this array contains +C the state/output matrix of the system G. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the input/output matrix DQ of the system Q. +C On exit, the leading P-by-M part of this array contains +C the input/output matrix of the system G. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C CR (input) DOUBLE PRECISION array, dimension (LDCR,N) +C The leading M-by-N part of this array must contain the +C state/output matrix CR of the system R. +C +C LDCR INTEGER +C The leading dimension of array CR. LDCR >= MAX(1,M). +C +C DR (input/output) DOUBLE PRECISION array, dimension (LDDR,M) +C On entry, the leading M-by-M part of this array must +C contain the input/output matrix DR of the system R. +C On exit, the leading M-by-M part of this array contains +C the LU factorization of the matrix DR, as computed by +C LAPACK Library routine DGETRF. +C +C LDDR INTEGER +C The leading dimension of array DR. LDDR >= MAX(1,M). +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (MAX(1,4*M)) +C On exit, DWORK(1) contains an estimate of the reciprocal +C condition number of the matrix DR. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the matrix DR is singular; +C = 2: the matrix DR is numerically singular (warning); +C the calculations continued. +C +C METHOD +C +C The subroutine computes the matrices of the state-space +C representation G = (A,B,C,D) by using the formulas: +C +C -1 -1 +C A = AQR - BQR * DR * CR, B = BQR * DR , +C -1 -1 +C C = CQ - DQ * DR * CR, D = DQ * DR . +C +C REFERENCES +C +C [1] Varga A. +C Coprime factors model reduction method based on +C square-root balancing-free techniques. +C System Analysis, Modelling and Simulation, +C vol. 11, pp. 303-311, 1993. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine RCFI. +C V. Sima, Research Institute for Informatics, Bucharest, Nov. 1998, +C full BLAS 3 version. +C +C REVISIONS +C +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C Mar. 2000, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C Coprime factorization, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDCR, LDD, LDDR, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), CR(LDCR,*), + $ D(LDD,*), DR(LDDR,*), DWORK(*) + INTEGER IWORK(*) +C .. Local Scalars + DOUBLE PRECISION DRNORM, RCOND +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE +C .. External Subroutines .. + EXTERNAL DGECON, DGEMM, DGETRF, DTRSM, MA02GD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Check the scalar input parameters. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDCR.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF( LDDR.LT.MAX( 1, M ) ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'SB08HD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( M.EQ.0 )THEN + DWORK(1) = ONE + RETURN + END IF +C +C Factor the matrix DR. First, compute the 1-norm. +C + DRNORM = DLANGE( '1-norm', M, M, DR, LDDR, DWORK ) + CALL DGETRF( M, M, DR, LDDR, IWORK, INFO ) + IF( INFO.NE.0 ) THEN + INFO = 1 + DWORK(1) = ZERO + RETURN + END IF +C -1 +C Compute B = BQR * DR , using the factorization P*DR = L*U. +C + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, M, ONE, + $ DR, LDDR, B, LDB ) + CALL DTRSM( 'Right', 'Lower', 'NoTranspose', 'Unit', N, M, ONE, + $ DR, LDDR, B, LDB ) + CALL MA02GD( N, B, LDB, 1, M, IWORK, -1 ) +C -1 +C Compute A = AQR - BQR * DR * CR. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, -ONE, B, LDB, + $ CR, LDCR, ONE, A, LDA ) +C -1 +C Compute D = DQ * DR . +C + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', P, M, ONE, + $ DR, LDDR, D, LDD ) + CALL DTRSM( 'Right', 'Lower', 'NoTranspose', 'Unit', P, M, ONE, + $ DR, LDDR, D, LDD ) + CALL MA02GD( P, D, LDD, 1, M, IWORK, -1 ) +C -1 +C Compute C = CQ - DQ * DR * CR. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, N, M, -ONE, D, LDD, + $ CR, LDCR, ONE, C, LDC ) +C +C Estimate the reciprocal condition number of DR. +C Workspace 4*M. +C + CALL DGECON( '1-norm', M, DR, LDDR, DRNORM, RCOND, DWORK, IWORK, + $ INFO ) + IF( RCOND.LE.DLAMCH( 'Epsilon' ) ) + $ INFO = 2 +C + DWORK(1) = RCOND +C + RETURN +C *** Last line of SB08HD *** + END diff --git a/mex/sources/libslicot/SB08MD.f b/mex/sources/libslicot/SB08MD.f new file mode 100644 index 000000000..78f6d46c2 --- /dev/null +++ b/mex/sources/libslicot/SB08MD.f @@ -0,0 +1,471 @@ + SUBROUTINE SB08MD( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a real polynomial E(s) such that +C +C (a) E(-s) * E(s) = A(-s) * A(s) and +C (b) E(s) is stable - that is, all the zeros of E(s) have +C non-positive real parts, +C +C which corresponds to computing the spectral factorization of the +C real polynomial A(s) arising from continuous optimality problems. +C +C The input polynomial may be supplied either in the form +C +C A(s) = a(0) + a(1) * s + ... + a(DA) * s**DA +C +C or as +C +C B(s) = A(-s) * A(s) +C = b(0) + b(1) * s**2 + ... + b(DA) * s**(2*DA) (1) +C +C ARGUMENTS +C +C Mode Parameters +C +C ACONA CHARACTER*1 +C Indicates whether the coefficients of A(s) or B(s) = +C A(-s) * A(s) are to be supplied as follows: +C = 'A': The coefficients of A(s) are to be supplied; +C = 'B': The coefficients of B(s) are to be supplied. +C +C Input/Output Parameters +C +C DA (input) INTEGER +C The degree of the polynomials A(s) and E(s). DA >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (DA+1) +C On entry, this array must contain either the coefficients +C of the polynomial A(s) in increasing powers of s if +C ACONA = 'A', or the coefficients of the polynomial B(s) in +C increasing powers of s**2 (see equation (1)) if ACONA = +C 'B'. +C On exit, this array contains the coefficients of the +C polynomial B(s) in increasing powers of s**2. +C +C RES (output) DOUBLE PRECISION +C An estimate of the accuracy with which the coefficients of +C the polynomial E(s) have been computed (see also METHOD +C and NUMERICAL ASPECTS). +C +C E (output) DOUBLE PRECISION array, dimension (DA+1) +C The coefficients of the spectral factor E(s) in increasing +C powers of s. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 5*DA+5. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if on entry, A(I) = 0.0, for I = 1,2,...,DA+1. +C = 2: if on entry, ACONA = 'B' but the supplied +C coefficients of the polynomial B(s) are not the +C coefficients of A(-s) * A(s) for some real A(s); +C in this case, RES and E are unassigned; +C = 3: if the iterative process (see METHOD) has failed to +C converge in 30 iterations; +C = 4: if the last computed iterate (see METHOD) is +C unstable. If ACONA = 'B', then the supplied +C coefficients of the polynomial B(s) may not be the +C coefficients of A(-s) * A(s) for some real A(s). +C +C METHOD +C _ _ +C Let A(s) be the conjugate polynomial of A(s), i.e., A(s) = A(-s). +C +C The method used by the routine is based on applying the +C Newton-Raphson iteration to the function +C _ _ +C F(e) = A * A - e * e, +C +C which leads to the iteration formulae (see [1]): +C +C _(i) (i) _(i) (i) _ ) +C q * x + x * q = 2 A * A ) +C ) for i = 0, 1, 2,... +C (i+1) (i) (i) ) +C q = (q + x )/2 ) +C +C (0) DA +C Starting from q = (1 + s) (which has no zeros in the closed +C (1) (2) (3) +C right half-plane), the sequence of iterates q , q , q ,... +C converges to a solution of F(e) = 0 which has no zeros in the +C open right half-plane. +C +C The iterates satisfy the following conditions: +C +C (i) +C (a) q is a stable polynomial (no zeros in the closed right +C half-plane) and +C +C (i) (i-1) +C (b) q (1) <= q (1). +C +C (i-1) (i) +C The iterative process stops with q , (where i <= 30) if q +C violates either (a) or (b), or if the condition +C _(i) (i) _ +C (c) RES = ||(q q - A A)|| < tol, +C +C is satisfied, where || . || denotes the largest coefficient of +C _(i) (i) _ +C the polynomial (q q - A A) and tol is an estimate of the +C _(i) (i) +C rounding error in the computed coefficients of q q . If there +C is no convergence after 30 iterations then the routine returns +C with the Error Indicator (INFO) set to 3, and the value of RES may +C indicate whether or not the last computed iterate is close to the +C solution. +C +C If ACONA = 'B', then it is possible that the equation e(-s) * +C e(s) = B(s) has no real solution, which will be the case if A(1) +C < 0 or if ( -1)**DA * A(DA+1) < 0. +C +C REFERENCES +C +C [1] Vostry, Z. +C New Algorithm for Polynomial Spectral Factorization with +C Quadratic Convergence II. +C Kybernetika, 12, pp. 248-259, 1976. +C +C NUMERICAL ASPECTS +C +C The conditioning of the problem depends upon the distance of the +C zeros of A(s) from the imaginary axis and on their multiplicity. +C For a well-conditioned problem the accuracy of the computed +C coefficients of E(s) is of the order of RES. However, for problems +C with zeros near the imaginary axis or with multiple zeros, the +C value of RES may be an overestimate of the true accuracy. +C +C FURTHER COMMENTS +C +C In order for the problem e(-s) * e(s) = B(s) to have a real +C solution e(s), it is necessary and sufficient that B(j*omega) +C >= 0 for any purely imaginary argument j*omega (see [1]). +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB08AD by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Factorization, Laplace transform, optimal control, optimal +C filtering, polynomial operations, spectral factorization, zeros. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER ACONA + INTEGER DA, INFO, LDWORK + DOUBLE PRECISION RES +C .. Array Arguments .. + DOUBLE PRECISION A(*), DWORK(*), E(*) +C .. Local Scalars .. + LOGICAL CONV, LACONA, STABLE + INTEGER BINC, DA1, I, I0, J, K, LAMBDA, LAY, LAYEND, + $ LDIF, LPHEND, LPHI, LQ, M, NC + DOUBLE PRECISION A0, EPS, MU, MUJ, SI, SIGNI, SIGNI0, SIGNJ, + $ SIMIN1, SQRTA0, SQRTMJ, SQRTMU, TOLPHI, W, XDA +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, SB08MY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MOD, SQRT +C .. Executable Statements .. +C + INFO = 0 + LACONA = LSAME( ACONA, 'A' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LACONA .AND. .NOT.LSAME( ACONA, 'B' ) ) THEN + INFO = -1 + ELSE IF( DA.LT.0 ) THEN + INFO = -2 + ELSE IF( LDWORK.LT.5*DA + 5 ) THEN + INFO = -7 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB08MD', -INFO ) + RETURN + END IF +C + IF ( .NOT.LACONA ) THEN + CALL DCOPY( DA+1, A, 1, E, 1 ) + ELSE + W = ZERO + CALL SB08MY( DA, A, E, W ) + END IF +C +C Reduce E such that the first and the last element are non-zero. +C + DA1 = DA + 1 +C +C WHILE ( DA1 >= 1 and E(DA1) = 0 ) DO + 20 IF ( DA1.GE.1 ) THEN + IF ( E(DA1).EQ.ZERO ) THEN + DA1 = DA1 - 1 + GO TO 20 + END IF + END IF +C END WHILE 20 +C + DA1 = DA1 - 1 + IF ( DA1.LT.0 ) THEN + INFO = 1 + RETURN + END IF +C + I0 = 1 +C +C WHILE ( E(I0) = 0 ) DO + 40 IF ( E(I0).EQ.ZERO ) THEN + I0 = I0 + 1 + GO TO 40 + END IF +C END WHILE 40 +C + I0 = I0 - 1 + IF ( I0.NE.0 ) THEN + IF ( MOD( I0, 2 ).EQ.0 ) THEN + SIGNI0 = ONE + ELSE + SIGNI0 = -ONE + END IF +C + DO 60 I = 1, DA1 - I0 + 1 + E(I) = SIGNI0*E(I+I0) + 60 CONTINUE +C + DA1 = DA1 - I0 + END IF + IF ( MOD( DA1, 2 ).EQ.0 ) THEN + SIGNI = ONE + ELSE + SIGNI = -ONE + END IF + NC = DA1 + 1 + IF ( ( E(1).LT.ZERO ) .OR. ( ( E(NC)*SIGNI ).LT.ZERO ) ) THEN + INFO = 2 + RETURN + END IF +C +C Initialization. +C + EPS = DLAMCH( 'Epsilon' ) + SI = ONE/DLAMCH( 'Safe minimum' ) + LQ = 1 + LAY = LQ + NC + LAMBDA = LAY + NC + LPHI = LAMBDA + NC + LDIF = LPHI + NC +C + A0 = E(1) + BINC = 1 +C +C Computation of the starting polynomial and scaling of the input +C polynomial. +C + MU = ( A0/ABS( E(NC) ) )**( ONE/DBLE( DA1 ) ) + MUJ = ONE +C + DO 80 J = 1, NC + W = E(J)*MUJ/A0 + A(J) = W + E(J) = BINC + DWORK(LQ+J-1) = BINC + MUJ = MUJ*MU + BINC = BINC*( NC - J )/J + 80 CONTINUE +C + CONV = .FALSE. + STABLE = .TRUE. +C +C The contents of the arrays is, cf [1], +C +C E : the last computed stable polynomial q ; +C i-1 +C DWORK(LAY+1,...,LAY+DA1-1) : a'(1), ..., a'(DA1-1), these values +C are changed during the computation +C into y; +C (LAMBDA+1,...,LAMBDA+DA1-2) : lambda(1), ..., lambda(DA1-2), +C the factors of the Routh +C stability test, (lambda(i) is +C P(i) in [1]); +C (LPHI+1,...,LPHI+DA1-1) : phi(1), ..., phi(DA1-1), the values +C phi(i,j), see [1], scheme (11); +C (LDIF,...,LDIF+DA1) : the coeffs of q (-s) * q (s) - b(s). +C i i +C DWORK(LQ,...,LQ+DA1) : the last computed polynomial q . +C i + I = 0 +C +C WHILE ( I < 30 and CONV = FALSE and STABLE = TRUE ) DO + 100 IF ( I.LT.30 .AND. .NOT.CONV .AND. STABLE ) THEN + I = I + 1 + CALL DCOPY( NC, A, 1, DWORK(LAY), 1 ) + CALL DCOPY( NC, DWORK(LQ), 1, DWORK(LPHI), 1 ) + M = DA1/2 + LAYEND = LAY + DA1 + LPHEND = LPHI + DA1 + XDA = A(NC)/DWORK(LQ+DA1) +C + DO 120 K = 1, M + DWORK(LAY+K) = DWORK(LAY+K) - DWORK(LPHI+2*K) + DWORK(LAYEND-K) = DWORK(LAYEND-K) - DWORK(LPHEND-2*K)*XDA + 120 CONTINUE +C +C Computation of lambda(k) and y(k). +C + K = 1 +C +C WHILE ( K <= DA1 - 2 and STABLE = TRUE ) DO + 140 IF ( ( K.LE.( DA1 - 2 ) ) .AND. STABLE ) THEN + IF ( DWORK(LPHI+K).LE.ZERO ) STABLE = .FALSE. + IF ( STABLE ) THEN + W = DWORK(LPHI+K-1)/DWORK(LPHI+K) + DWORK(LAMBDA+K) = W + CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LPHI+K+2), 2, + $ DWORK(LPHI+K+1), 2 ) + W = DWORK(LAY+K)/DWORK(LPHI+K) + DWORK(LAY+K) = W + CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LPHI+K+2), 2, + $ DWORK(LAY+K+1), 1 ) + K = K + 1 + END IF + GO TO 140 + END IF +C END WHILE 140 +C + IF ( DWORK(LPHI+DA1-1).LE.ZERO ) THEN + STABLE = .FALSE. + ELSE + DWORK(LAY+DA1-1) = DWORK(LAY+DA1-1)/DWORK(LPHI+DA1-1) + END IF +C +C STABLE = The polynomial q is stable. +C i-1 + IF ( STABLE ) THEN +C +C Computation of x and q . +C i i +C + DO 160 K = DA1 - 2, 1, -1 + W = DWORK(LAMBDA+K) + CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LAY+K+1), 2, + $ DWORK(LAY+K), 2 ) + 160 CONTINUE +C + DWORK(LAY+DA1) = XDA +C + CALL DCOPY( NC, DWORK(LQ), 1, E, 1 ) + SIMIN1 = SI + SI = DWORK(LQ) + SIGNJ = -ONE +C + DO 180 J = 1, DA1 + W = HALF*( DWORK(LQ+J) + SIGNJ*DWORK(LAY+J) ) + DWORK(LQ+J) = W + SI = SI + W + SIGNJ = -SIGNJ + 180 CONTINUE +C + TOLPHI = EPS + CALL SB08MY( DA1, E, DWORK(LDIF), TOLPHI ) + CALL DAXPY( NC, -ONE, A, 1, DWORK(LDIF), 1 ) + RES = ABS( DWORK( IDAMAX( NC, DWORK(LDIF), 1 ) + LDIF-1 ) ) +C +C Convergency test. +C + IF ( ( SI.GT.SIMIN1 ) .OR. ( RES.LT.TOLPHI ) ) THEN + CONV = .TRUE. + END IF + GO TO 100 + END IF + END IF +C END WHILE 100 +C +C Backscaling. +C + MU = ONE/MU + SQRTA0 = SQRT( A0 ) + SQRTMU = SQRT( MU ) + MUJ = ONE + SQRTMJ = ONE +C + DO 200 J = 1, NC + E(J) = E(J)*SQRTA0*SQRTMJ + A(J) = A(J)*A0*MUJ + MUJ = MUJ*MU + SQRTMJ = SQRTMJ*SQRTMU + 200 CONTINUE +C + IF ( I0.NE.0 ) THEN +C + DO 220 J = NC, 1, -1 + E(I0+J) = E(J) + A(I0+J) = SIGNI0*A(J) + 220 CONTINUE +C + DO 240 J = 1, I0 + E(J) = ZERO + A(J) = ZERO + 240 CONTINUE +C + END IF +C + IF ( .NOT.CONV ) THEN + IF ( STABLE ) THEN + INFO = 3 + ELSE + INFO = 4 + END IF + END IF +C + RETURN +C *** Last line of SB08MD *** + END diff --git a/mex/sources/libslicot/SB08MY.f b/mex/sources/libslicot/SB08MY.f new file mode 100644 index 000000000..085be630a --- /dev/null +++ b/mex/sources/libslicot/SB08MY.f @@ -0,0 +1,102 @@ + SUBROUTINE SB08MY( DA, A, B, EPSB ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients of B(s) = A(s) * A(-s) and a norm +C for the accuracy of the computed coefficients. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C DA (input) INTEGER +C The degree of the polynomials A(s) and B(s). DA >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (DA+1) +C This array must contain the coefficients of the polynomial +C A(s) in increasing powers of s. +C +C B (output) DOUBLE PRECISION array, dimension (DA+1) +C This array contains the coefficients of the polynomial +C B(s) in increasing powers of s**2. +C +C EPSB (input/output) DOUBLE PRECISION +C On entry, EPSB must contain the machine precision (see +C LAPACK Library routine DLAMCH). +C On exit, EPSB contains an updated value, using a norm +C for the accuracy of the computed coefficients. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB08AZ by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Laplace transform, polynomial operations, spectral factorization. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO=2.0D0, + $ THREE = 3.0D0 ) +C .. Scalar Arguments .. + INTEGER DA + DOUBLE PRECISION EPSB +C .. Array Arguments .. + DOUBLE PRECISION A(*), B(*) +C .. Local Scalars .. + INTEGER I, K + DOUBLE PRECISION MAXSA, SA, SABS, SIGNI, SIGNK, TERM +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. Executable Statements .. +C + SIGNI = ONE + MAXSA = ZERO +C + DO 40 I = 0, DA + SABS = A(I+1)**2 + SA = SIGNI*SABS + SIGNK = -TWO*SIGNI +C + DO 20 K = 1, MIN( I, DA - I ) + TERM = SIGNK*A(I-K+1)*A(I+K+1) + SA = SA + TERM + SABS = SABS + ABS( TERM ) + SIGNK = -SIGNK + 20 CONTINUE +C + B(I+1) = SA + MAXSA = MAX( MAXSA, SABS ) + SIGNI = -SIGNI + 40 CONTINUE +C + EPSB = THREE*MAXSA*EPSB +C + RETURN +C *** Last line of SB08MY *** + END diff --git a/mex/sources/libslicot/SB08ND.f b/mex/sources/libslicot/SB08ND.f new file mode 100644 index 000000000..ced79b329 --- /dev/null +++ b/mex/sources/libslicot/SB08ND.f @@ -0,0 +1,382 @@ + SUBROUTINE SB08ND( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a real polynomial E(z) such that +C +C (a) E(1/z) * E(z) = A(1/z) * A(z) and +C (b) E(z) is stable - that is, E(z) has no zeros with modulus +C greater than 1, +C +C which corresponds to computing the spectral factorization of the +C real polynomial A(z) arising from discrete optimality problems. +C +C The input polynomial may be supplied either in the form +C +C A(z) = a(0) + a(1) * z + ... + a(DA) * z**DA +C +C or as +C +C B(z) = A(1/z) * A(z) +C = b(0) + b(1) * (z + 1/z) + ... + b(DA) * (z**DA + 1/z**DA) +C (1) +C +C ARGUMENTS +C +C Mode Parameters +C +C ACONA CHARACTER*1 +C Indicates whether the coefficients of A(z) or B(z) = +C A(1/z) * A(z) are to be supplied as follows: +C = 'A': The coefficients of A(z) are to be supplied; +C = 'B': The coefficients of B(z) are to be supplied. +C +C Input/Output Parameters +C +C DA (input) INTEGER +C The degree of the polynomials A(z) and E(z). DA >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (DA+1) +C On entry, if ACONA = 'A', this array must contain the +C coefficients of the polynomial A(z) in increasing powers +C of z, and if ACONA = 'B', this array must contain the +C coefficients b ,b ,...,b of the polynomial B(z) in +C 0 1 DA +C equation (1). That is, A(i) = b for i = 1,2,...,DA+1. +C i-1 +C On exit, this array contains the coefficients of the +C polynomial B(z) in eqation (1). Specifically, A(i) +C contains b , for i = 1,2,...DA+1. +C i-1 +C +C RES (output) DOUBLE PRECISION +C An estimate of the accuracy with which the coefficients of +C the polynomial E(z) have been computed (see also METHOD +C and NUMERICAL ASPECTS). +C +C E (output) DOUBLE PRECISION array, dimension (DA+1) +C The coefficients of the spectral factor E(z) in increasing +C powers of z. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 5*DA+5. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 2: if on entry, ACONA = 'B' but the supplied +C coefficients of the polynomial B(z) are not the +C coefficients of A(1/z) * A(z) for some real A(z); +C in this case, RES and E are unassigned; +C = 3: if the iterative process (see METHOD) has failed to +C converge in 30 iterations; +C = 4: if the last computed iterate (see METHOD) is +C unstable. If ACONA = 'B', then the supplied +C coefficients of the polynomial B(z) may not be the +C coefficients of A(1/z) * A(z) for some real A(z). +C +C METHOD +C _ _ +C Let A(z) be the conjugate polynomial of A(z), i.e., A(z) = A(1/z). +C +C The method used by the routine is based on applying the +C Newton-Raphson iteration to the function +C _ _ +C F(e) = A * A - e * e, +C +C which leads to the iteration formulae (see [1] and [2]) +C +C _(i) (i) _(i) (i) _ ) +C q * x + x * q = 2 A * A ) +C ) for i = 0, 1, 2,... +C (i+1) (i) (i) ) +C q = (q + x )/2 ) +C +C The iteration starts from +C +C (0) DA +C q (z) = (b(0) + b(1) * z + ... + b(DA) * z ) / SQRT( b(0)) +C +C which is a Hurwitz polynomial that has no zeros in the closed unit +C (i) +C circle (see [2], Theorem 3). Then lim q = e, the convergence is +C uniform and e is a Hurwitz polynomial. +C +C The iterates satisfy the following conditions: +C (i) +C (a) q has no zeros in the closed unit circle, +C (i) (i-1) +C (b) q <= q and +C 0 0 +C DA (i) 2 DA 2 +C (c) SUM (q ) - SUM (A ) >= 0. +C k=0 k k=0 k +C (i) +C The iterative process stops if q violates (a), (b) or (c), +C or if the condition +C _(i) (i) _ +C (d) RES = ||(q q - A A)|| < tol, +C +C is satisfied, where || . || denotes the largest coefficient of +C _(i) (i) _ +C the polynomial (q q - A A) and tol is an estimate of the +C _(i) (i) +C rounding error in the computed coefficients of q q . If +C (i-1) +C condition (a) or (b) is violated then q is taken otherwise +C (i) +C q is used. Thus the computed reciprocal polynomial E(z) = z**DA +C * q(1/z) is stable. If there is no convergence after 30 iterations +C then the routine returns with the Error Indicator (INFO) set to 3, +C and the value of RES may indicate whether or not the last computed +C iterate is close to the solution. +C (0) +C If ACONA = 'B', then it is possible that q is not a Hurwitz +C polynomial, in which case the equation e(1/z) * e(z) = B(z) has no +C real solution (see [2], Theorem 3). +C +C REFERENCES +C +C [1] Kucera, V. +C Discrete Linear Control, The polynomial Approach. +C John Wiley & Sons, Chichester, 1979. +C +C [2] Vostry, Z. +C New Algorithm for Polynomial Spectral Factorization with +C Quadratic Convergence I. +C Kybernetika, 11, pp. 415-422, 1975. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB08BD by F. Delebecque and +C A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Factorization, Laplace transform, optimal control, optimal +C filtering, polynomial operations, spectral factorization, zeros. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, TWO + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, + $ TWO = 2.0D0 ) +C .. Scalar Arguments .. + CHARACTER ACONA + INTEGER DA, INFO, LDWORK + DOUBLE PRECISION RES +C .. Array Arguments .. + DOUBLE PRECISION A(*), DWORK(*), E(*) +C .. Local Scalars .. + LOGICAL CONV, HURWTZ, LACONA + INTEGER I, J, K, LALPHA, LAMBDA, LETA, LQ, LRO, NC, NCK + DOUBLE PRECISION A0, RES0, S, SA0, TOLQ, W +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + EXTERNAL IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSCAL, DSWAP, SB08NY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +C .. Executable Statements .. +C + INFO = 0 + LACONA = LSAME( ACONA, 'A' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LACONA .AND. .NOT.LSAME( ACONA, 'B' ) ) THEN + INFO = -1 + ELSE IF( DA.LT.0 ) THEN + INFO = -2 + ELSE IF( LDWORK.LT.5*DA + 5 ) THEN + INFO = -7 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB08ND', -INFO ) + RETURN + END IF +C + NC = DA + 1 + IF ( .NOT.LACONA ) THEN + IF ( A(1).LE.ZERO ) THEN + INFO = 2 + RETURN + END IF + CALL DCOPY( NC, A, 1, E, 1 ) + ELSE + CALL SB08NY( DA, A, E, W ) + END IF +C +C Initialization. +C + LALPHA = 1 + LRO = LALPHA + NC + LETA = LRO + NC + LAMBDA = LETA + NC + LQ = LAMBDA + NC +C + A0 = E(1) + SA0 = SQRT( A0 ) + S = ZERO +C + DO 20 J = 1, NC + W = E(J) + A(J) = W + W = W/SA0 + E(J) = W + DWORK(LQ-1+J) = W + S = S + W**2 + 20 CONTINUE +C + RES0 = S - A0 +C +C The contents of the arrays is, cf [1], Section 7.6, +C +C E : the last computed Hurwitz polynomial q ; +C i-1 +C DWORK(LALPHA,..,LALPHA+DA-K) : alpha(k,0),...alpha(k,n-k); +C (LRO,...,LRO+DA-K) : alpha(k,n-k),...,alpha(k); +C (LETA,...,LETA+DA) : eta(0),...,eta(n); +C (LAMBDA,...,LAMBDA+DA-1) : lambda(0),...,lambda(n-1) +C +C DWORK(LQ,...,LQ+DA) : the last computed polynomial q . +C i + I = 0 + CONV = .FALSE. + HURWTZ = .TRUE. +C +C WHILE ( I < 30 and CONV = FALSE and HURWTZ = TRUE ) DO + 40 IF ( I.LT.30 .AND. .NOT.CONV .AND. HURWTZ ) THEN + I = I + 1 + CALL DCOPY( NC, A, 1, DWORK(LETA), 1 ) + CALL DSCAL( NC, TWO, DWORK(LETA), 1 ) + CALL DCOPY( NC, DWORK(LQ), 1, DWORK(LALPHA), 1 ) +C +C Computation of lambda(k) and eta(k). +C + K = 1 +C +C WHILE ( K <= DA and HURWTZ = TRUE ) DO + 60 IF ( ( K.LE.DA ) .AND. HURWTZ ) THEN + NCK = NC - K + CALL DCOPY( NCK+1, DWORK(LALPHA), -1, DWORK(LRO), 1 ) + W = DWORK(LALPHA+NCK)/DWORK(LRO+NCK) + IF ( ABS( W ).GE.ONE ) HURWTZ = .FALSE. + IF ( HURWTZ ) THEN + DWORK(LAMBDA+K-1) = W + CALL DAXPY( NCK, -W, DWORK(LRO), 1, DWORK(LALPHA), 1 ) + W = DWORK(LETA+NCK)/DWORK(LALPHA) + DWORK(LETA+NCK) = W + CALL DAXPY( NCK-1, -W, DWORK(LALPHA+1), -1, + $ DWORK(LETA+1), 1 ) + K = K + 1 + END IF + GO TO 60 + END IF +C END WHILE 60 +C +C HURWTZ = The polynomial q is a Hurwitz polynomial. +C i-1 + IF ( HURWTZ ) THEN + CALL DCOPY( NC, DWORK(LQ), 1, E, 1 ) +C +C Accuracy test. +C + CALL SB08NY( DA, E, DWORK(LQ), TOLQ ) + CALL DAXPY( NC, -ONE, A, 1, DWORK(LQ), 1 ) + RES = ABS( DWORK( IDAMAX( NC, DWORK(LQ), 1 ) + LQ - 1 ) ) + CONV = ( RES.LT.TOLQ ) .OR. ( RES0.LT.ZERO ) +C + IF ( .NOT.CONV ) THEN + DWORK(LETA) = HALF*DWORK(LETA)/DWORK(LALPHA) +C +C Computation of x and q . +C i i +C DWORK(LETA,...,LETA+DA) : eta(k,0),...,eta(k,n) +C (LRO,...,LRO+DA-K+1) : eta(k,n-k+1),...,eta(k,0) +C + DO 80 K = DA, 1, -1 + NCK = NC - K + 1 + CALL DCOPY( NCK, DWORK(LETA), -1, DWORK(LRO), 1 ) + W = DWORK(LAMBDA+K-1) + CALL DAXPY( NCK, -W, DWORK(LRO), 1, DWORK(LETA), 1 ) + 80 CONTINUE +C + S = ZERO +C + DO 100 J = 0, DA + W = HALF*( DWORK(LETA+J) + E(J+1) ) + DWORK(LQ+J) = W + S = S + W**2 + 100 CONTINUE +C + RES0 = S - A0 +C +C Test on the monotonicity of q . +C 0 + CONV = DWORK(LQ).GT.E(1) + GO TO 40 + END IF + END IF + END IF +C END WHILE 40 +C +C Reverse the order of the coefficients in the array E. +C + CALL DSWAP( NC, E, 1, DWORK, -1 ) + CALL DSWAP( NC, DWORK, 1, E, 1 ) +C + IF ( .NOT.CONV ) THEN + IF ( HURWTZ ) THEN + INFO = 3 + ELSE IF ( I.EQ.1 ) THEN + INFO = 2 + ELSE + INFO = 4 + END IF + END IF +C + RETURN +C *** Last line of SB08ND *** + END diff --git a/mex/sources/libslicot/SB08NY.f b/mex/sources/libslicot/SB08NY.f new file mode 100644 index 000000000..f6c0cb668 --- /dev/null +++ b/mex/sources/libslicot/SB08NY.f @@ -0,0 +1,83 @@ + SUBROUTINE SB08NY( DA, A, B, EPSB ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients of B(z) = A(1/z) * A(z) and a norm for +C the accuracy of the computed coefficients. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C DA (input) INTEGER +C The degree of the polynomials A(z) and B(z). DA >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (DA+1) +C This array must contain the coefficients of the polynomial +C A(z) in increasing powers of z. +C +C B (output) DOUBLE PRECISION array, dimension (DA+1) +C This array contains the coefficients of the polynomial +C B(z). +C +C EPSB (output) DOUBLE PRECISION +C A value used for checking the accuracy of the computed +C coefficients. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB08BZ by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Laplace transform, polynomial operations, spectral factorization. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION THREE + PARAMETER ( THREE = 3.0D0 ) +C .. Scalar Arguments .. + INTEGER DA + DOUBLE PRECISION EPSB +C .. Array Arguments .. + DOUBLE PRECISION A(*), B(*) +C .. Local Scalars .. + INTEGER I +C .. External Functions .. + DOUBLE PRECISION DDOT, DLAMCH + EXTERNAL DDOT, DLAMCH +C .. Executable Statements .. +C + DO 20 I = 1, DA + 1 + B(I) = DDOT( DA-I+2, A(1), 1, A(I), 1 ) + 20 CONTINUE +C + EPSB = THREE*DLAMCH( 'Epsilon' )*B(1) +C + RETURN +C *** Last line of SB08NY *** + END diff --git a/mex/sources/libslicot/SB09MD.f b/mex/sources/libslicot/SB09MD.f new file mode 100644 index 000000000..edb0e2d1a --- /dev/null +++ b/mex/sources/libslicot/SB09MD.f @@ -0,0 +1,251 @@ + SUBROUTINE SB09MD( N, NC, NB, H1, LDH1, H2, LDH2, SS, LDSS, SE, + $ LDSE, PRE, LDPRE, TOL, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compare two multivariable sequences M1(k) and M2(k) for +C k = 1,2,...,N, and evaluate their closeness. Each of the +C parameters M1(k) and M2(k) is an NC by NB matrix. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of parameters. N >= 0. +C +C NC (input) INTEGER +C The number of rows in M1(k) and M2(k). NC >= 0. +C +C NB (input) INTEGER +C The number of columns in M1(k) and M2(k). NB >= 0. +C +C H1 (input) DOUBLE PRECISION array, dimension (LDH1,N*NB) +C The leading NC-by-N*NB part of this array must contain +C the multivariable sequence M1(k), where k = 1,2,...,N. +C Each parameter M1(k) is an NC-by-NB matrix, whose +C (i,j)-th element must be stored in H1(i,(k-1)*NB+j) for +C i = 1,2,...,NC and j = 1,2,...,NB. +C +C LDH1 INTEGER +C The leading dimension of array H1. LDH1 >= MAX(1,NC). +C +C H2 (input) DOUBLE PRECISION array, dimension (LDH2,N*NB) +C The leading NC-by-N*NB part of this array must contain +C the multivariable sequence M2(k), where k = 1,2,...,N. +C Each parameter M2(k) is an NC-by-NB matrix, whose +C (i,j)-th element must be stored in H2(i,(k-1)*NB+j) for +C i = 1,2,...,NC and j = 1,2,...,NB. +C +C LDH2 INTEGER +C The leading dimension of array H2. LDH2 >= MAX(1,NC). +C +C SS (output) DOUBLE PRECISION array, dimension (LDSS,NB) +C The leading NC-by-NB part of this array contains the +C matrix SS. +C +C LDSS INTEGER +C The leading dimension of array SS. LDSS >= MAX(1,NC). +C +C SE (output) DOUBLE PRECISION array, dimension (LDSE,NB) +C The leading NC-by-NB part of this array contains the +C quadratic error matrix SE. +C +C LDSE INTEGER +C The leading dimension of array SE. LDSE >= MAX(1,NC). +C +C PRE (output) DOUBLE PRECISION array, dimension (LDPRE,NB) +C The leading NC-by-NB part of this array contains the +C percentage relative error matrix PRE. +C +C LDPRE INTEGER +C The leading dimension of array PRE. LDPRE >= MAX(1,NC). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in the computation of the error +C matrices SE and PRE. If the user sets TOL to be less than +C EPS then the tolerance is taken as EPS, where EPS is the +C machine precision (see LAPACK Library routine DLAMCH). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The (i,j)-th element of the matrix SS is defined by: +C N 2 +C SS = SUM M1 (k) . (1) +C ij k=1 ij +C +C The (i,j)-th element of the quadratic error matrix SE is defined +C by: +C N 2 +C SE = SUM (M1 (k) - M2 (k)) . (2) +C ij k=1 ij ij +C +C The (i,j)-th element of the percentage relative error matrix PRE +C is defined by: +C +C PRE = 100 x SQRT( SE / SS ). (3) +C ij ij ij +C +C The following precautions are taken by the routine to guard +C against underflow and overflow: +C +C (i) if ABS( M1 (k) ) > 1/TOL or ABS( M1 (k) - M2 (k) ) > 1/TOL, +C ij ij ij +C +C then SE and SS are set to 1/TOL and PRE is set to 1; and +C ij ij ij +C +C (ii) if ABS( SS ) <= TOL, then PRE is set to 100. +C ij ij +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately +C 2xNBxNCx(N+1) multiplications/divisions, +C 4xNBxNCxN additions/subtractions and +C NBxNC square roots. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB09AD by S. Van Huffel, Katholieke +C University Leuven, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Closeness multivariable sequences, elementary matrix operations, +C real signals, system response. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HUNDRD + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HUNDRD = 100.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDH1, LDH2, LDPRE, LDSE, LDSS, N, NB, NC + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION H1(LDH1,*), H2(LDH2,*), PRE(LDPRE,*), + $ SE(LDSE,*), SS(LDSS,*) +C .. Local Scalars .. + LOGICAL NOFLOW + INTEGER I, J, K + DOUBLE PRECISION EPSO, SSE, SSS, TOLER, VAR, VARE +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( NC.LT.0 ) THEN + INFO = -2 + ELSE IF( NB.LT.0 ) THEN + INFO = -3 + ELSE IF( LDH1.LT.MAX( 1, NC ) ) THEN + INFO = -5 + ELSE IF( LDH2.LT.MAX( 1, NC ) ) THEN + INFO = -7 + ELSE IF( LDSS.LT.MAX( 1, NC ) ) THEN + INFO = -9 + ELSE IF( LDSE.LT.MAX( 1, NC ) ) THEN + INFO = -11 + ELSE IF( LDPRE.LT.MAX( 1, NC ) ) THEN + INFO = -13 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB09MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. NC.EQ.0 .OR. NB.EQ.0 ) + $ RETURN +C + TOLER = MAX( TOL, DLAMCH( 'Epsilon' ) ) + EPSO = ONE/TOLER +C + DO 60 J = 1, NB +C + DO 40 I = 1, NC + SSE = ZERO + SSS = ZERO + NOFLOW = .TRUE. + K = 0 +C +C WHILE ( ( NOFLOW .AND. ( K .LT. N*NB ) ) DO + 20 IF ( ( NOFLOW ) .AND. ( K.LT.N*NB ) ) THEN + VAR = H1(I,K+J) + VARE = H2(I,K+J) - VAR + IF ( ABS( VAR ).GT.EPSO .OR. ABS( VARE ).GT.EPSO ) + $ THEN + SE(I,J) = EPSO + SS(I,J) = EPSO + PRE(I,J) = ONE + NOFLOW = .FALSE. + ELSE + IF ( ABS( VARE ).GT.TOLER ) SSE = SSE + VARE*VARE + IF ( ABS( VAR ).GT.TOLER ) SSS = SSS + VAR*VAR + K = K + NB + END IF + GO TO 20 + END IF +C END WHILE 20 +C + IF ( NOFLOW ) THEN + SE(I,J) = SSE + SS(I,J) = SSS + PRE(I,J) = HUNDRD + IF ( SSS.GT.TOLER ) PRE(I,J) = SQRT( SSE/SSS )*HUNDRD + END IF + 40 CONTINUE +C + 60 CONTINUE +C + RETURN +C *** Last line of SB09MD *** + END diff --git a/mex/sources/libslicot/SB10AD.f b/mex/sources/libslicot/SB10AD.f new file mode 100644 index 000000000..a74b3a8ee --- /dev/null +++ b/mex/sources/libslicot/SB10AD.f @@ -0,0 +1,827 @@ + SUBROUTINE SB10AD( JOB, N, M, NP, NCON, NMEAS, GAMMA, A, LDA, + $ B, LDB, C, LDC, D, LDD, AK, LDAK, BK, LDBK, CK, + $ LDCK, DK, LDDK, AC, LDAC, BC, LDBC, CC, LDCC, + $ DC, LDDC, RCOND, GTOL, ACTOL, IWORK, LIWORK, + $ DWORK, LDWORK, BWORK, LBWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of an H-infinity optimal n-state +C controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C using modified Glover's and Doyle's 1988 formulas, for the system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 D22 | +C +C and for the estimated minimal possible value of gamma with respect +C to GTOL, where B2 has as column size the number of control inputs +C (NCON) and C2 has as row size the number of measurements (NMEAS) +C being provided to the controller, and then to compute the matrices +C of the closed-loop system +C +C | AC | BC | +C G = |----|----|, +C | CC | DC | +C +C if the stabilizing controller exists. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank and D21 is full row rank, +C +C (A3) | A-j*omega*I B2 | has full column rank for all omega, +C | C1 D12 | +C +C (A4) | A-j*omega*I B1 | has full row rank for all omega. +C | C2 D21 | +C +C ARGUMENTS +C +C Input/Output Parameters +C +C JOB (input) INTEGER +C Indicates the strategy for reducing the GAMMA value, as +C follows: +C = 1: Use bisection method for decreasing GAMMA from GAMMA +C to GAMMAMIN until the closed-loop system leaves +C stability. +C = 2: Scan from GAMMA to 0 trying to find the minimal GAMMA +C for which the closed-loop system retains stability. +C = 3: First bisection, then scanning. +C = 4: Find suboptimal controller only. +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C GAMMA (input/output) DOUBLE PRECISION +C The initial value of gamma on input. It is assumed that +C gamma is sufficiently large so that the controller is +C admissible. GAMMA >= 0. +C On output it contains the minimal estimated gamma. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C AC (output) DOUBLE PRECISION array, dimension (LDAC,2*N) +C The leading 2*N-by-2*N part of this array contains the +C closed-loop system state matrix AC. +C +C LDAC INTEGER +C The leading dimension of the array AC. +C LDAC >= max(1,2*N). +C +C BC (output) DOUBLE PRECISION array, dimension (LDBC,M-NCON) +C The leading 2*N-by-(M-NCON) part of this array contains +C the closed-loop system input matrix BC. +C +C LDBC INTEGER +C The leading dimension of the array BC. +C LDBC >= max(1,2*N). +C +C CC (output) DOUBLE PRECISION array, dimension (LDCC,2*N) +C The leading (NP-NMEAS)-by-2*N part of this array contains +C the closed-loop system output matrix CC. +C +C LDCC INTEGER +C The leading dimension of the array CC. +C LDCC >= max(1,NP-NMEAS). +C +C DC (output) DOUBLE PRECISION array, dimension (LDDC,M-NCON) +C The leading (NP-NMEAS)-by-(M-NCON) part of this array +C contains the closed-loop system input/output matrix DC. +C +C LDDC INTEGER +C The leading dimension of the array DC. +C LDDC >= max(1,NP-NMEAS). +C +C RCOND (output) DOUBLE PRECISION array, dimension (4) +C For the last successful step: +C RCOND(1) contains the reciprocal condition number of the +C control transformation matrix; +C RCOND(2) contains the reciprocal condition number of the +C measurement transformation matrix; +C RCOND(3) contains an estimate of the reciprocal condition +C number of the X-Riccati equation; +C RCOND(4) contains an estimate of the reciprocal condition +C number of the Y-Riccati equation. +C +C Tolerances +C +C GTOL DOUBLE PRECISION +C Tolerance used for controlling the accuracy of GAMMA +C and its distance to the estimated minimal possible +C value of GAMMA. +C If GTOL <= 0, then a default value equal to sqrt(EPS) +C is used, where EPS is the relative machine precision. +C +C ACTOL DOUBLE PRECISION +C Upper bound for the poles of the closed-loop system +C used for determining if it is stable. +C ACTOL <= 0 for stable systems. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C +C LIWORK INTEGER +C The dimension of the array IWORK. +C LIWORK >= max(2*max(N,M-NCON,NP-NMEAS,NCON,NMEAS),N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C value of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= LW1 + max(1,LW2,LW3,LW4,LW5 + MAX(LW6,LW7)), +C where +C LW1 = N*M + NP*N + NP*M + M2*M2 + NP2*NP2; +C LW2 = max( ( N + NP1 + 1 )*( N + M2 ) + +C max( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ), +C ( N + NP2 )*( N + M1 + 1 ) + +C max( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ), +C M2 + NP1*NP1 + max( NP1*max( N, M1 ), +C 3*M2 + NP1, 5*M2 ), +C NP2 + M1*M1 + max( max( N, NP1 )*M1, +C 3*NP2 + M1, 5*NP2 ) ); +C LW3 = max( ND1*M1 + max( 4*min( ND1, M1 ) + max( ND1,M1 ), +C 6*min( ND1, M1 ) ), +C NP1*ND2 + max( 4*min( NP1, ND2 ) + +C max( NP1,ND2 ), +C 6*min( NP1, ND2 ) ) ); +C LW4 = 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP; +C LW5 = 2*N*N + M*N + N*NP; +C LW6 = max( M*M + max( 2*M1, 3*N*N + +C max( N*M, 10*N*N + 12*N + 5 ) ), +C NP*NP + max( 2*NP1, 3*N*N + +C max( N*NP, 10*N*N + 12*N + 5 ) )); +C LW7 = M2*NP2 + NP2*NP2 + M2*M2 + +C max( ND1*ND1 + max( 2*ND1, ( ND1 + ND2 )*NP2 ), +C ND2*ND2 + max( 2*ND2, ND2*M2 ), 3*N, +C N*( 2*NP2 + M2 ) + +C max( 2*N*M2, M2*NP2 + +C max( M2*M2 + 3*M2, NP2*( 2*NP2 + +C M2 + max( NP2, N ) ) ) ) ); +C M1 = M - M2, NP1 = NP - NP2, +C ND1 = NP1 - M2, ND2 = M1 - NP2. +C For good performance, LDWORK must generally be larger. +C +C BWORK LOGICAL array, dimension (LBWORK) +C +C LBWORK INTEGER +C The dimension of the array BWORK. LBWORK >= 2*N. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix | A-j*omega*I B2 | had not full +C | C1 D12 | +C column rank in respect to the tolerance EPS; +C = 2: if the matrix | A-j*omega*I B1 | had not full row +C | C2 D21 | +C rank in respect to the tolerance EPS; +C = 3: if the matrix D12 had not full column rank in +C respect to the tolerance SQRT(EPS); +C = 4: if the matrix D21 had not full row rank in respect +C to the tolerance SQRT(EPS); +C = 5: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of one of +C the matrices |A B2 |, |A B1 |, D12 or D21); +C |C1 D12| |C2 D21| +C = 6: if the controller is not admissible (too small value +C of gamma); +C = 7: if the X-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 8: if the Y-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 9: if the determinant of Im2 + Tu*D11HAT*Ty*D22 is +C zero [3]; +C = 10: if there are numerical problems when estimating +C singular values of D1111, D1112, D1111', D1121'; +C = 11: if the matrices Inp2 - D22*DK or Im2 - DK*D22 +C are singular to working precision; +C = 12: if a stabilizing controller cannot be found. +C +C METHOD +C +C The routine implements the Glover's and Doyle's 1988 formulas [1], +C [2], modified to improve the efficiency as described in [3]. +C +C JOB = 1: It tries with a decreasing value of GAMMA, starting with +C the given, and with the newly obtained controller estimates of the +C closed-loop system. If it is stable, (i.e., max(eig(AC)) < ACTOL) +C the iterations can be continued until the given tolerance between +C GAMMA and the estimated GAMMAMIN is reached. Otherwise, in the +C next step GAMMA is increased. The step in the all next iterations +C is step = step/2. The closed-loop system is obtained by the +C formulas given in [2]. +C +C JOB = 2: The same as for JOB = 1, but with non-varying step till +C GAMMA = 0, step = max(0.1, GTOL). +C +C JOB = 3: Combines the JOB = 1 and JOB = 2 cases for a quicker +C procedure. +C +C JOB = 4: Suboptimal controller for current GAMMA only. +C +C REFERENCES +C +C [1] Glover, K. and Doyle, J.C. +C State-space formulae for all stabilizing controllers that +C satisfy an Hinf norm bound and relations to risk sensitivity. +C Systems and Control Letters, vol. 11, pp. 167-172, 1988. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, MA, 1995. +C +C [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of continuous-time +C linear control systems. +C Rep. 98-14, Department of Engineering, Leicester University, +C Leicester, U.K., 1998. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C input and output transformations and on the condition numbers of +C the two Riccati equations, as given by the values of RCOND(1), +C RCOND(2), RCOND(3) and RCOND(4), respectively. +C This approach by estimating the closed-loop system and checking +C its poles seems to be reliable. +C +C CONTRIBUTORS +C +C A. Markovski, P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, +C July 2003. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. +C +C KEYWORDS +C +C Algebraic Riccati equation, H-infinity optimal control, robust +C control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, P1, THOUS + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ P1 = 0.1D+0, THOUS = 1.0D+3 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, JOB, LBWORK, LDA, LDAC, LDAK, LDB, LDBC, + $ LDBK, LDC, LDCC, LDCK, LDD, LDDC, LDDK, LDWORK, + $ LIWORK, M, N, NCON, NMEAS, NP + DOUBLE PRECISION ACTOL, GAMMA, GTOL +C .. +C .. Array Arguments .. + LOGICAL BWORK( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AC( LDAC, * ), AK( LDAK, * ), + $ B( LDB, * ), BC( LDBC, * ), BK( LDBK, * ), + $ C( LDC, * ), CC( LDCC, * ), CK( LDCK, * ), + $ D( LDD, * ), DC( LDDC, * ), DK( LDDK, * ), + $ DWORK( * ), RCOND( 4 ) +C .. +C .. Local Scalars .. + INTEGER I, INF, INFO2, INFO3, IWAC, IWC, IWD, IWD1, + $ IWF, IWH, IWRE, IWRK, IWS1, IWS2, IWTU, IWTY, + $ IWWI, IWWR, IWX, IWY, LW1, LW2, LW3, LW4, LW5, + $ LW6, LW7, LWAMAX, M1, M11, M2, MINWRK, MODE, + $ NP1, NP11, NP2 + DOUBLE PRECISION GAMABS, GAMAMN, GAMAMX, GTOLL, MINEAC, STEPG, + $ TOL2 +C .. +C .. External Functions .. + LOGICAL SELECT + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DGEES, DGESVD, DLACPY, SB10LD, SB10PD, SB10QD, + $ SB10RD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Decode and test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS + NP11 = NP1 - M2 + M11 = M1 - NP2 +C + INFO = 0 + IF ( JOB.LT.1 .OR. JOB.GT.4 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( NP.LT.0 ) THEN + INFO = -4 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -5 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -6 + ELSE IF( GAMMA.LT.ZERO ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -13 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -15 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -19 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -21 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -23 + ELSE IF( LDAC.LT.MAX( 1, 2*N ) ) THEN + INFO = -25 + ELSE IF( LDBC.LT.MAX( 1, 2*N ) ) THEN + INFO = -27 + ELSE IF( LDCC.LT.MAX( 1, NP1 ) ) THEN + INFO = -29 + ELSE IF( LDDC.LT.MAX( 1, NP1 ) ) THEN + INFO = -31 + ELSE +C +C Compute workspace. +C + LW1 = N*M + NP*N + NP*M + M2*M2 + NP2*NP2 + LW2 = MAX( ( N + NP1 + 1 )*( N + M2 ) + + $ MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ), + $ ( N + NP2 )*( N + M1 + 1 ) + + $ MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ), + $ M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, + $ 5*M2 ), + $ NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, + $ 5*NP2 ) ) + LW3 = MAX( NP11*M1 + MAX( 4*MIN( NP11, M1 ) + MAX( NP11, M1 ), + $ 6*MIN( NP11, M1 ) ), + $ NP1*M11 + MAX( 4*MIN( NP1, M11 ) + MAX( NP1, M11 ), + $ 6*MIN( NP1, M11 ) ) ) + LW4 = 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP + LW5 = 2*N*N + M*N + N*NP + LW6 = MAX( M*M + MAX( 2*M1, 3*N*N + + $ MAX( N*M, 10*N*N + 12*N + 5 ) ), + $ NP*NP + MAX( 2*NP1, 3*N*N + + $ MAX( N*NP, 10*N*N + 12*N + 5 ) ) ) + LW7 = M2*NP2 + NP2*NP2 + M2*M2 + + $ MAX( NP11*NP11 + MAX( 2*NP11, ( NP11 + M11 )*NP2 ), + $ M11*M11 + MAX( 2*M11, M11*M2 ), 3*N, + $ N*( 2*NP2 + M2 ) + + $ MAX( 2*N*M2, M2*NP2 + + $ MAX( M2*M2 + 3*M2, NP2*( 2*NP2 + + $ M2 + MAX( NP2, N ) ) ) ) ) + MINWRK = LW1 + MAX( 1, LW2, LW3, LW4, LW5 + MAX( LW6, LW7 ) ) + IF( LDWORK.LT.MINWRK ) THEN + INFO = -38 + ELSE IF( LIWORK.LT.MAX( 2*MAX( N, M1, NP1, M2, NP2 ), + $ N*N ) ) THEN + INFO = -36 + ELSE IF( LBWORK.LT.2*N ) THEN + INFO = -40 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB10AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + MODE = JOB + IF ( MODE.GT.2 ) + $ MODE = 1 + GTOLL = GTOL + IF( GTOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance for GAMMA. +C + GTOLL = SQRT( DLAMCH( 'Epsilon' ) ) + END IF +C +C Workspace usage 1. +C + IWC = 1 + N*M + IWD = IWC + NP*N + IWTU = IWD + NP*M + IWTY = IWTU + M2*M2 + IWRK = IWTY + NP2*NP2 +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) +C + CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NP ) +C + CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NP ) +C +C Transform the system so that D12 and D21 satisfy the formulas +C in the computation of the Hinf optimal controller. +C Workspace: need LW1 + MAX(1,LWP1,LWP2,LWP3,LWP4), +C prefer larger, +C where +C LW1 = N*M + NP*N + NP*M + M2*M2 + NP2*NP2 +C LWP1 = (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2)), +C LWP2 = (N+NP2)*(N+M1+1) + MAX(3*(N+NP2)+N+M1,5*(N+NP2)), +C LWP3 = M2 + NP1*NP1 + MAX(NP1*MAX(N,M1),3*M2+NP1,5*M2), +C LWP4 = NP2 + M1*M1 + MAX(MAX(N,NP1)*M1,3*NP2+M1,5*NP2), +C with M1 = M - M2 and NP1 = NP - NP2. +C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is +C LW1 + MAX(1,(N+Q)*(N+Q+6),Q*(Q+MAX(N,Q,5)+1). +C + TOL2 = -ONE +C + CALL SB10PD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWTU ), + $ M2, DWORK( IWTY ), NP2, RCOND, TOL2, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) +C + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C + IF ( INFO2.NE.0 ) THEN + INFO = INFO2 + RETURN + END IF +C +C Workspace usage 2. +C + IWD1 = IWRK + IWS1 = IWD1 + NP11*M1 +C +C Check if GAMMA < max(sigma[D1111,D1112],sigma[D1111',D1121']). +C Workspace: need LW1 + MAX(1, LWS1, LWS2), +C prefer larger, +C where +C LWS1 = NP11*M1 + MAX(4*MIN(NP11,M1)+MAX(NP11,M1),6*MIN(NP11,M1)) +C LWS2 = NP1*M11 + MAX(4*MIN(NP1,M11)+MAX(NP1,M11),6*MIN(NP1,M11)) +C + INFO2 = 0 + INFO3 = 0 +C + IF ( NP11.NE.0 .AND. M1.NE.0 ) THEN + IWRK = IWS1 + MIN( NP11, M1 ) + CALL DLACPY( 'Full', NP11, M1, DWORK(IWD), LDD, DWORK(IWD1), + $ NP11 ) + CALL DGESVD( 'N', 'N', NP11, M1, DWORK(IWD1), NP11, + $ DWORK(IWS1), DWORK(IWS1), 1, DWORK(IWS1), 1, + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) + ELSE + DWORK(IWS1) = ZERO + END IF +C + IWS2 = IWD1 + NP1*M11 + IF ( NP1.NE.0 .AND. M11.NE.0 ) THEN + IWRK = IWS2 + MIN( NP1, M11 ) + CALL DLACPY( 'Full', NP1, M11, DWORK(IWD), LDD, DWORK(IWD1), + $ NP1 ) + CALL DGESVD( 'N', 'N', NP1, M11, DWORK(IWD1), NP1, DWORK(IWS2), + $ DWORK(IWS2), 1, DWORK(IWS2), 1, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO3 ) + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) + ELSE + DWORK(IWS2) = ZERO + END IF +C + GAMAMN = MAX( DWORK(IWS1), DWORK(IWS2) ) +C + IF ( INFO2.GT.0 .OR. INFO3.GT.0 ) THEN + INFO = 10 + RETURN + ELSE IF ( GAMMA.LE.GAMAMN ) THEN + INFO = 6 + RETURN + END IF +C +C Workspace usage 3. +C + IWX = IWD1 + IWY = IWX + N*N + IWF = IWY + N*N + IWH = IWF + M*N + IWRK = IWH + N*NP + IWAC = IWD1 + IWWR = IWAC + 4*N*N + IWWI = IWWR + 2*N + IWRE = IWWI + 2*N +C +C Prepare some auxiliary variables for the gamma iteration. +C + STEPG = GAMMA - GAMAMN + GAMABS = GAMMA + GAMAMX = GAMMA + INF = 0 +C +C ############################################################### +C +C Begin the gamma iteration. +C + 10 CONTINUE + STEPG = STEPG/TWO +C +C Try to compute the state feedback and output injection +C matrices for the current GAMMA. +C + CALL SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), + $ M, DWORK( IWH ), N, DWORK( IWX ), N, DWORK( IWY ), + $ N, RCOND(3), IWORK, DWORK( IWRK ), LDWORK-IWRK+1, + $ BWORK, INFO2 ) +C + IF ( INFO2.NE.0 ) GOTO 30 +C +C Try to compute the Hinf suboptimal (yet) controller. +C + CALL SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), + $ M, DWORK( IWH ), N, DWORK( IWTU ), M2, + $ DWORK( IWTY ), NP2, DWORK( IWX ), N, DWORK( IWY ), + $ N, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) +C + IF ( INFO2.NE.0 ) GOTO 30 +C +C Compute the closed-loop system. +C Workspace: need LW1 + 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP; +C prefer larger. +C + CALL SB10LD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, D, + $ LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, AC, + $ LDAC, BC, LDBC, CC, LDCC, DC, LDDC, IWORK, + $ DWORK( IWD1 ), LDWORK-IWD1+1, INFO2 ) +C + IF ( INFO2.NE.0 ) GOTO 30 +C + LWAMAX = MAX( LWAMAX, INT( DWORK( IWD1 ) ) + IWD1 - 1 ) +C +C Compute the poles of the closed-loop system. +C Workspace: need LW1 + 4*N*N + 4*N + max(1,6*N); +C prefer larger. +C + CALL DLACPY( 'Full', 2*N, 2*N, AC, LDAC, DWORK(IWAC), 2*N ) +C + CALL DGEES( 'N', 'N', SELECT, 2*N, DWORK(IWAC), 2*N, IWORK, + $ DWORK(IWWR), DWORK(IWWI), DWORK(IWRE), 1, + $ DWORK(IWRE), LDWORK-IWRE+1, BWORK, INFO2 ) +C + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRE ) ) + IWRE - 1 ) +C +C Now DWORK(IWWR+I)=Re(Lambda), DWORK(IWWI+I)=Im(Lambda), +C for I=0,2*N-1. +C + MINEAC = -THOUS +C + DO 20 I = 0, 2*N - 1 + MINEAC = MAX( MINEAC, DWORK(IWWR+I) ) + 20 CONTINUE +C +C Check if the closed-loop system is stable. +C + 30 IF ( MODE.EQ.1 ) THEN + IF ( INFO2.EQ.0 .AND. MINEAC.LT.ACTOL ) THEN + GAMABS = GAMMA + GAMMA = GAMMA - STEPG + INF = 1 + ELSE + GAMMA = MIN( GAMMA + STEPG, GAMAMX ) + END IF + ELSE IF ( MODE.EQ.2 ) THEN + IF ( INFO2.EQ.0 .AND. MINEAC.LT.ACTOL ) THEN + GAMABS = GAMMA + INF = 1 + END IF + GAMMA = GAMMA - MAX( P1, GTOLL ) + END IF +C +C More iterations? +C + IF ( MODE.EQ.1 .AND. JOB.EQ.3 .AND. TWO*STEPG.LT.GTOLL ) THEN + MODE = 2 + GAMMA = GAMABS + END IF +C + IF ( JOB.NE.4 .AND. + $ ( MODE.EQ.1 .AND. TWO*STEPG.GE.GTOLL .OR. + $ MODE.EQ.2 .AND. GAMMA.GT.ZERO ) ) THEN + GOTO 10 + END IF +C +C ############################################################### +C +C End of the gamma iteration - Return if no stabilizing controller +C was found. +C + IF ( INF.EQ.0 ) THEN + INFO = 12 + RETURN + END IF +C +C Now compute the state feedback and output injection matrices +C using GAMABS. +C + GAMMA = GAMABS +C +C Integer workspace: need max(2*max(N,M-NCON,NP-NMEAS),N*N). +C Workspace: need LW1P + +C max(1,M*M + max(2*M1,3*N*N + +C max(N*M,10*N*N+12*N+5)), +C NP*NP + max(2*NP1,3*N*N + +C max(N*NP,10*N*N+12*N+5))); +C prefer larger, +C where LW1P = LW1 + 2*N*N + M*N + N*NP. +C An upper bound of the second term after LW1P is +C max(1,4*Q*Q+max(2*Q,3*N*N + max(2*N*Q,10*N*N+12*N+5))). +C + CALL SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), + $ M, DWORK( IWH ), N, DWORK( IWX ), N, DWORK( IWY ), + $ N, RCOND(3), IWORK, DWORK( IWRK ), LDWORK-IWRK+1, + $ BWORK, INFO2 ) +C + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) +C + IF ( INFO2.GT.0 ) THEN + INFO = INFO2 + 5 + RETURN + END IF +C +C Compute the Hinf optimal controller. +C Integer workspace: need max(2*(max(NP,M)-M2-NP2,M2,N),NP2). +C Workspace: need LW1P + +C max(1, M2*NP2 + NP2*NP2 + M2*M2 + +C max(D1*D1 + max(2*D1, (D1+D2)*NP2), +C D2*D2 + max(2*D2, D2*M2), 3*N, +C N*(2*NP2 + M2) + +C max(2*N*M2, M2*NP2 + +C max(M2*M2+3*M2, NP2*(2*NP2+ +C M2+max(NP2,N)))))) +C where D1 = NP1 - M2 = NP11, D2 = M1 - NP2 = M11; +C prefer larger. +C An upper bound of the second term after LW1P is +C max( 1, Q*(3*Q + 3*N + max(2*N, 4*Q + max(Q, N)))). +C + CALL SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), + $ M, DWORK( IWH ), N, DWORK( IWTU ), M2, DWORK( IWTY ), + $ NP2, DWORK( IWX ), N, DWORK( IWY ), N, AK, LDAK, BK, + $ LDBK, CK, LDCK, DK, LDDK, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) +C + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) +C + IF( INFO2.EQ.1 ) THEN + INFO = 6 + RETURN + ELSE IF( INFO2.EQ.2 ) THEN + INFO = 9 + RETURN + END IF +C +C Integer workspace: need 2*max(NCON,NMEAS). +C Workspace: need 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP; +C prefer larger. +C + CALL SB10LD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, D, + $ LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, AC, + $ LDAC, BC, LDBC, CC, LDCC, DC, LDDC, IWORK, DWORK, + $ LDWORK, INFO2 ) +C + IF( INFO2.GT.0 ) THEN + INFO = 11 + RETURN + END IF +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10AD *** + END diff --git a/mex/sources/libslicot/SB10DD.f b/mex/sources/libslicot/SB10DD.f new file mode 100644 index 000000000..b6a99f7b9 --- /dev/null +++ b/mex/sources/libslicot/SB10DD.f @@ -0,0 +1,1007 @@ + SUBROUTINE SB10DD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, + $ C, LDC, D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, + $ DK, LDDK, X, LDX, Z, LDZ, RCOND, TOL, IWORK, + $ DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of an H-infinity (sub)optimal n-state +C controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C for the discrete-time system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 D22 | +C +C and for a given value of gamma, where B2 has as column size the +C number of control inputs (NCON) and C2 has as row size the number +C of measurements (NMEAS) being provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank and D21 is full row rank, +C +C j*Theta +C (A3) | A-e *I B2 | has full column rank for all +C | C1 D12 | +C +C 0 <= Theta < 2*Pi , +C +C j*Theta +C (A4) | A-e *I B1 | has full row rank for all +C | C2 D21 | +C +C 0 <= Theta < 2*Pi . +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C GAMMA (input) DOUBLE PRECISION +C The value of gamma. It is assumed that gamma is +C sufficiently large so that the controller is admissible. +C GAMMA > 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array contains the matrix +C X, solution of the X-Riccati equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C The leading N-by-N part of this array contains the matrix +C Z, solution of the Z-Riccati equation. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= max(1,N). +C +C RCOND (output) DOUBLE PRECISION array, dimension (8) +C RCOND contains estimates of the reciprocal condition +C numbers of the matrices which are to be inverted and +C estimates of the reciprocal condition numbers of the +C Riccati equations which have to be solved during the +C computation of the controller. (See the description of +C the algorithm in [2].) +C RCOND(1) contains the reciprocal condition number of the +C matrix R3; +C RCOND(2) contains the reciprocal condition number of the +C matrix R1 - R2'*inv(R3)*R2; +C RCOND(3) contains the reciprocal condition number of the +C matrix V21; +C RCOND(4) contains the reciprocal condition number of the +C matrix St3; +C RCOND(5) contains the reciprocal condition number of the +C matrix V12; +C RCOND(6) contains the reciprocal condition number of the +C matrix Im2 + DKHAT*D22 +C RCOND(7) contains the reciprocal condition number of the +C X-Riccati equation; +C RCOND(8) contains the reciprocal condition number of the +C Z-Riccati equation. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used in neglecting the small singular values +C in rank determination. If TOL <= 0, then a default value +C equal to 1000*EPS is used, where EPS is the relative +C machine precision. +C +C Workspace +C +C IWORK INTEGER array, dimension max(2*max(M2,N),M,M2+NP2,N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= max(LW1,LW2,LW3,LW4), where +C LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)); +C LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)); +C LW3 = 13*N*N + 2*M*M + N*(8*M+NP2) + M1*(M2+NP2) + 6*N + +C max(14*N+23,16*N,2*N+M,3*M); +C LW4 = 13*N*N + M*M + (8*N+M+M2+2*NP2)*(M2+NP2) + 6*N + +C N*(M+NP2) + max(14*N+23,16*N,2*N+M2+NP2,3*(M2+NP2)); +C For good performance, LDWORK must generally be larger. +C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is +C max((N+Q)*(N+Q+6),13*N*N + M*M + 2*Q*Q + N*(M+Q) + +C max(M*(M+7*N),2*Q*(8*N+M+2*Q)) + 6*N + +C max(14*N+23,16*N,2*N+max(M,2*Q),3*max(M,2*Q)). +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C j*Theta +C = 1: if the matrix | A-e *I B2 | had not full +C | C1 D12 | +C column rank; +C j*Theta +C = 2: if the matrix | A-e *I B1 | had not full +C | C2 D21 | +C row rank; +C = 3: if the matrix D12 had not full column rank; +C = 4: if the matrix D21 had not full row rank; +C = 5: if the controller is not admissible (too small value +C of gamma); +C = 6: if the X-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 7: if the Z-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 8: if the matrix Im2 + DKHAT*D22 is singular. +C = 9: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of one of +C the matrices |A B2 |, |A B1 |, D12 or D21). +C |C1 D12| |C2 D21| +C +C METHOD +C +C The routine implements the method presented in [1]. +C +C REFERENCES +C +C [1] Green, M. and Limebeer, D.J.N. +C Linear Robust Control. +C Prentice-Hall, Englewood Cliffs, NJ, 1995. +C +C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of linear +C discrete-time control systems. +C Report 99-8, Department of Engineering, Leicester University, +C April 1999. +C +C NUMERICAL ASPECTS +C +C With approaching the minimum value of gamma some of the matrices +C which are to be inverted tend to become ill-conditioned and +C the X- or Z-Riccati equation may also become ill-conditioned +C which may deteriorate the accuracy of the result. (The +C corresponding reciprocal condition numbers are given in +C the output array RCOND.) +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, April 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999. +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2000. +C +C KEYWORDS +C +C Algebraic Riccati equation, discrete-time H-infinity optimal +C control, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, THOUSN + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, + $ THOUSN = 1.0D+3 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, LDX, LDZ, M, N, NCON, NMEAS, NP + DOUBLE PRECISION GAMMA, TOL +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( * ), X( LDX, * ), Z( LDZ, * ) + LOGICAL BWORK( * ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IR2, IR3, IS2, IS3, IWB, IWC, IWD, IWG, + $ IWH, IWI, IWL, IWQ, IWR, IWRK, IWS, IWT, IWU, + $ IWV, IWW, J, LWAMAX, M1, M2, MINWRK, NP1, NP2 + DOUBLE PRECISION ANORM, FERR, RCOND2, SEPD, TOLL +C +C .. External Functions + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANSY +C .. +C .. External Subroutines .. + EXTERNAL DGECON, DGEMM, DGESVD, DGETRF, DGETRS, DLACPY, + $ DLASET, DPOCON, DPOTRF, DSCAL, DSWAP, DSYRK, + $ DSYTRF, DSYTRS, DTRCON, DTRSM, MA02AD, MB01RU, + $ MB01RX, SB02OD, SB02SD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( GAMMA.LE.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -14 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -20 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -22 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -24 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -26 + ELSE +C +C Compute workspace. +C + IWB = ( N + NP1 + 1 )*( N + M2 ) + + $ MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ) + IWC = ( N + NP2 )*( N + M1 + 1 ) + + $ MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ) + IWD = 13*N*N + 2*M*M + N*( 8*M + NP2 ) + M1*( M2 + NP2 ) + + $ 6*N + MAX( 14*N + 23, 16*N, 2*N + M, 3*M ) + IWG = 13*N*N + M*M + ( 8*N + M + M2 + 2*NP2 )*( M2 + NP2 ) + + $ 6*N + N*( M + NP2 ) + + $ MAX( 14*N + 23, 16*N, 2*N + M2 + NP2, 3*( M2 + NP2 ) ) + MINWRK = MAX( IWB, IWC, IWD, IWG ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -31 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10DD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + RCOND( 5 ) = ONE + RCOND( 6 ) = ONE + RCOND( 7 ) = ONE + RCOND( 8 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance in rank determination. +C + TOLL = THOUSN*DLAMCH( 'Epsilon' ) + END IF +C +C Workspace usage. +C + IWS = (N+NP1)*(N+M2) + 1 + IWRK = IWS + (N+M2) +C +C jTheta +C Determine if |A-e I B2 | has full column rank at +C | C1 D12| +C Theta = Pi/2 . +C Workspace: need (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2)); +C prefer larger. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N+NP1 ) + CALL DLACPY( 'Full', NP1, N, C, LDC, DWORK( N+1 ), N+NP1 ) + CALL DLACPY( 'Full', N, M2, B( 1, M1+1 ), LDB, + $ DWORK( (N+NP1)*N+1 ), N+NP1 ) + CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, + $ DWORK( (N+NP1)*N+N+1 ), N+NP1 ) + CALL DGESVD( 'N', 'N', N+NP1, N+M2, DWORK, N+NP1, DWORK( IWS ), + $ DWORK, N+NP1, DWORK, N+M2, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 9 + RETURN + END IF + IF( DWORK( IWS+N+M2 ) / DWORK( IWS ).LE.TOLL ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Workspace usage. +C + IWS = (N+NP2)*(N+M1) + 1 + IWRK = IWS + (N+NP2) +C +C jTheta +C Determine if |A-e I B1 | has full row rank at +C | C2 D21| +C Theta = Pi/2 . +C Workspace: need (N+NP2)*(N+M1+1) + +C MAX(3*(N+NP2)+N+M1,5*(N+NP2)); +C prefer larger. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N+NP2 ) + CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1), LDC, DWORK( N+1 ), + $ N+NP2 ) + CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( (N+NP2)*N+1 ), + $ N+NP2 ) + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, + $ DWORK( (N+NP2)*N+N+1 ), N+NP2 ) + CALL DGESVD( 'N', 'N', N+NP2, N+M1, DWORK, N+NP2, DWORK( IWS ), + $ DWORK, N+NP2, DWORK, N+M1, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 9 + RETURN + END IF + IF( DWORK( IWS+N+NP2 ) / DWORK( IWS ).LE.TOLL ) THEN + INFO = 2 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWS = NP1*M2 + 1 + IWRK = IWS + M2 +C +C Determine if D12 has full column rank. +C Workspace: need (NP1+1)*M2 + MAX(3*M2+NP1,5*M2); +C prefer larger. +C + CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, DWORK, NP1 ) + CALL DGESVD( 'N', 'N', NP1, M2, DWORK, NP1, DWORK( IWS ), DWORK, + $ NP1, DWORK, M2, DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 9 + RETURN + END IF + IF( DWORK( IWS+M2 ) / DWORK( IWS ).LE.TOLL ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWS = NP2*M1 + 1 + IWRK = IWS + NP2 +C +C Determine if D21 has full row rank. +C Workspace: need NP2*(M1+1) + MAX(3*NP2+M1,5*NP2); +C prefer larger. +C + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, NP2 ) + CALL DGESVD( 'N', 'N', NP2, M1, DWORK, NP2, DWORK( IWS ), DWORK, + $ NP2, DWORK, M1, DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 9 + RETURN + END IF + IF( DWORK( IWS+NP2 ) / DWORK( IWS ).LE.TOLL ) THEN + INFO = 4 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWV = 1 + IWB = IWV + M*M + IWC = IWB + N*M1 + IWD = IWC + ( M2 + NP2 )*N + IWQ = IWD + ( M2 + NP2 )*M1 + IWL = IWQ + N*N + IWR = IWL + N*M + IWI = IWR + 2*N + IWH = IWI + 2*N + IWS = IWH + 2*N + IWT = IWS + ( 2*N + M )*( 2*N + M ) + IWU = IWT + ( 2*N + M )*2*N + IWRK = IWU + 4*N*N + IR2 = IWV + M1 + IR3 = IR2 + M*M1 +C +C Compute R0 = |D11'||D11 D12| -|gamma^2*Im1 0| . +C |D12'| | 0 0| +C + CALL DSYRK( 'Lower', 'Transpose', M, NP1, ONE, D, LDD, ZERO, + $ DWORK, M ) + DO 10 J = 1, M*M1, M + 1 + DWORK( J ) = DWORK( J ) - GAMMA*GAMMA + 10 CONTINUE +C +C Compute C1'*C1 . +C + CALL DSYRK( 'Lower', 'Transpose', N, NP1, ONE, C, LDC, ZERO, + $ DWORK( IWQ ), N ) +C +C Compute C1'*|D11 D12| . +C + CALL DGEMM( 'Transpose', 'NoTranspose', N, M, NP1, ONE, C, LDC, + $ D, LDD, ZERO, DWORK( IWL ), N ) +C +C Solution of the X-Riccati equation. +C Workspace: need 13*N*N + 2*M*M + N*(8*M+NP2) + M1*(M2+NP2) + +C 6*N + max(14*N+23,16*N,2*N+M,3*M); +C prefer larger. +C + CALL SB02OD( 'D', 'B', 'N', 'L', 'N', 'S', N, M, NP, A, LDA, B, + $ LDB, DWORK( IWQ ), N, DWORK, M, DWORK( IWL ), N, + $ RCOND2, X, LDX, DWORK( IWR ), DWORK( IWI ), + $ DWORK( IWH ), DWORK( IWS ), 2*N+M, DWORK( IWT ), + $ 2*N+M, DWORK( IWU ), 2*N, TOLL, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Condition estimation. +C Workspace: need 4*N*N + 2*M*M + N*(3*M+NP2) + M1*(M2+NP2) + +C max(5*N,max(3,2*N*N)+N*N); +C prefer larger. +C + IWS = IWR + IWH = IWS + M*M + IWT = IWH + N*M + IWU = IWT + N*N + IWG = IWU + N*N + IWRK = IWG + N*N + CALL DLACPY( 'Lower', M, M, DWORK, M, DWORK( IWS ), M ) + CALL DSYTRF( 'Lower', M, DWORK( IWS ), M, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C + CALL MA02AD( 'Full', N, M, B, LDB, DWORK( IWH ), M ) + CALL DSYTRS( 'Lower', M, N, DWORK( IWS ), M, IWORK, DWORK( IWH ), + $ M, INFO2 ) + CALL MB01RX( 'Left', 'Lower', 'NoTranspose', N, M, ZERO, ONE, + $ DWORK( IWG ), N, B, LDB, DWORK( IWH ), M, INFO2 ) + CALL SB02SD( 'C', 'N', 'N', 'L', 'O', N, A, LDA, DWORK( IWT ), N, + $ DWORK( IWU ), N, DWORK( IWG ), N, DWORK( IWQ ), N, X, + $ LDX, SEPD, RCOND( 7 ), FERR, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) RCOND( 7 ) = ZERO + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWRK = IWR +C +C Compute the lower triangle of |R1 R2'| = R0 + B'*X*B . +C |R2 R3 | +C + CALL MB01RU( 'Lower', 'Transpose', M, N, ONE, ONE, DWORK, M, + $ B, LDB, X, LDX, DWORK( IWRK ), M*N, INFO2 ) +C +C Compute the Cholesky factorization of R3, R3 = V12'*V12 . +C Note that V12' is stored. +C + ANORM = DLANSY( '1', 'Lower', M2, DWORK( IR3 ), M, DWORK( IWRK ) ) + CALL DPOTRF( 'Lower', M2, DWORK( IR3 ), M, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL DPOCON( 'Lower', M2, DWORK( IR3 ), M, ANORM, RCOND( 1 ), + $ DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 1 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C + CALL DTRCON( '1', 'Lower', 'NonUnit', M2, DWORK( IR3 ), M, + $ RCOND( 5 ), DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 5 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C +C Compute R2 <- inv(V12')*R2 . +C + CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M2, M1, + $ ONE, DWORK( IR3 ), M, DWORK( IR2 ), M ) +C +C Compute -Nabla = R2'*inv(R3)*R2 - R1 . +C + CALL DSYRK( 'Lower', 'Transpose', M1, M2, ONE, DWORK( IR2 ), M, + $ -ONE, DWORK, M ) +C +C Compute the Cholesky factorization of -Nabla, -Nabla = V21t'*V21t. +C Note that V21t' is stored. +C + ANORM = DLANSY( '1', 'Lower', M1, DWORK, M, DWORK( IWRK ) ) + CALL DPOTRF( 'Lower', M1, DWORK, M, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL DPOCON( 'Lower', M1, DWORK, M, ANORM, RCOND( 2 ), + $ DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 2 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C + CALL DTRCON( '1', 'Lower', 'NonUnit', M1, DWORK, M, RCOND( 3 ), + $ DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 3 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C +C Compute X*A . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, X, LDX, + $ A, LDA, ZERO, DWORK( IWQ ), N ) +C +C Compute |L1| = |D11'|*C1 + B'*X*A . +C |L2| = |D12'| +C + CALL MA02AD( 'Full', N, M, DWORK( IWL ), N, DWORK( IWRK ), M ) + CALL DLACPY( 'Full', M, N, DWORK( IWRK ), M, DWORK( IWL ), M ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, N, N, ONE, B, LDB, + $ DWORK( IWQ ), N, ONE, DWORK( IWL ), M ) +C +C Compute L2 <- inv(V12')*L2 . +C + CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M2, N, ONE, + $ DWORK( IR3 ), M, DWORK( IWL+M1 ), M ) +C +C Compute L_Nabla = L1 - R2'*inv(R3)*L2 . +C + CALL DGEMM( 'Transpose', 'NoTranspose', M1, N, M2, -ONE, + $ DWORK( IR2 ), M, DWORK( IWL+M1 ), M, ONE, + $ DWORK( IWL ), M ) +C +C Compute L_Nabla <- inv(V21t')*L_Nabla . +C + CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M1, N, ONE, + $ DWORK, M, DWORK( IWL ), M ) +C +C Compute Bt1 = B1*inv(V21t) . +C + CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( IWB ), N ) + CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', N, M1, ONE, + $ DWORK, M, DWORK( IWB ), N ) +C +C Compute At . +C + CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M1, ONE, + $ DWORK( IWB ), N, DWORK( IWL ), M, ONE, AK, LDAK ) +C +C Scale Bt1 . +C + CALL DSCAL( N*M1, GAMMA, DWORK( IWB ), 1 ) +C +C Compute |Dt11| = |R2 |*inv(V21t) . +C |Dt21| |D21| +C + CALL DLACPY( 'Full', M2, M1, DWORK( IR2 ), M, DWORK( IWD ), + $ M2+NP2 ) + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, DWORK( IWD+M2 ), + $ M2+NP2 ) + CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', M2+NP2, + $ M1, ONE, DWORK, M, DWORK( IWD ), M2+NP2 ) +C +C Compute Ct = |Ct1| = |L2| + |Dt11|*inv(V21t')*L_Nabla . +C |Ct2| = |C2| + |Dt21| +C + CALL DLACPY( 'Full', M2, N, DWORK( IWL+M1 ), M, DWORK( IWC ), + $ M2+NP2 ) + CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1 ), LDC, DWORK( IWC+M2 ), + $ M2+NP2 ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M2+NP2, N, M1, ONE, + $ DWORK( IWD ), M2+NP2, DWORK( IWL ), M, ONE, + $ DWORK( IWC ), M2+NP2 ) +C +C Scale |Dt11| . +C |Dt21| +C + CALL DSCAL( ( M2+NP2 )*M1, GAMMA, DWORK( IWD ), 1 ) +C +C Workspace usage. +C + IWW = IWD + ( M2 + NP2 )*M1 + IWQ = IWW + ( M2 + NP2 )*( M2 + NP2 ) + IWL = IWQ + N*N + IWR = IWL + N*( M2 + NP2 ) + IWI = IWR + 2*N + IWH = IWI + 2*N + IWS = IWH + 2*N + IWT = IWS + ( 2*N + M2 + NP2 )*( 2*N + M2 + NP2 ) + IWU = IWT + ( 2*N + M2 + NP2 )*2*N + IWG = IWU + 4*N*N + IWRK = IWG + ( M2 + NP2 )*N + IS2 = IWW + ( M2 + NP2 )*M2 + IS3 = IS2 + M2 +C +C Compute S0 = |Dt11||Dt11' Dt21'| -|gamma^2*Im2 0| . +C |Dt21| | 0 0| +C + CALL DSYRK( 'Upper', 'NoTranspose', M2+NP2, M1, ONE, DWORK( IWD ), + $ M2+NP2, ZERO, DWORK( IWW ), M2+NP2 ) + DO 20 J = IWW, IWW - 1 + ( M2 + NP2 )*M2, M2 + NP2 + 1 + DWORK( J ) = DWORK( J ) - GAMMA*GAMMA + 20 CONTINUE +C +C Compute Bt1*Bt1' . +C + CALL DSYRK( 'Upper', 'NoTranspose', N, M1, ONE, DWORK( IWB ), N, + $ ZERO, DWORK( IWQ ), N ) +C +C Compute Bt1*|Dt11' Dt21'| . +C + CALL DGEMM( 'NoTranspose', 'Transpose', N, M2+NP2, M1, ONE, + $ DWORK( IWB ), N, DWORK( IWD ), M2+NP2, ZERO, + $ DWORK( IWL ), N ) +C +C Transpose At in situ (in AK) . +C + DO 30 J = 2, N + CALL DSWAP( J-1, AK( J, 1 ), LDAK, AK( 1, J ), 1 ) + 30 CONTINUE +C +C Transpose Ct . +C + CALL MA02AD( 'Full', M2+NP2, N, DWORK( IWC ), M2+NP2, + $ DWORK( IWG ), N ) +C +C Solution of the Z-Riccati equation. +C Workspace: need 13*N*N + M*M + (8*N+M+M2+2*NP2)*(M2+NP2) + +C N*(M+NP2) + 6*N + +C max(14*N+23,16*N,2*N+M2+NP2,3*(M2+NP2)); +C prefer larger. +C + CALL SB02OD( 'D', 'B', 'N', 'U', 'N', 'S', N, M2+NP2, NP, AK, + $ LDAK, DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWW ), + $ M2+NP2, DWORK( IWL ), N, RCOND2, Z, LDZ, DWORK( IWR), + $ DWORK( IWI ), DWORK( IWH ), DWORK( IWS ), 2*N+M2+NP2, + $ DWORK( IWT ), 2*N+M2+NP2, DWORK( IWU ), 2*N, TOLL, + $ IWORK, DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 7 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Condition estimation. +C Workspace: need 4*N*N + M*M + 2*(M2+NP2)*(M2+NP2)+ +C N*(M+2*M2+3*NP2) + (M2+NP2)*M1 + +C max(5*N,max(3,2*N*N)+N*N); +C prefer larger. +C + IWS = IWR + IWH = IWS + ( M2 + NP2 )*( M2 + NP2 ) + IWT = IWH + N*( M2 + NP2 ) + IWU = IWT + N*N + IWG = IWU + N*N + IWRK = IWG + N*N + CALL DLACPY( 'Upper', M2+NP2, M2+NP2, DWORK( IWW ), M2+NP2, + $ DWORK( IWS ), M2+NP2 ) + CALL DSYTRF( 'Upper', M2+NP2, DWORK( IWS ), M2+NP2, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C + CALL DLACPY( 'Full', M2+NP2, N, DWORK( IWC ), M2+NP2, + $ DWORK( IWH ), M2+NP2 ) + CALL DSYTRS( 'Upper', M2+NP2, N, DWORK( IWS ), M2+NP2, IWORK, + $ DWORK( IWH ), M2+NP2, INFO2 ) + CALL MB01RX( 'Left', 'Upper', 'Transpose', N, M2+NP2, ZERO, ONE, + $ DWORK( IWG ), N, DWORK( IWC ), M2+NP2, DWORK( IWH ), + $ M2+NP2, INFO2 ) + CALL SB02SD( 'C', 'N', 'N', 'U', 'O', N, AK, LDAK, DWORK( IWT ), + $ N, DWORK( IWU ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ Z, LDZ, SEPD, RCOND( 8 ), FERR, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) RCOND( 8 ) = ZERO + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWRK = IWR +C +C Compute the upper triangle of +C |St1 St2| = S0 + |Ct1|*Z*|Ct1' Ct2'| . +C |St2' St3| |Ct2| +C + CALL MB01RU( 'Upper', 'NoTranspose', M2+NP2, N, ONE, ONE, + $ DWORK( IWW ), M2+NP2, DWORK( IWC ), M2+NP2, Z, LDZ, + $ DWORK( IWRK ), (M2+NP2)*N, INFO2 ) +C +C Compute the Cholesky factorization of St3, St3 = U12'*U12 . +C + ANORM = DLANSY( '1', 'Upper', NP2, DWORK( IS3 ), M2+NP2, + $ DWORK( IWRK ) ) + CALL DPOTRF( 'Upper', NP2, DWORK( IS3 ), M2+NP2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL DPOCON( 'Upper', NP2, DWORK( IS3 ), M2+NP2, ANORM, + $ RCOND( 4 ), DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 4 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C +C Compute St2 <- St2*inv(U12) . +C + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', M2, NP2, + $ ONE, DWORK( IS3 ), M2+NP2, DWORK( IS2 ), M2+NP2 ) +C +C Check the negative definiteness of St1 - St2*inv(St3)*St2' . +C + CALL DSYRK( 'Upper', 'NoTranspose', M2, NP2, ONE, DWORK( IS2 ), + $ M2+NP2, -ONE, DWORK( IWW ), M2+NP2 ) + CALL DPOTRF( 'Upper', M2, DWORK( IWW ), M2+NP2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF +C +C Restore At in situ . +C + DO 40 J = 2, N + CALL DSWAP( J-1, AK( J, 1 ), LDAK, AK( 1, J ), 1 ) + 40 CONTINUE +C +C Compute At*Z . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, AK, LDAK, + $ Z, LDZ, ZERO, DWORK( IWRK ), N ) +C +C Compute Mt2 = Bt1*Dt21' + At*Z*Ct2' in BK . +C + CALL DLACPY( 'Full', N, NP2, DWORK( IWL+N*M2 ), N, BK, LDBK ) + CALL DGEMM( 'NoTranspose', 'Transpose', N, NP2, N, ONE, + $ DWORK( IWRK ), N, DWORK( IWC+M2 ), M2+NP2, ONE, + $ BK, LDBK ) +C +C Compute St2 <- St2*inv(U12') . +C + CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', M2, NP2, + $ ONE, DWORK( IS3 ), M2+NP2, DWORK( IS2 ), M2+NP2 ) +C +C Compute DKHAT = -inv(V12)*St2 in DK . +C + CALL DLACPY( 'Full', M2, NP2, DWORK( IS2 ), M2+NP2, DK, LDDK ) + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', M2, NP2, + $ -ONE, DWORK( IR3 ), M, DK, LDDK ) +C +C Compute CKHAT = -inv(V12)*(Ct1 - St2*inv(St3)*Ct2) in CK . +C + CALL DLACPY( 'Full', M2, N, DWORK( IWC ), M2+NP2, CK, LDCK ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M2, N, NP2, -ONE, + $ DWORK( IS2 ), M2+NP2, DWORK( IWC+M2 ), M2+NP2, ONE, + $ CK, LDCK ) + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', M2, N, -ONE, + $ DWORK( IR3 ), M, CK, LDCK ) +C +C Compute Mt2*inv(St3) in BK . +C + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, NP2, + $ ONE, DWORK( IS3 ), M2+NP2, BK, LDBK ) + CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', N, NP2, + $ ONE, DWORK( IS3 ), M2+NP2, BK, LDBK ) +C +C Compute AKHAT in AK . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M2, ONE, + $ B( 1, M1+1 ), LDB, CK, LDCK, ONE, AK, LDAK ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, NP2, -ONE, BK, + $ LDBK, DWORK( IWC+M2 ), M2+NP2, ONE, AK, LDAK ) +C +C Compute BKHAT in BK . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, NP2, M2, ONE, + $ B( 1, M1+1 ), LDB, DK, LDDK, ONE, BK, LDBK ) +C +C Compute Im2 + DKHAT*D22 . +C + IWRK = M2*M2 + 1 + CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK, M2 ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M2, M2, NP2, ONE, DK, + $ LDDK, D( NP1+1, M1+1 ), LDD, ONE, DWORK, M2 ) + ANORM = DLANGE( '1', M2, M2, DWORK, M2, DWORK( IWRK ) ) + CALL DGETRF( M2, M2, DWORK, M2, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 8 + RETURN + END IF + CALL DGECON( '1', M2, DWORK, M2, ANORM, RCOND( 6 ), DWORK( IWRK ), + $ IWORK( M2+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 6 ).LT.TOLL ) THEN + INFO = 8 + RETURN + END IF +C +C Compute CK . +C + CALL DGETRS( 'NoTranspose', M2, N, DWORK, M2, IWORK, CK, LDCK, + $ INFO2 ) +C +C Compute DK . +C + CALL DGETRS( 'NoTranspose', M2, NP2, DWORK, M2, IWORK, DK, LDDK, + $ INFO2 ) +C +C Compute AK . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M2, NP2, ONE, BK, + $ LDBK, D( NP1+1, M1+1 ), LDD, ZERO, DWORK, N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M2, -ONE, DWORK, + $ N, CK, LDCK, ONE, AK, LDAK ) +C +C Compute BK . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, NP2, M2, -ONE, DWORK, + $ N, DK, LDDK, ONE, BK, LDBK ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10DD *** + END diff --git a/mex/sources/libslicot/SB10ED.f b/mex/sources/libslicot/SB10ED.f new file mode 100644 index 000000000..51f7f048f --- /dev/null +++ b/mex/sources/libslicot/SB10ED.f @@ -0,0 +1,468 @@ + SUBROUTINE SB10ED( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, + $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, + $ RCOND, TOL, IWORK, DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the H2 optimal n-state controller +C +C | AK | BK | +C K = |----|----| +C | CK | DK | +C +C for the discrete-time system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| , +C | C1 | 0 D12 | | C | D | +C | C2 | D21 D22 | +C +C where B2 has as column size the number of control inputs (NCON) +C and C2 has as row size the number of measurements (NMEAS) being +C provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank and D21 is full row rank, +C +C j*Theta +C (A3) | A-e *I B2 | has full column rank for all +C | C1 D12 | +C +C 0 <= Theta < 2*Pi , +C +C +C j*Theta +C (A4) | A-e *I B1 | has full row rank for all +C | C2 D21 | +C +C 0 <= Theta < 2*Pi . +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C A (input/worksp.) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C This array is modified internally, but it is restored on +C exit. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C RCOND (output) DOUBLE PRECISION array, dimension (7) +C RCOND contains estimates the reciprocal condition +C numbers of the matrices which are to be inverted and the +C reciprocal condition numbers of the Riccati equations +C which have to be solved during the computation of the +C controller. (See the description of the algorithm in [2].) +C RCOND(1) contains the reciprocal condition number of the +C control transformation matrix TU; +C RCOND(2) contains the reciprocal condition number of the +C measurement transformation matrix TY; +C RCOND(3) contains the reciprocal condition number of the +C matrix Im2 + B2'*X2*B2; +C RCOND(4) contains the reciprocal condition number of the +C matrix Ip2 + C2*Y2*C2'; +C RCOND(5) contains the reciprocal condition number of the +C X-Riccati equation; +C RCOND(6) contains the reciprocal condition number of the +C Y-Riccati equation; +C RCOND(7) contains the reciprocal condition number of the +C matrix Im2 + DKHAT*D22 . +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used for controlling the accuracy of the +C transformations applied for diagonalizing D12 and D21, +C and for checking the nonsingularity of the matrices to be +C inverted. If TOL <= 0, then a default value equal to +C sqrt(EPS) is used, where EPS is the relative machine +C precision. +C +C Workspace +C +C IWORK INTEGER array, dimension max(2*M2,2*N,N*N,NP2) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 + +C max(1,LW1,LW2,LW3,LW4,LW5,LW6), where +C LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)), +C LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)), +C LW3 = M2 + NP1*NP1 + max(NP1*max(N,M1),3*M2+NP1,5*M2), +C LW4 = NP2 + M1*M1 + max(max(N,NP1)*M1,3*NP2+M1,5*NP2), +C LW5 = 2*N*N+max(1,14*N*N+6*N+max(14*N+23,16*N),M2*(N+M2+ +C max(3,M1)),NP2*(N+NP2+3)), +C LW6 = max(N*M2,N*NP2,M2*NP2,M2*M2+4*M2), +C with M1 = M - M2 and NP1 = NP - NP2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is +C 2*Q*(3*Q+2*N)+max(1,(N+Q)*(N+Q+6),Q*(Q+max(N,Q,5)+1), +C 2*N*N+max(1,14*N*N+6*N+max(14*N+23,16*N), +C Q*(N+Q+max(Q,3)))). +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C j*Theta +C = 1: if the matrix | A-e *I B2 | had not full +C | C1 D12 | +C column rank in respect to the tolerance EPS; +C j*Theta +C = 2: if the matrix | A-e *I B1 | had not full +C | C2 D21 | +C row rank in respect to the tolerance EPS; +C = 3: if the matrix D12 had not full column rank in +C respect to the tolerance TOL; +C = 4: if the matrix D21 had not full row rank in respect +C to the tolerance TOL; +C = 5: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of one of +C the matrices |A-I B2 |, |A-I B1 |, D12 or D21). +C |C1 D12| |C2 D21| +C = 6: if the X-Riccati equation was not solved +C successfully; +C = 7: if the matrix Im2 + B2'*X2*B2 is not positive +C definite, or it is numerically singular (with +C respect to the tolerance TOL); +C = 8: if the Y-Riccati equation was not solved +C successfully; +C = 9: if the matrix Ip2 + C2*Y2*C2' is not positive +C definite, or it is numerically singular (with +C respect to the tolerance TOL); +C =10: if the matrix Im2 + DKHAT*D22 is singular, or its +C estimated condition number is larger than or equal +C to 1/TOL. +C +C METHOD +C +C The routine implements the formulas given in [1]. +C +C REFERENCES +C +C [1] Zhou, K., Doyle, J.C., and Glover, K. +C Robust and Optimal Control. +C Prentice-Hall, Upper Saddle River, NJ, 1996. +C +C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of linear +C discrete-time control systems. +C Report 99-8, Department of Engineering, Leicester University, +C April 1999. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C matrices which are to be inverted and on the condition numbers of +C the matrix Riccati equations which are to be solved in the +C computation of the controller. (The corresponding reciprocal +C condition numbers are given in the output array RCOND.) +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, May 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Sept. 1999, Feb. 2000, Nov. 2005. +C +C KEYWORDS +C +C Algebraic Riccati equation, H2 optimal control, optimal regulator, +C robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, M, N, NCON, NMEAS, NP + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( * ) + LOGICAL BWORK( * ) +C .. +C .. Local Scalars .. + INTEGER I, INFO2, IWC, IWD, IWRK, IWTU, IWTY, IWX, IWY, + $ LW1, LW2, LW3, LW4, LW5, LW6, LWAMAX, M1, M2, + $ M2L, MINWRK, NL, NLP, NP1, NP2, NPL + DOUBLE PRECISION TOLL +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DLACPY, SB10PD, SB10SD, SB10TD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS + NL = MAX( 1, N ) + NPL = MAX( 1, NP ) + M2L = MAX( 1, M2 ) + NLP = MAX( 1, NP2 ) +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.NL ) THEN + INFO = -7 + ELSE IF( LDB.LT.NL ) THEN + INFO = -9 + ELSE IF( LDC.LT.NPL ) THEN + INFO = -11 + ELSE IF( LDD.LT.NPL ) THEN + INFO = -13 + ELSE IF( LDAK.LT.NL ) THEN + INFO = -15 + ELSE IF( LDBK.LT.NL ) THEN + INFO = -17 + ELSE IF( LDCK.LT.M2L ) THEN + INFO = -19 + ELSE IF( LDDK.LT.M2L ) THEN + INFO = -21 + ELSE +C +C Compute workspace. +C + LW1 = ( N + NP1 + 1 )*( N + M2 ) + MAX( 3*( N + M2 ) + N + NP1, + $ 5*( N + M2 ) ) + LW2 = ( N + NP2 )*( N + M1 + 1 ) + MAX( 3*( N + NP2 ) + N + + $ M1, 5*( N + NP2 ) ) + LW3 = M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, 5*M2 ) + LW4 = NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, 5*NP2 ) + LW5 = 2*N*N + MAX( 1, 14*N*N + + $ 6*N + MAX( 14*N + 23, 16*N ), + $ M2*( N + M2 + MAX( 3, M1 ) ), + $ NP2*( N + NP2 + 3 ) ) + LW6 = MAX( N*M2, N*NP2, M2*NP2, M2*M2 + 4*M2 ) + MINWRK = N*M + NP*( N + M ) + M2*M2 + NP2*NP2 + + $ MAX( 1, LW1, LW2, LW3, LW4, LW5, LW6 ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -26 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10ED', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .AND. MAX( M2, NP2 ).EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + RCOND( 5 ) = ONE + RCOND( 6 ) = ONE + RCOND( 7 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance for rank tests. +C + TOLL = SQRT( DLAMCH( 'Epsilon' ) ) + END IF +C +C Workspace usage. +C + IWC = N*M + 1 + IWD = IWC + NP*N + IWTU = IWD + NP*M + IWTY = IWTU + M2*M2 + IWRK = IWTY + NP2*NP2 +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, NL ) + CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NPL ) + CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NPL ) +C +C Transform the system so that D12 and D21 satisfy the formulas +C in the computation of the H2 optimal controller. +C Since SLICOT Library routine SB10PD performs the tests +C corresponding to the continuous-time counterparts of the +C assumptions (A3) and (A4), for the frequency w = 0, the +C next SB10PD routine call uses A - I. +C + DO 10 I = 1, N + A(I,I) = A(I,I) - ONE + 10 CONTINUE +C + CALL SB10PD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, NL, + $ DWORK( IWC ), NPL, DWORK( IWD ), NPL, DWORK( IWTU ), + $ M2L, DWORK( IWTY ), NLP, RCOND, TOLL, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) +C + DO 20 I = 1, N + A(I,I) = A(I,I) + ONE + 20 CONTINUE +C + IF( INFO2.GT.0 ) THEN + INFO = INFO2 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C + IWX = IWRK + IWY = IWX + N*N + IWRK = IWY + N*N +C +C Compute the optimal H2 controller for the normalized system. +C + CALL SB10SD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, NL, + $ DWORK( IWC ), NPL, DWORK( IWD ), NPL, AK, LDAK, BK, + $ LDBK, CK, LDCK, DK, LDDK, DWORK( IWX ), NL, + $ DWORK( IWY ), NL, RCOND( 3 ), TOLL, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = INFO2 + 5 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C + IWRK = IWX +C +C Compute the H2 optimal controller for the original system. +C + CALL SB10TD( N, M, NP, NCON, NMEAS, DWORK( IWD ), NPL, + $ DWORK( IWTU ), M2L, DWORK( IWTY ), NLP, AK, LDAK, BK, + $ LDBK, CK, LDCK, DK, LDDK, RCOND( 7 ), TOLL, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 10 + RETURN + END IF +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10ED *** + END diff --git a/mex/sources/libslicot/SB10FD.f b/mex/sources/libslicot/SB10FD.f new file mode 100644 index 000000000..61fcdd4f3 --- /dev/null +++ b/mex/sources/libslicot/SB10FD.f @@ -0,0 +1,469 @@ + SUBROUTINE SB10FD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, + $ C, LDC, D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, + $ DK, LDDK, RCOND, TOL, IWORK, DWORK, LDWORK, + $ BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of an H-infinity (sub)optimal n-state +C controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C using modified Glover's and Doyle's 1988 formulas, for the system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 D22 | +C +C and for a given value of gamma, where B2 has as column size the +C number of control inputs (NCON) and C2 has as row size the number +C of measurements (NMEAS) being provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank and D21 is full row rank, +C +C (A3) | A-j*omega*I B2 | has full column rank for all omega, +C | C1 D12 | +C +C (A4) | A-j*omega*I B1 | has full row rank for all omega. +C | C2 D21 | +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C GAMMA (input) DOUBLE PRECISION +C The value of gamma. It is assumed that gamma is +C sufficiently large so that the controller is admissible. +C GAMMA >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C RCOND (output) DOUBLE PRECISION array, dimension (4) +C RCOND(1) contains the reciprocal condition number of the +C control transformation matrix; +C RCOND(2) contains the reciprocal condition number of the +C measurement transformation matrix; +C RCOND(3) contains an estimate of the reciprocal condition +C number of the X-Riccati equation; +C RCOND(4) contains an estimate of the reciprocal condition +C number of the Y-Riccati equation. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used for controlling the accuracy of the applied +C transformations for computing the normalized form in +C SLICOT Library routine SB10PD. Transformation matrices +C whose reciprocal condition numbers are less than TOL are +C not allowed. If TOL <= 0, then a default value equal to +C sqrt(EPS) is used, where EPS is the relative machine +C precision. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), where +C LIWORK = max(2*max(N,M-NCON,NP-NMEAS,NCON),N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 + +C max(1,LW1,LW2,LW3,LW4,LW5,LW6), where +C LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)), +C LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)), +C LW3 = M2 + NP1*NP1 + max(NP1*max(N,M1),3*M2+NP1,5*M2), +C LW4 = NP2 + M1*M1 + max(max(N,NP1)*M1,3*NP2+M1,5*NP2), +C LW5 = 2*N*N + N*(M+NP) + +C max(1,M*M + max(2*M1,3*N*N+max(N*M,10*N*N+12*N+5)), +C NP*NP + max(2*NP1,3*N*N + +C max(N*NP,10*N*N+12*N+5))), +C LW6 = 2*N*N + N*(M+NP) + +C max(1, M2*NP2 + NP2*NP2 + M2*M2 + +C max(D1*D1 + max(2*D1, (D1+D2)*NP2), +C D2*D2 + max(2*D2, D2*M2), 3*N, +C N*(2*NP2 + M2) + +C max(2*N*M2, M2*NP2 + +C max(M2*M2+3*M2, NP2*(2*NP2+ +C M2+max(NP2,N)))))), +C with D1 = NP1 - M2, D2 = M1 - NP2, +C NP1 = NP - NP2, M1 = M - M2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is +C 2*Q*(3*Q+2*N)+max(1,(N+Q)*(N+Q+6),Q*(Q+max(N,Q,5)+1), +C 2*N*(N+2*Q)+max(1,4*Q*Q+ +C max(2*Q,3*N*N+max(2*N*Q,10*N*N+12*N+5)), +C Q*(3*N+3*Q+max(2*N,4*Q+max(N,Q))))). +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix | A-j*omega*I B2 | had not full +C | C1 D12 | +C column rank in respect to the tolerance EPS; +C = 2: if the matrix | A-j*omega*I B1 | had not full row +C | C2 D21 | +C rank in respect to the tolerance EPS; +C = 3: if the matrix D12 had not full column rank in +C respect to the tolerance TOL; +C = 4: if the matrix D21 had not full row rank in respect +C to the tolerance TOL; +C = 5: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of one of +C the matrices |A B2 |, |A B1 |, D12 or D21). +C |C1 D12| |C2 D21| +C = 6: if the controller is not admissible (too small value +C of gamma); +C = 7: if the X-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 8: if the Y-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 9: if the determinant of Im2 + Tu*D11HAT*Ty*D22 is +C zero [3]. +C +C METHOD +C +C The routine implements the Glover's and Doyle's 1988 formulas [1], +C [2] modified to improve the efficiency as described in [3]. +C +C REFERENCES +C +C [1] Glover, K. and Doyle, J.C. +C State-space formulae for all stabilizing controllers that +C satisfy an Hinf norm bound and relations to risk sensitivity. +C Systems and Control Letters, vol. 11, pp. 167-172, 1988. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of continuous-time +C linear control systems. +C Rep. 98-14, Department of Engineering, Leicester University, +C Leicester, U.K., 1998. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C input and output transformations and on the condition numbers of +C the two Riccati equations, as given by the values of RCOND(1), +C RCOND(2), RCOND(3) and RCOND(4), respectively. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Sept. 1999, Feb. 2000. +C +C KEYWORDS +C +C Algebraic Riccati equation, H-infinity optimal control, robust +C control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, M, N, NCON, NMEAS, NP + DOUBLE PRECISION GAMMA, TOL +C .. +C .. Array Arguments .. + LOGICAL BWORK( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( 4 ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IWC, IWD, IWF, IWH, IWRK, IWTU, IWTY, + $ IWX, IWY, LW1, LW2, LW3, LW4, LW5, LW6, + $ LWAMAX, M1, M2, MINWRK, ND1, ND2, NP1, NP2 + DOUBLE PRECISION TOLL +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DLACPY, SB10PD, SB10QD, SB10RD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( GAMMA.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -14 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -20 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -22 + ELSE +C +C Compute workspace. +C + ND1 = NP1 - M2 + ND2 = M1 - NP2 + LW1 = ( N + NP1 + 1 )*( N + M2 ) + MAX( 3*( N + M2 ) + N + NP1, + $ 5*( N + M2 ) ) + LW2 = ( N + NP2 )*( N + M1 + 1 ) + MAX( 3*( N + NP2 ) + N + + $ M1, 5*( N + NP2 ) ) + LW3 = M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, 5*M2 ) + LW4 = NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, 5*NP2 ) + LW5 = 2*N*N + N*( M + NP ) + + $ MAX( 1, M*M + MAX( 2*M1, 3*N*N + + $ MAX( N*M, 10*N*N + 12*N + 5 ) ), + $ NP*NP + MAX( 2*NP1, 3*N*N + + $ MAX( N*NP, 10*N*N + 12*N + 5 ) ) ) + LW6 = 2*N*N + N*( M + NP ) + + $ MAX( 1, M2*NP2 + NP2*NP2 + M2*M2 + + $ MAX( ND1*ND1 + MAX( 2*ND1, ( ND1 + ND2 )*NP2 ), + $ ND2*ND2 + MAX( 2*ND2, ND2*M2 ), 3*N, + $ N*( 2*NP2 + M2 ) + + $ MAX( 2*N*M2, M2*NP2 + + $ MAX( M2*M2 + 3*M2, NP2*( 2*NP2 + + $ M2 + MAX( NP2, N ) ) ) ) ) ) + MINWRK = N*M + NP*( N + M ) + M2*M2 + NP2*NP2 + + $ MAX( 1, LW1, LW2, LW3, LW4, LW5, LW6 ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -27 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10FD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance. +C + TOLL = SQRT( DLAMCH( 'Epsilon' ) ) + END IF +C +C Workspace usage. +C + IWC = 1 + N*M + IWD = IWC + NP*N + IWTU = IWD + NP*M + IWTY = IWTU + M2*M2 + IWRK = IWTY + NP2*NP2 +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NP ) + CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NP ) +C +C Transform the system so that D12 and D21 satisfy the formulas +C in the computation of the Hinf (sub)optimal controller. +C + CALL SB10PD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWTU ), + $ M2, DWORK( IWTY ), NP2, RCOND, TOLL, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = INFO2 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C + IWX = IWRK + IWY = IWX + N*N + IWF = IWY + N*N + IWH = IWF + M*N + IWRK = IWH + N*NP +C +C Compute the (sub)optimal state feedback and output injection +C matrices. +C + CALL SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), + $ M, DWORK( IWH ), N, DWORK( IWX ), N, DWORK( IWY ), + $ N, RCOND(3), IWORK, DWORK( IWRK ), LDWORK-IWRK+1, + $ BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = INFO2 + 5 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute the Hinf (sub)optimal controller. +C + CALL SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), + $ M, DWORK( IWH ), N, DWORK( IWTU ), M2, DWORK( IWTY ), + $ NP2, DWORK( IWX ), N, DWORK( IWY ), N, AK, LDAK, BK, + $ LDBK, CK, LDCK, DK, LDDK, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.EQ.1 ) THEN + INFO = 6 + RETURN + ELSE IF( INFO2.EQ.2 ) THEN + INFO = 9 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10FD *** + END diff --git a/mex/sources/libslicot/SB10HD.f b/mex/sources/libslicot/SB10HD.f new file mode 100644 index 000000000..5e350a98c --- /dev/null +++ b/mex/sources/libslicot/SB10HD.f @@ -0,0 +1,390 @@ + SUBROUTINE SB10HD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, + $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, + $ RCOND, TOL, IWORK, DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the H2 optimal n-state controller +C +C | AK | BK | +C K = |----|----| +C | CK | DK | +C +C for the system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| , +C | C1 | 0 D12 | | C | D | +C | C2 | D21 D22 | +C +C where B2 has as column size the number of control inputs (NCON) +C and C2 has as row size the number of measurements (NMEAS) being +C provided to the controller. +c +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) The block D11 of D is zero, +C +C (A3) D12 is full column rank and D21 is full row rank. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C RCOND (output) DOUBLE PRECISION array, dimension (4) +C RCOND(1) contains the reciprocal condition number of the +C control transformation matrix; +C RCOND(2) contains the reciprocal condition number of the +C measurement transformation matrix; +C RCOND(3) contains an estimate of the reciprocal condition +C number of the X-Riccati equation; +C RCOND(4) contains an estimate of the reciprocal condition +C number of the Y-Riccati equation. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used for controlling the accuracy of the applied +C transformations for computing the normalized form in +C SLICOT Library routine SB10UD. Transformation matrices +C whose reciprocal condition numbers are less than TOL are +C not allowed. If TOL <= 0, then a default value equal to +C sqrt(EPS) is used, where EPS is the relative machine +C precision. +C +C Workspace +C +C IWORK INTEGER array, dimension max(2*N,N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 + +C max(max(M2 + NP1*NP1 + +C max(NP1*N,3*M2+NP1,5*M2), +C NP2 + M1*M1 + +C max(M1*N,3*NP2+M1,5*NP2), +C N*M2,NP2*N,NP2*M2,1), +C N*(14*N+12+M2+NP2)+5), +C where M1 = M - M2 and NP1 = NP - NP2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is +C 2*Q*(3*Q+2*N)+max(1,Q*(Q+max(N,5)+1),N*(14*N+12+2*Q)+5). +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix D12 had not full column rank in +C respect to the tolerance TOL; +C = 2: if the matrix D21 had not full row rank in respect +C to the tolerance TOL; +C = 3: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of one of +C the matrices D12 or D21). +C = 4: if the X-Riccati equation was not solved +C successfully; +C = 5: if the Y-Riccati equation was not solved +C successfully. +C +C METHOD +C +C The routine implements the formulas given in [1], [2]. +C +C REFERENCES +C +C [1] Zhou, K., Doyle, J.C., and Glover, K. +C Robust and Optimal Control. +C Prentice-Hall, Upper Saddle River, NJ, 1996. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C input and output transformations and on the condition numbers of +C the two Riccati equations, as given by the values of RCOND(1), +C RCOND(2), RCOND(3) and RCOND(4), respectively. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, Oct. 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Sept. 1999, Jan. 2000, Feb. 2000. +C +C KEYWORDS +C +C Algebraic Riccati equation, H2 optimal control, optimal regulator, +C robust control. +C +C ********************************************************************* +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, M, N, NCON, NMEAS, NP + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + LOGICAL BWORK( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( 4 ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IWC, IWD, IWF, IWH, IWRK, IWTU, IWTY, + $ IWY, LWAMAX, M1, M2, MINWRK, NP1, NP2 + DOUBLE PRECISION TOLL +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DLACPY, SB10UD, SB10VD, SB10WD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -13 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -19 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -21 + ELSE +C +C Compute workspace. +C + MINWRK = N*M + NP*(N+M) + M2*M2 + NP2*NP2 + + $ MAX( MAX( M2 + NP1*NP1 + + $ MAX( NP1*N, 3*M2 + NP1, 5*M2 ), + $ NP2 + M1*M1 + + $ MAX( M1*N, 3*NP2 + M1, 5*NP2 ), + $ N*M2, NP2*N, NP2*M2, 1 ), + $ N*( 14*N + 12 + M2 + NP2 ) + 5 ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -26 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10HD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance for rank tests. +C + TOLL = SQRT( DLAMCH( 'Epsilon' ) ) + END IF +C +C Workspace usage. +C + IWC = N*M + 1 + IWD = IWC + NP*N + IWTU = IWD + NP*M + IWTY = IWTU + M2*M2 + IWRK = IWTY + NP2*NP2 +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NP ) + CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NP ) +C +C Transform the system so that D12 and D21 satisfy the formulas +C in the computation of the H2 optimal controller. +C + CALL SB10UD( N, M, NP, NCON, NMEAS, DWORK, N, DWORK( IWC ), NP, + $ DWORK( IWD ), NP, DWORK( IWTU ), M2, DWORK( IWTY ), + $ NP2, RCOND, TOLL, DWORK( IWRK ), LDWORK-IWRK+1, + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = INFO2 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C + IWY = IWRK + IWF = IWY + N*N + IWH = IWF + M2*N + IWRK = IWH + N*NP2 +C +C Compute the optimal state feedback and output injection matrices. +C AK is used to store X. +C + CALL SB10VD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWF ), M2, DWORK( IWH ), N, + $ AK, LDAK, DWORK( IWY ), N, RCOND( 3 ), IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = INFO2 + 3 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute the H2 optimal controller. +C + CALL SB10WD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), M2, + $ DWORK( IWH ), N, DWORK( IWTU ), M2, DWORK( IWTY ), + $ NP2, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, INFO2 ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10HD *** + END diff --git a/mex/sources/libslicot/SB10ID.f b/mex/sources/libslicot/SB10ID.f new file mode 100644 index 000000000..2ea302e96 --- /dev/null +++ b/mex/sources/libslicot/SB10ID.f @@ -0,0 +1,584 @@ + SUBROUTINE SB10ID( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, + $ FACTOR, NK, AK, LDAK, BK, LDBK, CK, LDCK, + $ DK, LDDK, RCOND, IWORK, DWORK, LDWORK, BWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the positive feedback controller +C +C | Ak | Bk | +C K = |----|----| +C | Ck | Dk | +C +C for the shaped plant +C +C | A | B | +C G = |---|---| +C | C | D | +C +C in the McFarlane/Glover Loop Shaping Design Procedure. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the plant. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A of the shaped plant. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B of the shaped plant. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C of the shaped plant. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system matrix D of the shaped plant. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C FACTOR (input) DOUBLE PRECISION +C = 1 implies that an optimal controller is required; +C > 1 implies that a suboptimal controller is required, +C achieving a performance FACTOR less than optimal. +C FACTOR >= 1. +C +C NK (output) INTEGER +C The order of the positive feedback controller. NK <= N. +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading NK-by-NK part of this array contains the +C controller state matrix Ak. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NP) +C The leading NK-by-NP part of this array contains the +C controller input matrix Bk. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading M-by-NK part of this array contains the +C controller output matrix Ck. +C +C LDCK INTEGER +C The leading dimension of the array CK. LDCK >= max(1,M). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NP) +C The leading M-by-NP part of this array contains the +C controller matrix Dk. +C +C LDDK INTEGER +C The leading dimension of the array DK. LDDK >= max(1,M). +C +C RCOND (output) DOUBLE PRECISION array, dimension (2) +C RCOND(1) contains an estimate of the reciprocal condition +C number of the X-Riccati equation; +C RCOND(2) contains an estimate of the reciprocal condition +C number of the Z-Riccati equation. +C +C Workspace +C +C IWORK INTEGER array, dimension max(2*N,N*N,M,NP) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 4*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N + +C max( 6*N*N + 5 + max(1,4*N*N+8*N), N*NP + 2*N ). +C For good performance, LDWORK must generally be larger. +C An upper bound of LDWORK in the above formula is +C LDWORK >= 10*N*N + M*M + NP*NP + 2*M*N + 2*N*NP + 4*N + +C 5 + max(1,4*N*N+8*N). +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the X-Riccati equation is not solved successfully; +C = 2: the Z-Riccati equation is not solved successfully; +C = 3: the iteration to compute eigenvalues or singular +C values failed to converge; +C = 4: the matrix Ip - D*Dk is singular; +C = 5: the matrix Im - Dk*D is singular; +C = 6: the closed-loop system is unstable. +C +C METHOD +C +C The routine implements the formulas given in [1]. +C +C REFERENCES +C +C [1] McFarlane, D. and Glover, K. +C A loop shaping design procedure using H_infinity synthesis. +C IEEE Trans. Automat. Control, vol. AC-37, no. 6, pp. 759-769, +C 1992. +C +C NUMERICAL ASPECTS +C +C The accuracy of the results depends on the conditioning of the +C two Riccati equations solved in the controller design (see the +C output parameter RCOND). +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, +C Feb. 2001. +C +C KEYWORDS +C +C H_infinity control, Loop-shaping design, Robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, M, N, NK, NP + DOUBLE PRECISION FACTOR +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + LOGICAL BWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( 2 ) +C .. +C .. Local Scalars .. + CHARACTER*1 HINV + INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, + $ I11, I12, I13, INFO2, IWRK, J, LWA, LWAMAX, + $ MINWRK, N2, NS, SDIM + DOUBLE PRECISION SEP, FERR, GAMMA +C .. +C .. External Functions .. + LOGICAL SELECT + EXTERNAL SELECT +C .. +C .. External Subroutines .. + EXTERNAL DGEES, DGEMM, DLACPY, DLASET, DPOTRF, DPOTRS, + $ DSYRK, DTRSM, MB02VD, SB02RD, SB10JD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( FACTOR.LT.ONE ) THEN + INFO = -12 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDCK.LT.MAX( 1, M ) ) THEN + INFO = -19 + ELSE IF( LDDK.LT.MAX( 1, M ) ) THEN + INFO = -21 + END IF +C +C Compute workspace. +C + MINWRK = 4*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N + + $ MAX( 6*N*N + 5 + MAX( 1, 4*N*N + 8*N ), N*NP + 2*N ) + IF( LDWORK.LT.MINWRK ) THEN + INFO = -25 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10ID', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C +C Workspace usage. +C + I1 = N*N + I2 = I1 + N*N + I3 = I2 + M*N + I4 = I3 + M*N + I5 = I4 + M*M + I6 = I5 + NP*NP + I7 = I6 + NP*N + I8 = I7 + N*N + I9 = I8 + N*N + I10 = I9 + N*N + I11 = I10 + N*N + I12 = I11 + 2*N + I13 = I12 + 2*N +C + IWRK = I13 + 4*N*N +C +C Compute D'*C . +C + CALL DGEMM( 'T', 'N', M, N, NP, ONE, D, LDD, C, LDC, ZERO, + $ DWORK( I2+1 ), M ) +C +C Compute S = Im + D'*D . +C + CALL DLASET( 'U', M, M, ZERO, ONE, DWORK( I4+1 ), M ) + CALL DSYRK( 'U', 'T', M, NP, ONE, D, LDD, ONE, DWORK( I4+1 ), M ) +C +C Factorize S, S = T'*T, with T upper triangular. +C + CALL DPOTRF( 'U', M, DWORK( I4+1 ), M, INFO2 ) +C +C -1 +C Compute S D'*C . +C + CALL DPOTRS( 'U', M, N, DWORK( I4+1 ), M, DWORK( I2+1 ), M, + $ INFO2 ) +C +C -1 +C Compute B*T . +C + CALL DLACPY( 'F', N, M, B, LDB, DWORK( I3+1 ), N ) + CALL DTRSM( 'R', 'U', 'N', 'N', N, M, ONE, DWORK( I4+1 ), M, + $ DWORK( I3+1 ), N ) +C +C Compute R = Ip + D*D' . +C + CALL DLASET( 'U', NP, NP, ZERO, ONE, DWORK( I5+1 ), NP ) + CALL DSYRK( 'U', 'N', NP, M, ONE, D, LDD, ONE, DWORK( I5+1 ), NP ) +C +C Factorize R, R = U'*U, with U upper triangular. +C + CALL DPOTRF( 'U', NP, DWORK( I5+1 ), NP, INFO2 ) +C +C -T +C Compute U C . +C + CALL DLACPY( 'F', NP, N, C, LDC, DWORK( I6+1 ), NP ) + CALL DTRSM( 'L', 'U', 'T', 'N', NP, N, ONE, DWORK( I5+1 ), NP, + $ DWORK( I6+1 ), NP ) +C +C -1 +C Compute Ar = A - B*S D'*C . +C + CALL DLACPY( 'F', N, N, A, LDA, DWORK( I7+1 ), N ) + CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, DWORK( I2+1 ), M, + $ ONE, DWORK( I7+1 ), N ) +C +C -1 +C Compute the upper triangle of Cr = C'*R *C . +C + CALL DSYRK( 'U', 'T', N, NP, ONE, DWORK( I6+1 ), NP, ZERO, + $ DWORK( I8+1 ), N ) +C +C -1 +C Compute the upper triangle of Dr = B*S B' . +C + CALL DSYRK( 'U', 'N', N, M, ONE, DWORK( I3+1 ), N, ZERO, + $ DWORK( I9+1 ), N ) +C +C Solution of the Riccati equation Ar'*X + X*Ar + Cr - X*Dr*X = 0 . +C Workspace: need 10*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N + +C 5 + max(1,4*N*N+8*N). +C prefer larger. +C AK is used as workspace. +C + N2 = 2*N + CALL SB02RD( 'A', 'C', HINV, 'N', 'U', 'G', 'S', 'N', 'O', N, + $ DWORK( I7+1 ), N, DWORK( I10+1 ), N, AK, LDAK, + $ DWORK( I9+1 ), N, DWORK( I8+1 ), N, DWORK, N, SEP, + $ RCOND( 1 ), FERR, DWORK( I11+1 ), DWORK( I12+1 ), + $ DWORK( I13+1 ), N2, IWORK, DWORK( IWRK+1 ), + $ LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 1 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( MINWRK, LWA ) +C +C Solution of the Riccati equation Ar*Z + Z*Ar' + Dr - Z*Cr*Z = 0 . +C + CALL SB02RD( 'A', 'C', HINV, 'T', 'U', 'G', 'S', 'N', 'O', N, + $ DWORK( I7+1 ), N, DWORK( I10+1 ), N, AK, LDAK, + $ DWORK( I8+1 ), N, DWORK( I9+1 ), N, DWORK( I1+1 ), + $ N, SEP, RCOND( 2 ), FERR, DWORK( I11+1 ), + $ DWORK( I12+1 ), DWORK( I13+1 ), N2, IWORK, + $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 2 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) +C +C -1 -1 +C Compute F1 = -( S D'*C + S B'*X ) . +C + CALL DTRSM( 'R', 'U', 'T', 'N', N, M, ONE, DWORK( I4+1 ), M, + $ DWORK( I3+1 ), N ) + CALL DGEMM( 'T', 'N', M, N, N, -ONE, DWORK( I3+1 ), N, DWORK, N, + $ -ONE, DWORK( I2+1 ), M ) +C +C Compute gamma . +C + CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK, N, DWORK( I1+1 ), N, + $ ZERO, DWORK( I7+1 ), N ) + CALL DGEES( 'N', 'N', SELECT, N, DWORK( I7+1 ), N, SDIM, + $ DWORK( I11+1 ), DWORK( I12+1 ), DWORK( IWRK+1 ), N, + $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) + GAMMA = ZERO + DO 10 I = 1, N + GAMMA = MAX( GAMMA, DWORK( I11+I ) ) + 10 CONTINUE + GAMMA = FACTOR*SQRT( ONE + GAMMA ) +C +C Workspace usage. +C Workspace: need 4*N*N + M*N + N*NP. +C + I4 = I3 + N*N + I5 = I4 + N*N +C +C Compute Ac = A + B*F1 . +C + CALL DLACPY( 'F', N, N, A, LDA, DWORK( I4+1 ), N ) + CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, DWORK( I2+1 ), M, + $ ONE, DWORK( I4+1 ), N ) +C +C Compute W1' = (1-gamma^2)*In + Z*X . +C + CALL DLASET( 'F', N, N, ZERO, ONE-GAMMA*GAMMA, DWORK( I3+1 ), N ) + CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I1+1 ), N, DWORK, N, + $ ONE, DWORK( I3+1 ), N ) +C +C Compute Bcp = gamma^2*Z*C' . +C + CALL DGEMM( 'N', 'T', N, NP, N, GAMMA*GAMMA, DWORK( I1+1 ), N, C, + $ LDC, ZERO, BK, LDBK ) +C +C Compute C + D*F1 . +C + CALL DLACPY( 'F', NP, N, C, LDC, DWORK( I5+1 ), NP ) + CALL DGEMM( 'N', 'N', NP, N, M, ONE, D, LDD, DWORK( I2+1 ), M, + $ ONE, DWORK( I5+1 ), NP ) +C +C Compute Acp = W1'*Ac + gamma^2*Z*C'*(C+D*F1) . +C + CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I3+1 ), N, + $ DWORK( I4+1 ), N, ZERO, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, NP, ONE, BK, LDBK, + $ DWORK( I5+1 ), NP, ONE, AK, LDAK ) +C +C Compute Ccp = B'*X . +C + CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, DWORK, N, ZERO, + $ CK, LDCK ) +C +C Set Dcp = -D' . +C + DO 30 I = 1, M + DO 20 J = 1, NP + DK( I, J ) = -D( J, I ) + 20 CONTINUE + 30 CONTINUE +C + IWRK = I4 +C +C Reduce the generalized state-space description to a regular one. +C Workspace: need 3*N*N + M*N. +C Additional workspace: need 2*N*N + 2*N + N*MAX(5,N+M+NP). +C prefer larger. +C + CALL SB10JD( N, NP, M, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, + $ DWORK( I3+1 ), N, NK, DWORK( IWRK+1 ), LDWORK-IWRK, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) +C +C Workspace usage. +C Workspace: need 4*N*N + M*M + NP*NP + 2*M*N + 2*N*NP. +C (NK <= N.) +C + I2 = NP*NP + I3 = I2 + NK*NP + I4 = I3 + M*M + I5 = I4 + N*M + I6 = I5 + NP*NK + I7 = I6 + M*N +C + IWRK = I7 + ( N + NK )*( N + NK ) +C +C Compute Ip - D*Dk . +C + CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK, NP ) + CALL DGEMM( 'N', 'N', NP, NP, M, -ONE, D, LDD, DK, LDDK, ONE, + $ DWORK, NP ) +C +C -1 +C Compute Bk*(Ip-D*Dk) . +C + CALL DLACPY( 'F', NK, NP, BK, LDBK, DWORK( I2+1 ), NK ) + CALL MB02VD( 'N', NK, NP, DWORK, NP, IWORK, DWORK( I2+1 ), NK, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 4 + RETURN + END IF +C +C Compute Im - Dk*D . +C + CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK( I3+1 ), M ) + CALL DGEMM( 'N', 'N', M, M, NP, -ONE, DK, LDDK, D, LDD, ONE, + $ DWORK( I3+1 ), M ) +C +C -1 +C Compute B*(Im-Dk*D) . +C + CALL DLACPY( 'F', N, M, B, LDB, DWORK( I4+1 ), N ) + CALL MB02VD( 'N', N, M, DWORK( I3+1 ), M, IWORK, DWORK( I4+1 ), N, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF +C +C Compute D*Ck . +C + CALL DGEMM( 'N', 'N', NP, NK, M, ONE, D, LDD, CK, LDCK, ZERO, + $ DWORK( I5+1 ), NP ) +C +C Compute Dk*C . +C + CALL DGEMM( 'N', 'N', M, N, NP, ONE, DK, LDDK, C, LDC, ZERO, + $ DWORK( I6+1 ), M ) +C +C Compute the closed-loop state matrix. +C + CALL DLACPY( 'F', N, N, A, LDA, DWORK( I7+1 ), N+NK ) + CALL DGEMM( 'N', 'N', N, N, M, ONE, DWORK( I4+1 ), N, + $ DWORK( I6+1 ), M, ONE, DWORK( I7+1 ), N+NK ) + CALL DGEMM( 'N', 'N', NK, N, NP, ONE, DWORK( I2+1 ), NK, C, LDC, + $ ZERO, DWORK( I7+N+1 ), N+NK ) + CALL DGEMM( 'N', 'N', N, NK, M, ONE, DWORK( I4+1 ), N, CK, LDCK, + $ ZERO, DWORK( I7+(N+NK)*N+1 ), N+NK ) + CALL DLACPY( 'F', NK, NK, AK, LDAK, DWORK( I7+(N+NK)*N+N+1 ), + $ N+NK ) + CALL DGEMM( 'N', 'N', NK, NK, NP, ONE, DWORK( I2+1 ), NK, + $ DWORK( I5+1 ), NP, ONE, DWORK( I7+(N+NK)*N+N+1 ), + $ N+NK ) +C +C Compute the closed-loop poles. +C Additional workspace: need 3*(N+NK); prefer larger. +C The fact that M > 0, NP > 0, and NK <= N is used here. +C + CALL DGEES( 'N', 'N', SELECT, N+NK, DWORK( I7+1 ), N+NK, SDIM, + $ DWORK, DWORK( N+NK+1 ), DWORK( IWRK+1 ), N, + $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) +C +C Check the stability of the closed-loop system. +C + NS = 0 + DO 40 I = 1, N+NK + IF( DWORK( I ).GE.ZERO ) NS = NS + 1 + 40 CONTINUE + IF( NS.GT.0 ) THEN + INFO = 6 + RETURN + END IF +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10ID *** + END diff --git a/mex/sources/libslicot/SB10JD.f b/mex/sources/libslicot/SB10JD.f new file mode 100644 index 000000000..938b65088 --- /dev/null +++ b/mex/sources/libslicot/SB10JD.f @@ -0,0 +1,355 @@ + SUBROUTINE SB10JD( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, E, + $ LDE, NSYS, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To convert the descriptor state-space system +C +C E*dx/dt = A*x + B*u +C y = C*x + D*u +C +C into regular state-space form +C +C dx/dt = Ad*x + Bd*u +C y = Cd*x + Dd*u . +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the descriptor system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state matrix A of the descriptor system. +C On exit, the leading NSYS-by-NSYS part of this array +C contains the state matrix Ad of the converted system. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B of the descriptor system. +C On exit, the leading NSYS-by-M part of this array +C contains the input matrix Bd of the converted system. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading NP-by-N part of this array must +C contain the output matrix C of the descriptor system. +C On exit, the leading NP-by-NSYS part of this array +C contains the output matrix Cd of the converted system. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading NP-by-M part of this array must +C contain the matrix D of the descriptor system. +C On exit, the leading NP-by-M part of this array contains +C the matrix Dd of the converted system. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix E of the descriptor system. +C On exit, this array contains no useful information. +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= max(1,N). +C +C NSYS (output) INTEGER +C The order of the converted state-space system. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= max( 1, 2*N*N + 2*N + N*MAX( 5, N + M + NP ) ). +C For good performance, LDWORK must generally be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the iteration for computing singular value +C decomposition did not converge. +C +C METHOD +C +C The routine performs the transformations described in [1]. +C +C REFERENCES +C +C [1] Chiang, R.Y. and Safonov, M.G. +C Robust Control Toolbox User's Guide. +C The MathWorks Inc., Natick, Mass., 1992. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, +C Feb. 2001. +C +C KEYWORDS +C +C Descriptor systems, state-space models. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, M, N, + $ NP, NSYS +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), DWORK( * ), E( LDE, * ) +C .. +C .. Local Scalars .. + INTEGER I, IA12, IA21, IB2, IC2, INFO2, IS, ISA, IU, + $ IV, IWRK, J, K, LWA, LWAMAX, MINWRK, NS1 + DOUBLE PRECISION EPS, SCALE, TOL +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DGESVD, DLACPY, DLASET, DSCAL, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -13 + END IF +C +C Compute workspace. +C + MINWRK = MAX( 1, 2*N*( N + 1 ) + N*MAX( 5, N + M + NP ) ) + IF( LDWORK.LT.MINWRK ) THEN + INFO = -16 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10JD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + NSYS = 0 + DWORK( 1 ) = ONE + RETURN + END IF +C +C Set tol. +C + EPS = DLAMCH( 'Epsilon' ) + TOL = SQRT( EPS ) +C +C Workspace usage. +C + IS = 0 + IU = IS + N + IV = IU + N*N +C + IWRK = IV + N*N +C +C Compute the SVD of E. +C Additional workspace: need 5*N; prefer larger. +C + CALL DGESVD( 'S', 'S', N, N, E, LDE, DWORK( IS+1 ), DWORK( IU+1 ), + $ N, DWORK( IV+1 ), N, DWORK( IWRK+1 ), LDWORK-IWRK, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = MAX( MINWRK, INT( DWORK( IWRK+1 ) + IWRK ) ) +C +C Determine the rank of E. +C + NS1 = 0 + DO 10 I = 1, N + IF( DWORK( IS+I ).GT.TOL ) NS1 = NS1 + 1 + 10 CONTINUE + IF( NS1.GT.0 ) THEN +C +C Transform A. +C Additional workspace: need N*max(N,M,NP). +C + CALL DGEMM( 'T', 'N', N, N, N, ONE, DWORK( IU+1 ), N, A, LDA, + $ ZERO, DWORK( IWRK+1 ), N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, DWORK( IWRK+1 ), N, + $ DWORK( IV+1 ), N, ZERO, A, LDA ) +C +C Transform B. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK( IWRK+1 ), N ) + CALL DGEMM( 'T', 'N', N, M, N, ONE, DWORK( IU+1 ), N, + $ DWORK( IWRK+1 ), N, ZERO, B, LDB ) +C +C Transform C. +C + CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWRK+1 ), NP ) + CALL DGEMM( 'N', 'T', NP, N, N, ONE, DWORK( IWRK+1 ), NP, + $ DWORK( IV+1 ), N, ZERO, C, LDC ) +C + K = N - NS1 + IF( K.GT.0 ) THEN + ISA = IU + K*K + IV = ISA + K + IWRK = IV + K*MAX( K, NS1 ) +C +C Compute the SVD of A22. +C Additional workspace: need 5*K; prefer larger. +C + CALL DGESVD( 'S', 'S', K, K, A( NS1+1, NS1+1 ), LDA, + $ DWORK( ISA+1 ), DWORK( IU+1 ), K, + $ DWORK( IV+1 ), K, DWORK( IWRK+1 ), LDWORK-IWRK, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 1 + RETURN + END IF + IA12 = IWRK + IB2 = IA12 + NS1*K + IC2 = IB2 + K*M +C + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX, IC2 + K*NP ) +C +C Compute the transformed A12. +C + CALL DGEMM( 'N', 'T', NS1, K, K, ONE, A( 1, NS1+1 ), LDA, + $ DWORK( IV+1 ), K, ZERO, DWORK( IA12+1 ), NS1 ) +C +C Compute CC2. +C + CALL DGEMM( 'N', 'T', NP, K, K, ONE, C( 1, NS1+1 ), LDC, + $ DWORK( IV+1 ), K, ZERO, DWORK( IC2+1 ), NP ) +C +C Compute the transformed A21. +C + IA21 = IV + CALL DGEMM( 'T', 'N', K, NS1, K, ONE, DWORK( IU+1 ), K, + $ A( NS1+1, 1 ), LDA, ZERO, DWORK( IA21+1 ), K ) +C +C Compute BB2. +C + CALL DGEMM( 'T', 'N', K, M, K, ONE, DWORK( IU+1 ), K, + $ B( NS1+1, 1 ), LDB, ZERO, DWORK( IB2+1 ), K ) +C +C Compute A12*pinv(A22) and CC2*pinv(A22). +C + DO 20 J = 1, K + SCALE = ZERO + IF( DWORK( ISA+J ).GT.TOL ) SCALE = ONE/DWORK( ISA+J ) + CALL DSCAL( NS1, SCALE, DWORK( IA12+(J-1)*NS1+1 ), 1 ) + CALL DSCAL( NP, SCALE, DWORK( IC2+(J-1)*NP+1 ), 1 ) + 20 CONTINUE +C +C Compute Ad. +C + CALL DGEMM( 'N', 'N', NS1, NS1, K, -ONE, DWORK( IA12+1 ), + $ NS1, DWORK( IA21+1 ), K, ONE, A, LDA ) +C +C Compute Bd. +C + CALL DGEMM( 'N', 'N', NS1, M, K, -ONE, DWORK( IA12+1 ), NS1, + $ DWORK( IB2+1 ), K, ONE, B, LDB ) +C +C Compute Cd. +C + CALL DGEMM( 'N', 'N', NP, NS1, K, -ONE, DWORK( IC2+1 ), NP, + $ DWORK( IA21+1 ), K, ONE, C, LDC ) +C +C Compute Dd. +C + CALL DGEMM( 'N', 'N', NP, M, K, -ONE, DWORK( IC2+1 ), NP, + $ DWORK( IB2+1 ), K, ONE, D, LDD ) + END IF + DO 30 I = 1, NS1 + SCALE = ONE/SQRT( DWORK( IS+I ) ) + CALL DSCAL( NS1, SCALE, A( I, 1 ), LDA ) + CALL DSCAL( M, SCALE, B( I, 1 ), LDB ) + 30 CONTINUE + DO 40 J = 1, NS1 + SCALE = ONE/SQRT( DWORK( IS+J ) ) + CALL DSCAL( NS1, SCALE, A( 1, J ), 1 ) + CALL DSCAL( NP, SCALE, C( 1, J ), 1 ) + 40 CONTINUE + NSYS = NS1 + ELSE + CALL DLASET( 'F', N, N, ZERO, -ONE/EPS, A, LDA ) + CALL DLASET( 'F', N, M, ZERO, ZERO, B, LDB ) + CALL DLASET( 'F', NP, N, ZERO, ZERO, C, LDC ) + NSYS = N + END IF + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10JD *** + END diff --git a/mex/sources/libslicot/SB10KD.f b/mex/sources/libslicot/SB10KD.f new file mode 100644 index 000000000..38f1cef01 --- /dev/null +++ b/mex/sources/libslicot/SB10KD.f @@ -0,0 +1,650 @@ + SUBROUTINE SB10KD( N, M, NP, A, LDA, B, LDB, C, LDC, FACTOR, + $ AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, RCOND, + $ IWORK, DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the positive feedback controller +C +C | Ak | Bk | +C K = |----|----| +C | Ck | Dk | +C +C for the shaped plant +C +C | A | B | +C G = |---|---| +C | C | 0 | +C +C in the Discrete-Time Loop Shaping Design Procedure. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the plant. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A of the shaped plant. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B of the shaped plant. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C of the shaped plant. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C FACTOR (input) DOUBLE PRECISION +C = 1 implies that an optimal controller is required; +C > 1 implies that a suboptimal controller is required +C achieving a performance FACTOR less than optimal. +C FACTOR >= 1. +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix Ak. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NP) +C The leading N-by-NP part of this array contains the +C controller input matrix Bk. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading M-by-N part of this array contains the +C controller output matrix Ck. +C +C LDCK INTEGER +C The leading dimension of the array CK. LDCK >= max(1,M). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NP) +C The leading M-by-NP part of this array contains the +C controller matrix Dk. +C +C LDDK INTEGER +C The leading dimension of the array DK. LDDK >= max(1,M). +C +C RCOND (output) DOUBLE PRECISION array, dimension (4) +C RCOND(1) contains an estimate of the reciprocal condition +C number of the linear system of equations from +C which the solution of the P-Riccati equation is +C obtained; +C RCOND(2) contains an estimate of the reciprocal condition +C number of the linear system of equations from +C which the solution of the Q-Riccati equation is +C obtained; +C RCOND(3) contains an estimate of the reciprocal condition +C number of the linear system of equations from +C which the solution of the X-Riccati equation is +C obtained; +C RCOND(4) contains an estimate of the reciprocal condition +C number of the matrix Rx + Bx'*X*Bx (see the +C comments in the code). +C +C Workspace +C +C IWORK INTEGER array, dimension 2*max(N,NP+M) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 15*N*N + 6*N + +C max( 14*N+23, 16*N, 2*N+NP+M, 3*(NP+M) ) + +C max( N*N, 11*N*NP + 2*M*M + 8*NP*NP + 8*M*N + +C 4*M*NP + NP ). +C For good performance, LDWORK must generally be larger. +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the P-Riccati equation is not solved successfully; +C = 2: the Q-Riccati equation is not solved successfully; +C = 3: the X-Riccati equation is not solved successfully; +C = 4: the iteration to compute eigenvalues failed to +C converge; +C = 5: the matrix Rx + Bx'*X*Bx is singular; +C = 6: the closed-loop system is unstable. +C +C METHOD +C +C The routine implements the method presented in [1]. +C +C REFERENCES +C +C [1] McFarlane, D. and Glover, K. +C A loop shaping design procedure using H_infinity synthesis. +C IEEE Trans. Automat. Control, vol. AC-37, no. 6, pp. 759-769, +C 1992. +C +C NUMERICAL ASPECTS +C +C The accuracy of the results depends on the conditioning of the +C two Riccati equations solved in the controller design. For +C better conditioning it is advised to take FACTOR > 1. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 2000. +C +C REVISIONS +C +C V. Sima, Katholieke University Leuven, January 2001, +C February 2001. +C +C KEYWORDS +C +C H_infinity control, Loop-shaping design, Robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDDK, + $ LDWORK, M, N, NP + DOUBLE PRECISION FACTOR +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + LOGICAL BWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ DK( LDDK, * ), DWORK( * ), RCOND( 4 ) +C .. +C .. Local Scalars .. + INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, + $ I11, I12, I13, I14, I15, I16, I17, I18, I19, + $ I20, I21, I22, I23, I24, I25, I26, INFO2, + $ IWRK, J, LWA, LWAMAX, MINWRK, N2, NS, SDIM + DOUBLE PRECISION GAMMA, RNORM +C .. +C .. External Functions .. + LOGICAL SELECT + DOUBLE PRECISION DLANSY, DLAPY2 + EXTERNAL DLANSY, DLAPY2, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DGEES, DLACPY, DLASET, DPOTRF, DPOTRS, + $ DSYCON, DSYEV, DSYRK, DSYTRF, DSYTRS, SB02OD, + $ XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -9 + ELSE IF( FACTOR.LT.ONE ) THEN + INFO = -10 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDCK.LT.MAX( 1, M ) ) THEN + INFO = -16 + ELSE IF( LDDK.LT.MAX( 1, M ) ) THEN + INFO = -18 + END IF +C +C Compute workspace. +C + MINWRK = 15*N*N + 6*N + MAX( 14*N+23, 16*N, 2*N+NP+M, 3*(NP+M) ) + + $ MAX( N*N, 11*N*NP + 2*M*M + 8*NP*NP + 8*M*N + + $ 4*M*NP + NP ) + IF( LDWORK.LT.MINWRK ) THEN + INFO = -22 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10KD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C +C Workspace usage. +C + N2 = 2*N + I1 = N*N + I2 = I1 + N*N + I3 = I2 + N*N + I4 = I3 + N*N + I5 = I4 + N2 + I6 = I5 + N2 + I7 = I6 + N2 + I8 = I7 + N2*N2 + I9 = I8 + N2*N2 +C + IWRK = I9 + N2*N2 + LWAMAX = 0 +C +C Compute Cr = C'*C . +C + CALL DSYRK( 'U', 'T', N, NP, ONE, C, LDC, ZERO, DWORK( I2+1 ), N ) +C +C Compute Dr = B*B' . +C + CALL DSYRK( 'U', 'N', N, M, ONE, B, LDB, ZERO, DWORK( I3+1 ), N ) +C -1 +C Solution of the Riccati equation A'*P*(In + Dr*P) *A - P + Cr = 0. +C + CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, A, LDA, + $ DWORK( I3+1 ), N, DWORK( I2+1 ), N, DWORK, M, DWORK, + $ N, RCOND( 1 ), DWORK, N, DWORK( I4+1 ), + $ DWORK( I5+1 ), DWORK( I6+1 ), DWORK( I7+1 ), N2, + $ DWORK( I8+1 ), N2, DWORK( I9+1 ), N2, -ONE, IWORK, + $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 1 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) +C +C Transpose A in AK (used as workspace). +C + DO 40 J = 1, N + DO 30 I = 1, N + AK( I,J ) = A( J,I ) + 30 CONTINUE + 40 CONTINUE +C -1 +C Solution of the Riccati equation A*Q*(In + Cr*Q) *A' - Q + Dr = 0. +C + CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, AK, LDAK, + $ DWORK( I2+1 ), N, DWORK( I3+1 ), N, DWORK, M, DWORK, + $ N, RCOND( 2 ), DWORK( I1+1 ), N, DWORK( I4+1 ), + $ DWORK( I5+1 ), DWORK( I6+1 ), DWORK( I7+1 ), N2, + $ DWORK( I8+1 ), N2, DWORK( I9+1 ), N2, -ONE, IWORK, + $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 2 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) +C +C Compute gamma. +C + CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I1+1 ), N, DWORK, N, + $ ZERO, AK, LDAK ) + CALL DGEES( 'N', 'N', SELECT, N, AK, LDAK, SDIM, DWORK( I6+1 ), + $ DWORK( I7+1 ), DWORK( IWRK+1 ), N, DWORK( IWRK+1 ), + $ LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 4 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) + GAMMA = ZERO + DO 50 I = 1, N + GAMMA = MAX( GAMMA, DWORK( I6+I ) ) + 50 CONTINUE + GAMMA = FACTOR*SQRT( ONE + GAMMA ) +C +C Workspace usage. +C + I3 = I2 + N*NP + I4 = I3 + NP*NP + I5 = I4 + NP*NP + I6 = I5 + NP*NP + I7 = I6 + NP + I8 = I7 + NP*NP + I9 = I8 + NP*NP + I10 = I9 + NP*NP + I11 = I10 + N*NP + I12 = I11 + N*NP + I13 = I12 + ( NP+M )*( NP+M ) + I14 = I13 + N*( NP+M ) + I15 = I14 + N*( NP+M ) + I16 = I15 + N*N + I17 = I16 + N2 + I18 = I17 + N2 + I19 = I18 + N2 + I20 = I19 + ( N2+NP+M )*( N2+NP+M ) + I21 = I20 + ( N2+NP+M )*N2 +C + IWRK = I21 + N2*N2 +C +C Compute Q*C' . +C + CALL DGEMM( 'N', 'T', N, NP, N, ONE, DWORK( I1+1 ), N, C, LDC, + $ ZERO, DWORK( I2+1 ), N ) +C +C Compute Ip + C*Q*C' . +C + CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK( I3+1 ), NP ) + CALL DGEMM( 'N', 'N', NP, NP, N, ONE, C, LDC, DWORK( I2+1 ), N, + $ ONE, DWORK( I3+1 ), NP ) +C +C Compute the eigenvalues and eigenvectors of Ip + C'*Q*C +C + CALL DLACPY( 'U', NP, NP, DWORK( I3+1 ), NP, DWORK( I5+1 ), NP ) + CALL DSYEV( 'V', 'U', NP, DWORK( I5+1 ), NP, DWORK( I6+1 ), + $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 4 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) +C -1 +C Compute ( Ip + C'*Q*C ) . +C + DO 70 J = 1, NP + DO 60 I = 1, NP + DWORK( I9+I+(J-1)*NP ) = DWORK( I5+J+(I-1)*NP ) / + $ DWORK( I6+I ) + 60 CONTINUE + 70 CONTINUE + CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I5+1 ), NP, + $ DWORK( I9+1 ), NP, ZERO, DWORK( I4+1 ), NP ) +C +C Compute Z2 . +C + DO 90 J = 1, NP + DO 80 I = 1, NP + DWORK( I9+I+(J-1)*NP ) = DWORK( I5+J+(I-1)*NP ) / + $ SQRT( DWORK( I6+I ) ) + 80 CONTINUE + 90 CONTINUE + CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I5+1 ), NP, + $ DWORK( I9+1 ), NP, ZERO, DWORK( I7+1 ), NP ) +C -1 +C Compute Z2 . +C + DO 110 J = 1, NP + DO 100 I = 1, NP + DWORK( I9+I+(J-1)*NP ) = DWORK( I5+J+(I-1)*NP )* + $ SQRT( DWORK( I6+I ) ) + 100 CONTINUE + 110 CONTINUE + CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I5+1 ), NP, + $ DWORK( I9+1 ), NP, ZERO, DWORK( I8+1 ), NP ) +C +C Compute A*Q*C' . +C + CALL DGEMM( 'N', 'N', N, NP, N, ONE, A, LDA, DWORK( I2+1 ), N, + $ ZERO, DWORK( I10+1 ), N ) +C -1 +C Compute H = -A*Q*C'*( Ip + C*Q*C' ) . +C + CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I10+1 ), N, + $ DWORK( I4+1 ), NP, ZERO, DWORK( I11+1 ), N ) +C +C Compute Rx . +C + CALL DLASET( 'F', NP+M, NP+M, ZERO, ONE, DWORK( I12+1 ), NP+M ) + DO 130 J = 1, NP + DO 120 I = 1, NP + DWORK( I12+I+(J-1)*(NP+M) ) = DWORK( I3+I+(J-1)*NP ) + 120 CONTINUE + DWORK( I12+J+(J-1)*(NP+M) ) = DWORK( I3+J+(J-1)*NP ) - + $ GAMMA*GAMMA + 130 CONTINUE +C +C Compute Bx . +C + CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I11+1 ), N, + $ DWORK( I8+1 ), NP, ZERO, DWORK( I13+1 ), N ) + DO 150 J = 1, M + DO 140 I = 1, N + DWORK( I13+N*NP+I+(J-1)*N ) = B( I, J ) + 140 CONTINUE + 150 CONTINUE +C +C Compute Sx . +C + CALL DGEMM( 'T', 'N', N, NP, NP, ONE, C, LDC, DWORK( I8+1 ), NP, + $ ZERO, DWORK( I14+1 ), N ) + CALL DLASET( 'F', N, M, ZERO, ZERO, DWORK( I14+N*NP+1 ), N ) +C +C Solve the Riccati equation +C -1 +C X = A'*X*A + Cx - (Sx + A'*X*Bx)*(Rx + Bx'*X*B ) *(Sx'+Bx'*X*A). +C + CALL SB02OD( 'D', 'B', 'C', 'U', 'N', 'S', N, NP+M, NP, A, LDA, + $ DWORK( I13+1 ), N, C, LDC, DWORK( I12+1 ), NP+M, + $ DWORK( I14+1 ), N, RCOND( 3 ), DWORK( I15+1 ), N, + $ DWORK( I16+1 ), DWORK( I17+1 ), DWORK( I18+1 ), + $ DWORK( I19+1 ), N2+NP+M, DWORK( I20+1 ), N2+NP+M, + $ DWORK( I21+1 ), N2, -ONE, IWORK, DWORK( IWRK+1 ), + $ LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) +C + I22 = I16 + I23 = I22 + ( NP+M )*N + I24 = I23 + ( NP+M )*( NP+M ) + I25 = I24 + ( NP+M )*N + I26 = I25 + M*N +C + IWRK = I25 +C +C Compute Bx'*X . +C + CALL DGEMM( 'T', 'N', NP+M, N, N, ONE, DWORK( I13+1 ), N, + $ DWORK( I15+1 ), N, ZERO, DWORK( I22+1 ), NP+M ) +C +C Compute Rx + Bx'*X*Bx . +C + CALL DLACPY( 'F', NP+M, NP+M, DWORK( I12+1 ), NP+M, + $ DWORK( I23+1 ), NP+M ) + CALL DGEMM( 'N', 'N', NP+M, NP+M, N, ONE, DWORK( I22+1 ), NP+M, + $ DWORK( I13+1 ), N, ONE, DWORK( I23+1 ), NP+M ) +C +C Compute -( Sx' + Bx'*X*A ) . +C + DO 170 J = 1, N + DO 160 I = 1, NP+M + DWORK( I24+I+(J-1)*(NP+M) ) = DWORK( I14+J+(I-1)*N ) + 160 CONTINUE + 170 CONTINUE + CALL DGEMM( 'N', 'N', NP+M, N, N, -ONE, DWORK( I22+1 ), NP+M, + $ A, LDA, -ONE, DWORK( I24+1 ), NP+M ) +C +C Factorize Rx + Bx'*X*Bx . +C + RNORM = DLANSY( '1', 'U', NP+M, DWORK( I23+1 ), NP+M, + $ DWORK( IWRK+1 ) ) + CALL DSYTRF( 'U', NP+M, DWORK( I23+1 ), NP+M, IWORK, + $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) + CALL DSYCON( 'U', NP+M, DWORK( I23+1 ), NP+M, IWORK, RNORM, + $ RCOND( 4 ), DWORK( IWRK+1 ), IWORK( NP+M+1), INFO2 ) +C -1 +C Compute F = -( Rx + Bx'*X*Bx ) ( Sx' + Bx'*X*A ) . +C + CALL DSYTRS( 'U', NP+M, N, DWORK( I23+1 ), NP+M, IWORK, + $ DWORK( I24+1 ), NP+M, INFO2 ) +C +C Compute B'*X . +C + CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, DWORK( I15+1 ), N, + $ ZERO, DWORK( I25+1 ), M ) +C +C Compute Im + B'*X*B . +C + CALL DLASET( 'F', M, M, ZERO, ONE, DWORK( I23+1 ), M ) + CALL DGEMM( 'N', 'N', M, M, N, ONE, DWORK( I25+1 ), M, B, LDB, + $ ONE, DWORK( I23+1 ), M ) +C +C Factorize Im + B'*X*B . +C + CALL DPOTRF( 'U', M, DWORK( I23+1 ), M, INFO2 ) +C -1 +C Compute ( Im + B'*X*B ) B'*X . +C + CALL DPOTRS( 'U', M, N, DWORK( I23+1 ), M, DWORK( I25+1 ), M, + $ INFO2 ) +C -1 +C Compute Dk = ( Im + B'*X*B ) B'*X*H . +C + CALL DGEMM( 'N', 'N', M, NP, N, ONE, DWORK( I25+1 ), M, + $ DWORK( I11+1 ), N, ZERO, DK, LDDK ) +C +C Compute Bk = -H + B*Dk . +C + CALL DLACPY( 'F', N, NP, DWORK( I11+1 ), N, BK, LDBK ) + CALL DGEMM( 'N', 'N', N, NP, M, ONE, B, LDB, DK, LDDK, -ONE, + $ BK, LDBK ) +C -1 +C Compute Dk*Z2 . +C + CALL DGEMM( 'N', 'N', M, NP, NP, ONE, DK, LDDK, DWORK( I8+1 ), + $ NP, ZERO, DWORK( I26+1 ), M ) +C +C Compute F1 + Z2*C . +C + CALL DLACPY( 'F', NP, N, DWORK( I24+1 ), NP+M, DWORK( I12+1 ), + $ NP ) + CALL DGEMM( 'N', 'N', NP, N, NP, ONE, DWORK( I7+1 ), NP, C, LDC, + $ ONE, DWORK( I12+1 ), NP ) +C -1 +C Compute Ck = F2 - Dk*Z2 *( F1 + Z2*C ) . +C + CALL DLACPY( 'F', M, N, DWORK( I24+NP+1 ), NP+M, CK, LDCK ) + CALL DGEMM( 'N', 'N', M, N, NP, -ONE, DWORK( I26+1 ), M, + $ DWORK( I12+1 ), NP, ONE, CK, LDCK ) +C +C Compute Ak = A + H*C + B*Ck . +C + CALL DLACPY( 'F', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I11+1 ), N, C, LDC, + $ ONE, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, CK, LDCK, ONE, AK, + $ LDAK ) +C +C Workspace usage. +C + I1 = M*N + I2 = I1 + N2*N2 + I3 = I2 + N2 +C + IWRK = I3 + N2 +C +C Compute Dk*C . +C + CALL DGEMM( 'N', 'N', M, N, NP, ONE, DK, LDDK, C, LDC, ZERO, + $ DWORK, M ) +C +C Compute the closed-loop state matrix. +C + CALL DLACPY( 'F', N, N, A, LDA, DWORK( I1+1 ), N2 ) + CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, DWORK, M, ONE, + $ DWORK( I1+1 ), N2 ) + CALL DGEMM( 'N', 'N', N, N, NP, -ONE, BK, LDBK, C, LDC, ZERO, + $ DWORK( I1+N+1 ), N2 ) + CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, CK, LDCK, ZERO, + $ DWORK( I1+N2*N+1 ), N2 ) + CALL DLACPY( 'F', N, N, AK, LDAK, DWORK( I1+N2*N+N+1 ), N2 ) +C +C Compute the closed-loop poles. +C + CALL DGEES( 'N', 'N', SELECT, N2, DWORK( I1+1 ), N2, SDIM, + $ DWORK( I2+1 ), DWORK( I3+1 ), DWORK( IWRK+1 ), N, + $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 4 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) +C +C Check the stability of the closed-loop system. +C + NS = 0 + DO 180 I = 1, N2 + IF( DLAPY2( DWORK( I2+I ), DWORK( I3+I ) ).GT.ONE ) NS = NS + 1 + 180 CONTINUE + IF( NS.GT.0 ) THEN + INFO = 6 + RETURN + END IF +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10KD *** + END diff --git a/mex/sources/libslicot/SB10LD.f b/mex/sources/libslicot/SB10LD.f new file mode 100644 index 000000000..b2d7d06b3 --- /dev/null +++ b/mex/sources/libslicot/SB10LD.f @@ -0,0 +1,438 @@ + SUBROUTINE SB10LD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, + $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, + $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the closed-loop system +C +C | AC | BC | +C G = |----|----|, +C | CC | DC | +C +C from the matrices of the open-loop system +C +C | A | B | +C P = |---|---| +C | C | D | +C +C and the matrices of the controller +C +C | AK | BK | +C K = |----|----|. +C | CK | DK | +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0. +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0. +C M-NCON >= NMEAS. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (input) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array must contain the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (input) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array must contain the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (input) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array must contain the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (input) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array must contain +C the controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C AC (output) DOUBLE PRECISION array, dimension (LDAC,2*N) +C The leading 2*N-by-2*N part of this array contains the +C closed-loop system state matrix AC. +C +C LDAC INTEGER +C The leading dimension of the array AC. +C LDAC >= max(1,2*N). +C +C BC (output) DOUBLE PRECISION array, dimension (LDBC,M-NCON) +C The leading 2*N-by-(M-NCON) part of this array contains +C the closed-loop system input matrix BC. +C +C LDBC INTEGER +C The leading dimension of the array BC. +C LDBC >= max(1,2*N). +C +C CC (output) DOUBLE PRECISION array, dimension (LDCC,2*N) +C The leading (NP-NMEAS)-by-2*N part of this array contains +C the closed-loop system output matrix CC. +C +C LDCC INTEGER +C The leading dimension of the array CC. +C LDCC >= max(1,NP-NMEAS). +C +C DC (output) DOUBLE PRECISION array, dimension (LDDC,M-NCON) +C The leading (NP-NMEAS)-by-(M-NCON) part of this array +C contains the closed-loop system input/output matrix DC. +C +C LDDC INTEGER +C The leading dimension of the array DC. +C LDDC >= max(1,NP-NMEAS). +C +C Workspace +C +C IWORK INTEGER array, dimension 2*max(NCON,NMEAS) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 2*M*M+NP*NP+2*M*N+M*NP+2*N*NP. +C For good performance, LDWORK must generally be larger. +C +C Error Indicactor +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix Inp2 - D22*DK is singular to working +C precision; +C = 2: if the matrix Im2 - DK*D22 is singular to working +C precision. +C +C METHOD +C +C The routine implements the formulas given in [1]. +C +C REFERENCES +C +C [1] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C matrices Inp2 - D22*DK and Im2 - DK*D22. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999. +C A. Markovski, Technical University, Sofia, April, 2003. +C +C KEYWORDS +C +C Closed loop systems, feedback control, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAC, LDAK, LDB, LDBC, LDBK, LDC, + $ LDCC, LDCK, LDD, LDDC, LDDK, LDWORK, M, N, + $ NCON, NMEAS, NP +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AC( LDAC, * ), AK( LDAK, * ), + $ B( LDB, * ), BC( LDBC, * ), BK( LDBK, * ), + $ C( LDC, * ), CC( LDCC, * ), CK( LDCK, * ), + $ D( LDD, * ), DC( LDDC, * ), DK( LDDK, * ), + $ DWORK( * ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IW2, IW3, IW4, IW5, IW6, IW7, IW8, IWRK, + $ LWAMAX, M1, M2, MINWRK, N2, NP1, NP2 + DOUBLE PRECISION ANORM, EPS, RCOND +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE +C .. +C .. External Subroutines .. + EXTERNAL DGECON, DGEMM, DGETRF, DGETRI, DLACPY, DLASET, + $ XERBLA +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + N2 = 2*N + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -13 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -19 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -21 + ELSE IF( LDAC.LT.MAX( 1, N2 ) ) THEN + INFO = -23 + ELSE IF( LDBC.LT.MAX( 1, N2 ) ) THEN + INFO = -25 + ELSE IF( LDCC.LT.MAX( 1, NP1 ) ) THEN + INFO = -27 + ELSE IF( LDDC.LT.MAX( 1, NP1 ) ) THEN + INFO = -29 + ELSE +C +C Compute workspace. +C + MINWRK = 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP + IF( LDWORK.LT.MINWRK ) + $ INFO = -32 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10LD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + DWORK( 1 ) = ONE + RETURN + END IF +C +C Get the machine precision. +C + EPS = DLAMCH( 'Epsilon' ) +C +C Workspace usage. +C + IW2 = NP2*NP2 + 1 + IW3 = IW2 + M2*M2 + IW4 = IW3 + NP2*N + IW5 = IW4 + M2*N + IW6 = IW5 + NP2*M1 + IW7 = IW6 + M2*M1 + IW8 = IW7 + M2*N + IWRK = IW8 + NP2*N +C +C Compute inv(Inp2 - D22*DK) . +C + CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK, NP2 ) + CALL DGEMM( 'N', 'N', NP2, NP2, M2, -ONE, D( NP1+1, M1+1 ), + $ LDD, DK, LDDK, ONE, DWORK, NP2 ) + ANORM = DLANGE( '1', NP2, NP2, DWORK, NP2, DWORK( IWRK ) ) + CALL DGETRF( NP2, NP2, DWORK, NP2, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + CALL DGECON( '1', NP2, DWORK, NP2, ANORM, RCOND, DWORK( IWRK ), + $ IWORK( NP2+1 ), INFO ) + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.EPS ) THEN + INFO = 1 + RETURN + END IF + CALL DGETRI( NP2, DWORK, NP2, IWORK, DWORK( IWRK ), LDWORK-IWRK+1, + $ INFO2 ) + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute inv(Im2 - DK*D22) . +C + CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 ) + CALL DGEMM( 'N', 'N', M2, M2, NP2, -ONE, DK, LDDK, + $ D( NP1+1, M1+1 ), LDD, ONE, DWORK( IW2 ), M2 ) + ANORM = DLANGE( '1', M2, M2, DWORK( IW2 ), M2, DWORK( IWRK ) ) + CALL DGETRF( M2, M2, DWORK( IW2 ), M2, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF + CALL DGECON( '1', M2, DWORK( IW2 ), M2, ANORM, RCOND, + $ DWORK( IWRK ), IWORK( M2+1 ), INFO ) + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.EPS ) THEN + INFO = 2 + RETURN + END IF + CALL DGETRI( M2, DWORK( IW2 ), M2, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute inv(Inp2 - D22*DK)*C2 . +C + CALL DGEMM( 'N', 'N', NP2, N, NP2, ONE, DWORK, NP2, C( NP1+1, 1 ), + $ LDC, ZERO, DWORK( IW3 ), NP2 ) +C +C Compute DK*inv(Inp2 - D22*DK)*C2 . +C + CALL DGEMM( 'N', 'N', M2, N, NP2, ONE, DK, LDDK, DWORK( IW3 ), + $ NP2, ZERO, DWORK( IW4 ), M2 ) +C +C Compute inv(Inp2 - D22*DK)*D21 . +C + CALL DGEMM( 'N', 'N', NP2, M1, NP2, ONE, DWORK, NP2, + $ D( NP1+1, 1 ), LDD, ZERO, DWORK( IW5 ), NP2 ) +C +C Compute DK*inv(Inp2 - D22*DK)*D21 . +C + CALL DGEMM( 'N', 'N', M2, M1, NP2, ONE, DK, LDDK, DWORK( IW5 ), + $ NP2, ZERO, DWORK( IW6 ), M2 ) +C +C Compute inv(Im2 - DK*D22)*CK . +C + CALL DGEMM( 'N', 'N', M2, N, M2, ONE, DWORK( IW2 ), M2, CK, LDCK, + $ ZERO, DWORK( IW7 ), M2 ) +C +C Compute D22*inv(Im2 - DK*D22)*CK . +C + CALL DGEMM( 'N', 'N', NP2, N, M2, ONE, D( NP1+1, M1+1 ), LDD, + $ DWORK( IW7 ), M2, ZERO, DWORK( IW8 ), NP2 ) +C +C Compute AC . +C + CALL DLACPY( 'Full', N, N, A, LDA, AC, LDAC ) + CALL DGEMM( 'N', 'N', N, N, M2, ONE, B( 1, M1+1 ), LDB, + $ DWORK( IW4 ), M2, ONE, AC, LDAC ) + CALL DGEMM( 'N', 'N', N, N, M2, ONE, B( 1, M1+1 ), LDB, + $ DWORK( IW7 ), M2, ZERO, AC( 1, N+1 ), LDAC ) + CALL DGEMM( 'N', 'N', N, N, NP2, ONE, BK, LDBK, DWORK( IW3 ), NP2, + $ ZERO, AC( N+1, 1 ), LDAC ) + CALL DLACPY( 'Full', N, N, AK, LDAK, AC( N+1, N+1 ), LDAC ) + CALL DGEMM( 'N', 'N', N, N, NP2, ONE, BK, LDBK, DWORK( IW8 ), NP2, + $ ONE, AC( N+1, N+1 ), LDAC ) +C +C Compute BC . +C + CALL DLACPY( 'Full', N, M1, B, LDB, BC, LDBC ) + CALL DGEMM( 'N', 'N', N, M1, M2, ONE, B( 1, M1+1 ), LDB, + $ DWORK( IW6 ), M2, ONE, BC, LDBC ) + CALL DGEMM( 'N', 'N', N, M1, NP2, ONE, BK, LDBK, DWORK( IW5 ), + $ NP2, ZERO, BC( N+1, 1 ), LDBC ) +C +C Compute CC . +C + CALL DLACPY( 'Full', NP1, N, C, LDC, CC, LDCC ) + CALL DGEMM( 'N', 'N', NP1, N, M2, ONE, D( 1, M1+1 ), LDD, + $ DWORK( IW4 ), M2, ONE, CC, LDCC ) + CALL DGEMM( 'N', 'N', NP1, N, M2, ONE, D( 1, M1+1 ), LDD, + $ DWORK( IW7 ), M2, ZERO, CC( 1, N+1 ), LDCC ) +C +C Compute DC . +C + CALL DLACPY( 'Full', NP1, M1, D, LDD, DC, LDDC ) + CALL DGEMM( 'N', 'N', NP1, M1, M2, ONE, D( 1, M1+1 ), LDD, + $ DWORK( IW6 ), M2, ONE, DC, LDDC ) +C + RETURN +C *** Last line of SB10LD *** + END diff --git a/mex/sources/libslicot/SB10MD.f b/mex/sources/libslicot/SB10MD.f new file mode 100644 index 000000000..46ea3d84b --- /dev/null +++ b/mex/sources/libslicot/SB10MD.f @@ -0,0 +1,670 @@ + SUBROUTINE SB10MD( NC, MP, LENDAT, F, ORD, MNB, NBLOCK, ITYPE, + $ QUTOL, A, LDA, B, LDB, C, LDC, D, LDD, OMEGA, + $ TOTORD, AD, LDAD, BD, LDBD, CD, LDCD, DD, LDDD, + $ MJU, IWORK, LIWORK, DWORK, LDWORK, ZWORK, + $ LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the D-step in the D-K iteration. It handles +C continuous-time case. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NC (input) INTEGER +C The order of the matrix A. NC >= 0. +C +C MP (input) INTEGER +C The order of the matrix D. MP >= 0. +C +C LENDAT (input) INTEGER +C The length of the vector OMEGA. LENDAT >= 2. +C +C F (input) INTEGER +C The number of the measurements and controls, i.e., +C the size of the block I_f in the D-scaling system. +C F >= 0. +C +C ORD (input/output) INTEGER +C The MAX order of EACH block in the fitting procedure. +C ORD <= LENDAT-1. +C On exit, if ORD < 1 then ORD = 1. +C +C MNB (input) INTEGER +C The number of diagonal blocks in the block structure of +C the uncertainty, and the length of the vectors NBLOCK +C and ITYPE. 1 <= MNB <= MP. +C +C NBLOCK (input) INTEGER array, dimension (MNB) +C The vector of length MNB containing the block structure +C of the uncertainty. NBLOCK(I), I = 1:MNB, is the size of +C each block. +C +C ITYPE (input) INTEGER array, dimension (MNB) +C The vector of length MNB indicating the type of each +C block. +C For I = 1 : MNB, +C ITYPE(I) = 1 indicates that the corresponding block is a +C real block. IN THIS CASE ONLY MJU(JW) WILL BE ESTIMATED +C CORRECTLY, BUT NOT D(S)! +C ITYPE(I) = 2 indicates that the corresponding block is a +C complex block. THIS IS THE ONLY ALLOWED VALUE NOW! +C NBLOCK(I) must be equal to 1 if ITYPE(I) is equal to 1. +C +C QUTOL (input) DOUBLE PRECISION +C The acceptable mean relative error between the D(jw) and +C the frequency responce of the estimated block +C [ADi,BDi;CDi,DDi]. When it is reached, the result is +C taken as good enough. +C A good value is QUTOL = 2.0. +C If QUTOL < 0 then only mju(jw) is being estimated, +C not D(s). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,NC) +C On entry, the leading NC-by-NC part of this array must +C contain the A matrix of the closed-loop system. +C On exit, if MP > 0, the leading NC-by-NC part of this +C array contains an upper Hessenberg matrix similar to A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,NC). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,MP) +C On entry, the leading NC-by-MP part of this array must +C contain the B matrix of the closed-loop system. +C On exit, the leading NC-by-MP part of this array contains +C the transformed B matrix corresponding to the Hessenberg +C form of A. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,NC). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,NC) +C On entry, the leading MP-by-NC part of this array must +C contain the C matrix of the closed-loop system. +C On exit, the leading MP-by-NC part of this array contains +C the transformed C matrix corresponding to the Hessenberg +C form of A. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,MP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,MP) +C The leading MP-by-MP part of this array must contain the +C D matrix of the closed-loop system. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= MAX(1,MP). +C +C OMEGA (input) DOUBLE PRECISION array, dimension (LENDAT) +C The vector with the frequencies. +C +C TOTORD (output) INTEGER +C The TOTAL order of the D-scaling system. +C TOTORD is set to zero, if QUTOL < 0. +C +C AD (output) DOUBLE PRECISION array, dimension (LDAD,MP*ORD) +C The leading TOTORD-by-TOTORD part of this array contains +C the A matrix of the D-scaling system. +C Not referenced if QUTOL < 0. +C +C LDAD INTEGER +C The leading dimension of the array AD. +C LDAD >= MAX(1,MP*ORD), if QUTOL >= 0; +C LDAD >= 1, if QUTOL < 0. +C +C BD (output) DOUBLE PRECISION array, dimension (LDBD,MP+F) +C The leading TOTORD-by-(MP+F) part of this array contains +C the B matrix of the D-scaling system. +C Not referenced if QUTOL < 0. +C +C LDBD INTEGER +C The leading dimension of the array BD. +C LDBD >= MAX(1,MP*ORD), if QUTOL >= 0; +C LDBD >= 1, if QUTOL < 0. +C +C CD (output) DOUBLE PRECISION array, dimension (LDCD,MP*ORD) +C The leading (MP+F)-by-TOTORD part of this array contains +C the C matrix of the D-scaling system. +C Not referenced if QUTOL < 0. +C +C LDCD INTEGER +C The leading dimension of the array CD. +C LDCD >= MAX(1,MP+F), if QUTOL >= 0; +C LDCD >= 1, if QUTOL < 0. +C +C DD (output) DOUBLE PRECISION array, dimension (LDDD,MP+F) +C The leading (MP+F)-by-(MP+F) part of this array contains +C the D matrix of the D-scaling system. +C Not referenced if QUTOL < 0. +C +C LDDD INTEGER +C The leading dimension of the array DD. +C LDDD >= MAX(1,MP+F), if QUTOL >= 0; +C LDDD >= 1, if QUTOL < 0. +C +C MJU (output) DOUBLE PRECISION array, dimension (LENDAT) +C The vector with the upper bound of the structured +C singular value (mju) for each frequency in OMEGA. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C +C LIWORK INTEGER +C The length of the array IWORK. +C LIWORK >= MAX( NC, 4*MNB-2, MP, 2*ORD+1 ), if QUTOL >= 0; +C LIWORK >= MAX( NC, 4*MNB-2, MP ), if QUTOL < 0. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, DWORK(2) returns the optimal value of LZWORK, +C and DWORK(3) returns an estimate of the minimum reciprocal +C of the condition numbers (with respect to inversion) of +C the generated Hessenberg matrices. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 3, LWM, LWD ), where +C LWM = LWA + MAX( NC + MAX( NC, MP-1 ), +C 2*MP*MP*MNB - MP*MP + 9*MNB*MNB + +C MP*MNB + 11*MP + 33*MNB - 11 ); +C LWD = LWB + MAX( 2, LW1, LW2, LW3, LW4, 2*ORD ), +C if QUTOL >= 0; +C LWD = 0, if QUTOL < 0; +C LWA = MP*LENDAT + 2*MNB + MP - 1; +C LWB = LENDAT*(MP + 2) + ORD*(ORD + 2) + 1; +C LW1 = 2*LENDAT + 4*HNPTS; HNPTS = 2048; +C LW2 = LENDAT + 6*HNPTS; MN = MIN( 2*LENDAT, 2*ORD+1 ); +C LW3 = 2*LENDAT*(2*ORD + 1) + MAX( 2*LENDAT, 2*ORD + 1 ) + +C MAX( MN + 6*ORD + 4, 2*MN + 1 ); +C LW4 = MAX( ORD*ORD + 5*ORD, 6*ORD + 1 + MIN( 1, ORD ) ). +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK >= MAX( LZM, LZD ), where +C LZM = MAX( MP*MP + NC*MP + NC*NC + 2*NC, +C 6*MP*MP*MNB + 13*MP*MP + 6*MNB + 6*MP - 3 ); +C LZD = MAX( LENDAT*(2*ORD + 3), ORD*ORD + 3*ORD + 1 ), +C if QUTOL >= 0; +C LZD = 0, if QUTOL < 0. +C +C Error indicator +C +C INFO (output) INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if one or more values w in OMEGA are (close to +C some) poles of the closed-loop system, i.e., the +C matrix jw*I - A is (numerically) singular; +C = 2: the block sizes must be positive integers; +C = 3: the sum of block sizes must be equal to MP; +C = 4: the size of a real block must be equal to 1; +C = 5: the block type must be either 1 or 2; +C = 6: errors in solving linear equations or in matrix +C inversion; +C = 7: errors in computing eigenvalues or singular values. +C = 1i: INFO on exit from SB10YD is i. (1i means 10 + i.) +C +C METHOD +C +C I. First, W(jw) for the given closed-loop system is being +C estimated. +C II. Now, AB13MD SLICOT subroutine can obtain the D(jw) scaling +C system with respect to NBLOCK and ITYPE, and colaterally, +C mju(jw). +C If QUTOL < 0 then the estimations stop and the routine exits. +C III. Now that we have D(jw), SB10YD subroutine can do block-by- +C block fit. For each block it tries with an increasing order +C of the fit, starting with 1 until the +C (mean quadratic error + max quadratic error)/2 +C between the Dii(jw) and the estimated frequency responce +C of the block becomes less than or equal to the routine +C argument QUTOL, or the order becomes equal to ORD. +C IV. Arrange the obtained blocks in the AD, BD, CD and DD +C matrices and estimate the total order of D(s), TOTORD. +C V. Add the system I_f to the system obtained in IV. +C +C REFERENCES +C +C [1] Balas, G., Doyle, J., Glover, K., Packard, A. and Smith, R. +C Mu-analysis and Synthesis toolbox - User's Guide, +C The Mathworks Inc., Natick, MA, USA, 1998. +C +C CONTRIBUTORS +C +C Asparuh Markovski, Technical University of Sofia, July 2003. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. +C A. Markovski, V. Sima, October 2003. +C +C KEYWORDS +C +C Frequency response, H-infinity optimal control, robust control, +C structured singular value. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ THREE = 3.0D+0 ) + INTEGER HNPTS + PARAMETER ( HNPTS = 2048 ) +C .. +C .. Scalar Arguments .. + INTEGER F, INFO, LDA, LDAD, LDB, LDBD, LDC, LDCD, LDD, + $ LDDD, LDWORK, LENDAT, LIWORK, LZWORK, MNB, MP, + $ NC, ORD, TOTORD + DOUBLE PRECISION QUTOL +C .. +C .. Array Arguments .. + INTEGER ITYPE(*), IWORK(*), NBLOCK(*) + DOUBLE PRECISION A(LDA, *), AD(LDAD, *), B(LDB, *), BD(LDBD, *), + $ C(LDC, *), CD(LDCD, *), D(LDD, *), DD(LDDD, *), + $ DWORK(*), MJU(*), OMEGA(*) + COMPLEX*16 ZWORK(*) +C .. +C .. Local Scalars .. + CHARACTER BALEIG, INITA + INTEGER CLWMAX, CORD, DLWMAX, I, IC, ICWRK, IDWRK, II, + $ INFO2, IWAD, IWB, IWBD, IWCD, IWDD, IWGJOM, + $ IWIFRD, IWRFRD, IWX, K, LCSIZE, LDSIZE, LORD, + $ LW1, LW2, LW3, LW4, LWA, LWB, MAXCWR, MAXWRK, + $ MN, W + DOUBLE PRECISION MAQE, MEQE, MOD1, MOD2, RCND, RCOND, RQE, TOL, + $ TOLER + COMPLEX*16 FREQ +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL AB13MD, DCOPY, DLACPY, DLASET, DSCAL, SB10YD, + $ TB05AD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DCMPLX, INT, MAX, MIN, SQRT +C +C Decode and test input parameters. +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C Workspace usage 1. +C +C real +C + IWX = 1 + MP*LENDAT + IWGJOM = IWX + 2*MNB - 1 + IDWRK = IWGJOM + MP + LDSIZE = LDWORK - IDWRK + 1 +C +C complex +C + IWB = MP*MP + 1 + ICWRK = IWB + NC*MP + LCSIZE = LZWORK - ICWRK + 1 +C + INFO = 0 + IF ( NC.LT.0 ) THEN + INFO = -1 + ELSE IF( MP.LT.0 ) THEN + INFO = -2 + ELSE IF( LENDAT.LT.2 ) THEN + INFO = -3 + ELSE IF( F.LT.0 ) THEN + INFO = -4 + ELSE IF( ORD.GT.LENDAT - 1 ) THEN + INFO = -5 + ELSE IF( MNB.LT.1 .OR. MNB.GT.MP ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, NC ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.MAX( 1, NC ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, MP ) ) THEN + INFO = -15 + ELSE IF( LDD.LT.MAX( 1, MP ) ) THEN + INFO = -17 + ELSE IF( LDAD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDAD.LT.MP*ORD ) ) + $ THEN + INFO = -21 + ELSE IF( LDBD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDBD.LT.MP*ORD ) ) + $ THEN + INFO = -23 + ELSE IF( LDCD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDCD.LT.MP + F ) ) + $ THEN + INFO = -25 + ELSE IF( LDDD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDDD.LT.MP + F ) ) + $ THEN + INFO = -27 + ELSE +C +C Compute workspace. +C + II = MAX( NC, 4*MNB - 2, MP ) + MN = MIN( 2*LENDAT, 2*ORD + 1 ) + LWA = IDWRK - 1 + LWB = LENDAT*( MP + 2 ) + ORD*( ORD + 2 ) + 1 + LW1 = 2*LENDAT + 4*HNPTS + LW2 = LENDAT + 6*HNPTS + LW3 = 2*LENDAT*( 2*ORD + 1 ) + MAX( 2*LENDAT, 2*ORD + 1 ) + + $ MAX( MN + 6*ORD + 4, 2*MN + 1 ) + LW4 = MAX( ORD*ORD + 5*ORD, 6*ORD + 1 + MIN( 1, ORD ) ) +C + DLWMAX = LWA + MAX( NC + MAX( NC, MP - 1 ), + $ 2*MP*MP*MNB - MP*MP + 9*MNB*MNB + MP*MNB + + $ 11*MP + 33*MNB - 11 ) +C + CLWMAX = MAX( ICWRK - 1 + NC*NC + 2*NC, + $ 6*MP*MP*MNB + 13*MP*MP + 6*MNB + 6*MP - 3 ) +C + IF ( QUTOL.GE.ZERO ) THEN + II = MAX( II, 2*ORD + 1 ) + DLWMAX = MAX( DLWMAX, + $ LWB + MAX( 2, LW1, LW2, LW3, LW4, 2*ORD ) ) + CLWMAX = MAX( CLWMAX, LENDAT*( 2*ORD + 3 ), + $ ORD*( ORD + 3 ) + 1 ) + END IF + IF ( LIWORK.LT.II ) THEN + INFO = -30 + ELSE IF ( LDWORK.LT.MAX( 3, DLWMAX ) ) THEN + INFO = -32 + ELSE IF ( LZWORK.LT.CLWMAX ) THEN + INFO = -34 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB10MD', -INFO ) + RETURN + END IF +C + ORD = MAX( 1, ORD ) + TOTORD = 0 +C +C Quick return if possible. +C + IF( NC.EQ.0 .OR. MP.EQ.0 ) THEN + DWORK(1) = THREE + DWORK(2) = ZERO + DWORK(3) = ONE + RETURN + END IF +C + TOLER = SQRT( DLAMCH( 'Epsilon' ) ) +C + BALEIG = 'C' + RCOND = ONE + MAXCWR = CLWMAX +C +C @@@ 1. Estimate W(jw) for the closed-loop system, @@@ +C @@@ D(jw) and mju(jw) for each frequency. @@@ +C + DO 30 W = 1, LENDAT + FREQ = DCMPLX( ZERO, OMEGA(W) ) + IF ( W.EQ.1 ) THEN + INITA = 'G' + ELSE + INITA = 'H' + END IF +C +C Compute C*inv(jw*I-A)*B. +C Integer workspace: need NC. +C Real workspace: need LWA + NC + MAX(NC,MP-1); +C prefer larger, +C where LWA = MP*LENDAT + 2*MNB + MP - 1. +C Complex workspace: need MP*MP + NC*MP + NC*NC + 2*NC. +C + CALL TB05AD( BALEIG, INITA, NC, MP, MP, FREQ, A, LDA, B, LDB, + $ C, LDC, RCND, ZWORK, MP, DWORK, DWORK, ZWORK(IWB), + $ NC, IWORK, DWORK(IDWRK), LDSIZE, ZWORK(ICWRK), + $ LCSIZE, INFO2 ) +C + IF ( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C + RCOND = MIN( RCOND, RCND ) + IF ( W.EQ.1 ) + $ MAXWRK = INT( DWORK(IDWRK) + IDWRK - 1 ) + IC = 0 +C +C D + C*inv(jw*I-A)*B +C + DO 20 K = 1, MP + DO 10 I = 1, MP + IC = IC + 1 + ZWORK(IC) = ZWORK(IC) + DCMPLX ( D(I,K), ZERO ) + 10 CONTINUE + 20 CONTINUE +C +C Estimate D(jw) and mju(jw). +C Integer workspace: need MAX(4*MNB-2,MP). +C Real workspace: need LWA + 2*MP*MP*MNB - MP*MP + 9*MNB*MNB +C + MP*MNB + 11*MP + 33*MNB - 11; +C prefer larger. +C Complex workspace: need 6*MP*MP*MNB + 13*MP*MP + 6*MNB + +C 6*MP - 3. +C + CALL AB13MD( 'N', MP, ZWORK, MP, MNB, NBLOCK, ITYPE, + $ DWORK(IWX), MJU(W), DWORK((W-1)*MP+1), + $ DWORK(IWGJOM), IWORK, DWORK(IDWRK), LDSIZE, + $ ZWORK(IWB), LZWORK-IWB+1, INFO2 ) +C + IF ( INFO2.NE.0 ) THEN + INFO = INFO2 + 1 + RETURN + END IF +C + IF ( W.EQ.1 ) THEN + MAXWRK = MAX( MAXWRK, INT( DWORK(IDWRK) ) + IDWRK - 1 ) + MAXCWR = MAX( MAXCWR, INT( ZWORK(IWB) ) + IWB - 1 ) + END IF +C +C Normalize D(jw) through it's last entry. +C + IF ( DWORK(W*MP).NE.ZERO ) + $ CALL DSCAL( MP, ONE/DWORK(W*MP), DWORK((W-1)*MP+1), 1 ) +C + 30 CONTINUE +C +C Quick return if needed. +C + IF ( QUTOL.LT.ZERO ) THEN + DWORK(1) = MAXWRK + DWORK(2) = MAXCWR + DWORK(3) = RCOND + RETURN + END IF +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C Workspace usage 2. +C +C real +C + IWRFRD = IWX + IWIFRD = IWRFRD + LENDAT + IWAD = IWIFRD + LENDAT + IWBD = IWAD + ORD*ORD + IWCD = IWBD + ORD + IWDD = IWCD + ORD + IDWRK = IWDD + 1 + LDSIZE = LDWORK - IDWRK + 1 +C +C complex +C + ICWRK = ORD + 2 + LCSIZE = LZWORK - ICWRK + 1 + INITA = 'H' +C +C Use default tolerance for SB10YD. +C + TOL = -ONE +C +C @@@ 2. Clear imag parts of D(jw) for SB10YD. @@@ +C + DO 40 I = 1, LENDAT + DWORK(IWIFRD+I-1) = ZERO + 40 CONTINUE +C +C @@@ 3. Clear AD, BD, CD and initialize DD with I_(mp+f). @@@ +C + CALL DLASET( 'Full', MP*ORD, MP*ORD, ZERO, ZERO, AD, LDAD ) + CALL DLASET( 'Full', MP*ORD, MP+F, ZERO, ZERO, BD, LDBD ) + CALL DLASET( 'Full', MP+F, MP*ORD, ZERO, ZERO, CD, LDCD ) + CALL DLASET( 'Full', MP+F, MP+F, ZERO, ONE, DD, LDDD ) +C +C @@@ 4. Block by block frequency identification. @@@ +C + DO 80 II = 1, MP +C + CALL DCOPY( LENDAT, DWORK(II), MP, DWORK(IWRFRD), 1 ) +C +C Increase CORD from 1 to ORD for every block, if needed. +C + CORD = 1 +C + 50 CONTINUE + LORD = CORD +C +C Now, LORD is the desired order. +C Integer workspace: need 2*N+1, where N = LORD. +C Real workspace: need LWB + MAX( 2, LW1, LW2, LW3, LW4), +C where +C LWB = LENDAT*(MP+2) + +C ORD*(ORD+2) + 1, +C HNPTS = 2048, and +C LW1 = 2*LENDAT + 4*HNPTS; +C LW2 = LENDAT + 6*HNPTS; +C MN = min( 2*LENDAT, 2*N+1 ) +C LW3 = 2*LENDAT*(2*N+1) + +C max( 2*LENDAT, 2*N+1 ) + +C max( MN + 6*N + 4, 2*MN+1 ); +C LW4 = max( N*N + 5*N, +C 6*N + 1 + min( 1,N ) ); +C prefer larger. +C Complex workspace: need LENDAT*(2*N+3). +C + CALL SB10YD( 0, 1, LENDAT, DWORK(IWRFRD), DWORK(IWIFRD), + $ OMEGA, LORD, DWORK(IWAD), ORD, DWORK(IWBD), + $ DWORK(IWCD), DWORK(IWDD), TOL, IWORK, + $ DWORK(IDWRK), LDSIZE, ZWORK, LZWORK, INFO2 ) +C +C At this point, LORD is the actual order reached by SB10YD, +C 0 <= LORD <= CORD. +C [ADi,BDi; CDi,DDi] is a minimal realization with ADi in +C upper Hessenberg form. +C The leading LORD-by-LORD part of ORD-by-ORD DWORK(IWAD) +C contains ADi, the leading LORD-by-1 part of ORD-by-1 +C DWORK(IWBD) contains BDi, the leading 1-by-LORD part of +C 1-by-ORD DWORK(IWCD) contains CDi, DWORK(IWDD) contains DDi. +C + IF ( INFO2.NE.0 ) THEN + INFO = 10 + INFO2 + RETURN + END IF +C +C Compare the original D(jw) with the fitted one. +C + MEQE = ZERO + MAQE = ZERO +C + DO 60 W = 1, LENDAT + FREQ = DCMPLX( ZERO, OMEGA(W) ) +C +C Compute CD*inv(jw*I-AD)*BD. +C Integer workspace: need LORD. +C Real workspace: need LWB + 2*LORD; +C prefer larger. +C Complex workspace: need 1 + ORD + LORD*LORD + 2*LORD. +C + CALL TB05AD( BALEIG, INITA, LORD, 1, 1, FREQ, + $ DWORK(IWAD), ORD, DWORK(IWBD), ORD, + $ DWORK(IWCD), 1, RCND, ZWORK, 1, + $ DWORK(IDWRK), DWORK(IDWRK), ZWORK(2), ORD, + $ IWORK, DWORK(IDWRK), LDSIZE, ZWORK(ICWRK), + $ LCSIZE, INFO2 ) +C + IF ( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C + RCOND = MIN( RCOND, RCND ) + IF ( W.EQ.1 ) + $ MAXWRK = MAX( MAXWRK, INT( DWORK(IDWRK) ) + IDWRK - 1) +C +C DD + CD*inv(jw*I-AD)*BD +C + ZWORK(1) = ZWORK(1) + DCMPLX( DWORK(IWDD), ZERO ) +C + MOD1 = ABS( DWORK(IWRFRD+W-1) ) + MOD2 = ABS( ZWORK(1) ) + RQE = ABS( ( MOD1 - MOD2 )/( MOD1 + TOLER ) ) + MEQE = MEQE + RQE + MAQE = MAX( MAQE, RQE ) +C + 60 CONTINUE +C + MEQE = MEQE/LENDAT +C + IF ( ( ( MEQE + MAQE )/TWO.LE.QUTOL ) .OR. + $ ( CORD.EQ.ORD ) ) THEN + GOTO 70 + END IF +C + CORD = CORD + 1 + GOTO 50 +C + 70 TOTORD = TOTORD + LORD +C +C Copy ad(ii), bd(ii) and cd(ii) to AD, BD and CD, respectively. +C + CALL DLACPY( 'Full', LORD, LORD, DWORK(IWAD), ORD, + $ AD(TOTORD-LORD+1,TOTORD-LORD+1), LDAD ) + CALL DCOPY( LORD, DWORK(IWBD), 1, BD(TOTORD-LORD+1,II), 1 ) + CALL DCOPY( LORD, DWORK(IWCD), 1, CD(II,TOTORD-LORD+1), LDCD ) +C +C Copy dd(ii) to DD. +C + DD(II,II) = DWORK(IWDD) +C + 80 CONTINUE +C + DWORK(1) = MAXWRK + DWORK(2) = MAXCWR + DWORK(3) = RCOND + RETURN +C +C *** Last line of SB10MD *** + END diff --git a/mex/sources/libslicot/SB10PD.f b/mex/sources/libslicot/SB10PD.f new file mode 100644 index 000000000..617bdd29b --- /dev/null +++ b/mex/sources/libslicot/SB10PD.f @@ -0,0 +1,505 @@ + SUBROUTINE SB10PD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, + $ D, LDD, TU, LDTU, TY, LDTY, RCOND, TOL, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the matrices D12 and D21 of the linear time-invariant +C system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 D22 | +C +C to unit diagonal form, to transform the matrices B, C, and D11 to +C satisfy the formulas in the computation of an H2 and H-infinity +C (sub)optimal controllers and to check the rank conditions. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the system input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading NP-by-N part of this array must +C contain the system output matrix C. +C On exit, the leading NP-by-N part of this array contains +C the transformed system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading NP-by-M part of this array must +C contain the system input/output matrix D. The +C NMEAS-by-NCON trailing submatrix D22 is not referenced. +C On exit, the leading (NP-NMEAS)-by-(M-NCON) part of this +C array contains the transformed submatrix D11. +C The transformed submatrices D12 = [ 0 Im2 ]' and +C D21 = [ 0 Inp2 ] are not stored. The corresponding part +C of this array contains no useful information. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C TU (output) DOUBLE PRECISION array, dimension (LDTU,M2) +C The leading M2-by-M2 part of this array contains the +C control transformation matrix TU. +C +C LDTU INTEGER +C The leading dimension of the array TU. LDTU >= max(1,M2). +C +C TY (output) DOUBLE PRECISION array, dimension (LDTY,NP2) +C The leading NP2-by-NP2 part of this array contains the +C measurement transformation matrix TY. +C +C LDTY INTEGER +C The leading dimension of the array TY. +C LDTY >= max(1,NP2). +C +C RCOND (output) DOUBLE PRECISION array, dimension (2) +C RCOND(1) contains the reciprocal condition number of the +C control transformation matrix TU; +C RCOND(2) contains the reciprocal condition number of the +C measurement transformation matrix TY. +C RCOND is set even if INFO = 3 or INFO = 4; if INFO = 3, +C then RCOND(2) was not computed, but it is set to 0. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used for controlling the accuracy of the applied +C transformations. Transformation matrices TU and TY whose +C reciprocal condition numbers are less than TOL are not +C allowed. If TOL <= 0, then a default value equal to +C sqrt(EPS) is used, where EPS is the relative machine +C precision. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= MAX(1,LW1,LW2,LW3,LW4), where +C LW1 = (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2)), +C LW2 = (N+NP2)*(N+M1+1) + MAX(3*(N+NP2)+N+M1,5*(N+NP2)), +C LW3 = M2 + NP1*NP1 + MAX(NP1*MAX(N,M1),3*M2+NP1,5*M2), +C LW4 = NP2 + M1*M1 + MAX(MAX(N,NP1)*M1,3*NP2+M1,5*NP2), +C with M1 = M - M2 and NP1 = NP - NP2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is +C MAX(1,(N+Q)*(N+Q+6),Q*(Q+MAX(N,Q,5)+1). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix | A B2 | had not full column rank +C | C1 D12 | +C in respect to the tolerance EPS; +C = 2: if the matrix | A B1 | had not full row rank in +C | C2 D21 | +C respect to the tolerance EPS; +C = 3: if the matrix D12 had not full column rank in +C respect to the tolerance TOL; +C = 4: if the matrix D21 had not full row rank in respect +C to the tolerance TOL; +C = 5: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of one of +C the matrices |A B2 |, |A B1 |, D12 or D21). +C |C1 D12| |C2 D21| +C +C METHOD +C +C The routine performs the transformations described in [2]. +C +C REFERENCES +C +C [1] Glover, K. and Doyle, J.C. +C State-space formulae for all stabilizing controllers that +C satisfy an Hinf norm bound and relations to risk sensitivity. +C Systems and Control Letters, vol. 11, pp. 167-172, 1988. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C NUMERICAL ASPECTS +C +C The precision of the transformations can be controlled by the +C condition numbers of the matrices TU and TY as given by the +C values of RCOND(1) and RCOND(2), respectively. An error return +C with INFO = 3 or INFO = 4 will be obtained if the condition +C number of TU or TY, respectively, would exceed 1/TOL. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Feb. 2000. +C +C KEYWORDS +C +C H-infinity optimal control, robust control, singular value +C decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDTU, LDTY, LDWORK, + $ M, N, NCON, NMEAS, NP + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), DWORK( * ), RCOND( 2 ), + $ TU( LDTU, * ), TY( LDTY, * ) +C .. +C .. Local Scalars .. + INTEGER IEXT, INFO2, IQ, IWRK, J, LWAMAX, M1, M2, + $ MINWRK, ND1, ND2, NP1, NP2 + DOUBLE PRECISION EPS, TOLL +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DGESVD, DLACPY, DSCAL, DSWAP, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -13 + ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN + INFO = -15 + ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN + INFO = -17 + ELSE +C +C Compute workspace. +C + MINWRK = MAX( 1, + $ ( N + NP1 + 1 )*( N + M2 ) + + $ MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ), + $ ( N + NP2 )*( N + M1 + 1 ) + + $ MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ), + $ M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, + $ 5*M2 ), + $ NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, + $ 5*NP2 ) ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -21 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + ND1 = NP1 - M2 + ND2 = M1 - NP2 + EPS = DLAMCH( 'Epsilon' ) + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance for condition tests. +C + TOLL = SQRT( EPS ) + END IF +C +C Determine if |A-jwI B2 | has full column rank at w = 0. +C | C1 D12| +C Workspace: need (N+NP1+1)*(N+M2) + +C max(3*(N+M2)+N+NP1,5*(N+M2)); +C prefer larger. +C + IEXT = N + M2 + 1 + IWRK = IEXT + ( N + NP1 )*( N + M2 ) + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IEXT ), N+NP1 ) + CALL DLACPY( 'Full', NP1, N, C, LDC, DWORK( IEXT+N ), N+NP1 ) + CALL DLACPY( 'Full', N, M2, B( 1, M1+1 ), LDB, + $ DWORK( IEXT+(N+NP1)*N ), N+NP1 ) + CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, + $ DWORK( IEXT+(N+NP1)*N+N ), N+NP1 ) + CALL DGESVD( 'N', 'N', N+NP1, N+M2, DWORK( IEXT ), N+NP1, DWORK, + $ TU, LDTU, TY, LDTY, DWORK( IWRK ), LDWORK-IWRK+1, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF + IF( DWORK( N+M2 )/DWORK( 1 ).LE.EPS ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Determine if |A-jwI B1 | has full row rank at w = 0. +C | C2 D21| +C Workspace: need (N+NP2)*(N+M1+1) + +C max(3*(N+NP2)+N+M1,5*(N+NP2)); +C prefer larger. +C + IEXT = N + NP2 + 1 + IWRK = IEXT + ( N + NP2 )*( N + M1 ) + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IEXT ), N+NP2 ) + CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1), LDC, DWORK( IEXT+N ), + $ N+NP2 ) + CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( IEXT+(N+NP2)*N ), + $ N+NP2 ) + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, + $ DWORK( IEXT+(N+NP2)*N+N ), N+NP2 ) + CALL DGESVD( 'N', 'N', N+NP2, N+M1, DWORK( IEXT ), N+NP2, DWORK, + $ TU, LDTU, TY, LDTY, DWORK( IWRK ), LDWORK-IWRK+1, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF + IF( DWORK( N+NP2 )/DWORK( 1 ).LE.EPS ) THEN + INFO = 2 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Determine SVD of D12, D12 = U12 S12 V12', and check if D12 has +C full column rank. V12' is stored in TU. +C Workspace: need M2 + NP1*NP1 + max(3*M2+NP1,5*M2); +C prefer larger. +C + IQ = M2 + 1 + IWRK = IQ + NP1*NP1 +C + CALL DGESVD( 'A', 'A', NP1, M2, D( 1, M1+1 ), LDD, DWORK, + $ DWORK( IQ ), NP1, TU, LDTU, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF +C + RCOND( 1 ) = DWORK( M2 )/DWORK( 1 ) + IF( RCOND( 1 ).LE.TOLL ) THEN + RCOND( 2 ) = ZERO + INFO = 3 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Determine Q12. +C + IF( ND1.GT.0 ) THEN + CALL DLACPY( 'Full', NP1, M2, DWORK( IQ ), NP1, D( 1, M1+1 ), + $ LDD ) + CALL DLACPY( 'Full', NP1, ND1, DWORK( IQ+NP1*M2 ), NP1, + $ DWORK( IQ ), NP1 ) + CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, + $ DWORK( IQ+NP1*ND1 ), NP1 ) + END IF +C +C Determine Tu by transposing in-situ and scaling. +C + DO 10 J = 1, M2 - 1 + CALL DSWAP( J, TU( J+1, 1 ), LDTU, TU( 1, J+1 ), 1 ) + 10 CONTINUE +C + DO 20 J = 1, M2 + CALL DSCAL( M2, ONE/DWORK( J ), TU( 1, J ), 1 ) + 20 CONTINUE +C +C Determine C1 =: Q12'*C1. +C Workspace: M2 + NP1*NP1 + NP1*N. +C + CALL DGEMM( 'T', 'N', NP1, N, NP1, ONE, DWORK( IQ ), NP1, C, LDC, + $ ZERO, DWORK( IWRK ), NP1 ) + CALL DLACPY( 'Full', NP1, N, DWORK( IWRK ), NP1, C, LDC ) + LWAMAX = MAX( IWRK + NP1*N - 1, LWAMAX ) +C +C Determine D11 =: Q12'*D11. +C Workspace: M2 + NP1*NP1 + NP1*M1. +C + CALL DGEMM( 'T', 'N', NP1, M1, NP1, ONE, DWORK( IQ ), NP1, D, LDD, + $ ZERO, DWORK( IWRK ), NP1 ) + CALL DLACPY( 'Full', NP1, M1, DWORK( IWRK ), NP1, D, LDD ) + LWAMAX = MAX( IWRK + NP1*M1 - 1, LWAMAX ) +C +C Determine SVD of D21, D21 = U21 S21 V21', and check if D21 has +C full row rank. U21 is stored in TY. +C Workspace: need NP2 + M1*M1 + max(3*NP2+M1,5*NP2); +C prefer larger. +C + IQ = NP2 + 1 + IWRK = IQ + M1*M1 +C + CALL DGESVD( 'A', 'A', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, TY, + $ LDTY, DWORK( IQ ), M1, DWORK( IWRK ), LDWORK-IWRK+1, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF +C + RCOND( 2 ) = DWORK( NP2 )/DWORK( 1 ) + IF( RCOND( 2 ).LE.TOLL ) THEN + INFO = 4 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Determine Q21. +C + IF( ND2.GT.0 ) THEN + CALL DLACPY( 'Full', NP2, M1, DWORK( IQ ), M1, D( NP1+1, 1 ), + $ LDD ) + CALL DLACPY( 'Full', ND2, M1, DWORK( IQ+NP2 ), M1, DWORK( IQ ), + $ M1 ) + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, + $ DWORK( IQ+ND2 ), M1 ) + END IF +C +C Determine Ty by scaling and transposing in-situ. +C + DO 30 J = 1, NP2 + CALL DSCAL( NP2, ONE/DWORK( J ), TY( 1, J ), 1 ) + 30 CONTINUE +C + DO 40 J = 1, NP2 - 1 + CALL DSWAP( J, TY( J+1, 1 ), LDTY, TY( 1, J+1 ), 1 ) + 40 CONTINUE +C +C Determine B1 =: B1*Q21'. +C Workspace: NP2 + M1*M1 + N*M1. +C + CALL DGEMM( 'N', 'T', N, M1, M1, ONE, B, LDB, DWORK( IQ ), M1, + $ ZERO, DWORK( IWRK ), N ) + CALL DLACPY( 'Full', N, M1, DWORK( IWRK ), N, B, LDB ) + LWAMAX = MAX( IWRK + N*M1 - 1, LWAMAX ) +C +C Determine D11 =: D11*Q21'. +C Workspace: NP2 + M1*M1 + NP1*M1. +C + CALL DGEMM( 'N', 'T', NP1, M1, M1, ONE, D, LDD, DWORK( IQ ), M1, + $ ZERO, DWORK( IWRK ), NP1 ) + CALL DLACPY( 'Full', NP1, M1, DWORK( IWRK ), NP1, D, LDD ) + LWAMAX = MAX( IWRK + NP1*M1 - 1, LWAMAX ) +C +C Determine B2 =: B2*Tu. +C Workspace: N*M2. +C + CALL DGEMM( 'N', 'N', N, M2, M2, ONE, B( 1, M1+1 ), LDB, TU, LDTU, + $ ZERO, DWORK, N ) + CALL DLACPY( 'Full', N, M2, DWORK, N, B( 1, M1+1 ), LDB ) +C +C Determine C2 =: Ty*C2. +C Workspace: NP2*N. +C + CALL DGEMM( 'N', 'N', NP2, N, NP2, ONE, TY, LDTY, + $ C( NP1+1, 1 ), LDC, ZERO, DWORK, NP2 ) + CALL DLACPY( 'Full', NP2, N, DWORK, NP2, C( NP1+1, 1 ), LDC ) +C + LWAMAX = MAX( N*MAX( M2, NP2 ), LWAMAX ) + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10PD *** + END diff --git a/mex/sources/libslicot/SB10QD.f b/mex/sources/libslicot/SB10QD.f new file mode 100644 index 000000000..6b64f8396 --- /dev/null +++ b/mex/sources/libslicot/SB10QD.f @@ -0,0 +1,602 @@ + SUBROUTINE SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, + $ C, LDC, D, LDD, F, LDF, H, LDH, X, LDX, Y, LDY, + $ XYCOND, IWORK, DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the state feedback and the output injection +C matrices for an H-infinity (sub)optimal n-state controller, +C using Glover's and Doyle's 1988 formulas, for the system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 D22 | +C +C and for a given value of gamma, where B2 has as column size the +C number of control inputs (NCON) and C2 has as row size the number +C of measurements (NMEAS) being provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank with D12 = | 0 | and D21 is +C | I | +C full row rank with D21 = | 0 I | as obtained by the +C subroutine SB10PD, +C +C (A3) | A-j*omega*I B2 | has full column rank for all omega, +C | C1 D12 | +C +C +C (A4) | A-j*omega*I B1 | has full row rank for all omega. +C | C2 D21 | +C +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C GAMMA (input) DOUBLE PRECISION +C The value of gamma. It is assumed that gamma is +C sufficiently large so that the controller is admissible. +C GAMMA >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C F (output) DOUBLE PRECISION array, dimension (LDF,N) +C The leading M-by-N part of this array contains the state +C feedback matrix F. +C +C LDF INTEGER +C The leading dimension of the array F. LDF >= max(1,M). +C +C H (output) DOUBLE PRECISION array, dimension (LDH,NP) +C The leading N-by-NP part of this array contains the output +C injection matrix H. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array contains the matrix +C X, solution of the X-Riccati equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,N) +C The leading N-by-N part of this array contains the matrix +C Y, solution of the Y-Riccati equation. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= max(1,N). +C +C XYCOND (output) DOUBLE PRECISION array, dimension (2) +C XYCOND(1) contains an estimate of the reciprocal condition +C number of the X-Riccati equation; +C XYCOND(2) contains an estimate of the reciprocal condition +C number of the Y-Riccati equation. +C +C Workspace +C +C IWORK INTEGER array, dimension max(2*max(N,M-NCON,NP-NMEAS),N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= max(1,M*M + max(2*M1,3*N*N + +C max(N*M,10*N*N+12*N+5)), +C NP*NP + max(2*NP1,3*N*N + +C max(N*NP,10*N*N+12*N+5))), +C where M1 = M - M2 and NP1 = NP - NP2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is +C max(1,4*Q*Q+max(2*Q,3*N*N + max(2*N*Q,10*N*N+12*N+5))). +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the controller is not admissible (too small value +C of gamma); +C = 2: if the X-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 3: if the Y-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties). +C +C METHOD +C +C The routine implements the Glover's and Doyle's formulas [1],[2] +C modified as described in [3]. The X- and Y-Riccati equations +C are solved with condition and accuracy estimates [4]. +C +C REFERENCES +C +C [1] Glover, K. and Doyle, J.C. +C State-space formulae for all stabilizing controllers that +C satisfy an Hinf norm bound and relations to risk sensitivity. +C Systems and Control Letters, vol. 11, pp. 167-172, 1988. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of continuous-time +C linear control systems. +C Rep. 98-14, Department of Engineering, Leicester University, +C Leicester, U.K., 1998. +C +C [4] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. +C DGRSVX and DMSRIC: Fortan 77 subroutines for solving +C continuous-time matrix algebraic Riccati equations with +C condition and accuracy estimates. +C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. +C Chemnitz, May 1998. +C +C NUMERICAL ASPECTS +C +C The precision of the solution of the matrix Riccati equations +C can be controlled by the values of the condition numbers +C XYCOND(1) and XYCOND(2) of these equations. +C +C FURTHER COMMENTS +C +C The Riccati equations are solved by the Schur approach +C implementing condition and accuracy estimates. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Sept. 1999. +C +C KEYWORDS +C +C Algebraic Riccati equation, H-infinity optimal control, robust +C control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDF, LDH, LDWORK, + $ LDX, LDY, M, N, NCON, NMEAS, NP + DOUBLE PRECISION GAMMA +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), DWORK( * ), F( LDF, * ), + $ H( LDH, * ), X( LDX, * ), XYCOND( 2 ), + $ Y( LDY, * ) + LOGICAL BWORK( * ) +C +C .. +C .. Local Scalars .. + INTEGER INFO2, IW2, IWA, IWG, IWI, IWQ, IWR, IWRK, IWS, + $ IWT, IWV, LWAMAX, M1, M2, MINWRK, N2, ND1, ND2, + $ NN, NP1, NP2 + DOUBLE PRECISION ANORM, EPS, FERR, RCOND, SEP +C .. +C .. External Functions .. +C + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASET, DSYCON, DSYMM, DSYRK, + $ DSYTRF, DSYTRI, MB01RU, MB01RX, SB02RD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS + NN = N*N +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( GAMMA.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -14 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -16 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -20 + ELSE IF( LDY.LT.MAX( 1, N ) ) THEN + INFO = -22 + ELSE +C +C Compute workspace. +C + MINWRK = MAX( 1, M*M + MAX( 2*M1, 3*NN + + $ MAX( N*M, 10*NN + 12*N + 5 ) ), + $ NP*NP + MAX( 2*NP1, 3*NN + + $ MAX( N*NP, 10*NN + 12*N + 5 ) ) ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -26 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + XYCOND( 1 ) = ONE + XYCOND( 2 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF + ND1 = NP1 - M2 + ND2 = M1 - NP2 + N2 = 2*N +C +C Get the machine precision. +C + EPS = DLAMCH( 'Epsilon' ) +C +C Workspace usage. +C + IWA = M*M + 1 + IWQ = IWA + NN + IWG = IWQ + NN + IW2 = IWG + NN +C +C Compute |D1111'||D1111 D1112| - gamma^2*Im1 . +C |D1112'| +C + CALL DLASET( 'L', M1, M1, ZERO, -GAMMA*GAMMA, DWORK, M ) + IF( ND1.GT.0 ) + $ CALL DSYRK( 'L', 'T', M1, ND1, ONE, D, LDD, ONE, DWORK, M ) +C +C Compute inv(|D1111'|*|D1111 D1112| - gamma^2*Im1) . +C |D1112'| +C + IWRK = IWA + ANORM = DLANSY( 'I', 'L', M1, DWORK, M, DWORK( IWRK ) ) + CALL DSYTRF( 'L', M1, DWORK, M, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 + CALL DSYCON( 'L', M1, DWORK, M, IWORK, ANORM, RCOND, + $ DWORK( IWRK ), IWORK( M1+1 ), INFO2 ) + IF( RCOND.LT.EPS ) THEN + INFO = 1 + RETURN + END IF +C +C Compute inv(R) block by block. +C + CALL DSYTRI( 'L', M1, DWORK, M, IWORK, DWORK( IWRK ), INFO2 ) +C +C Compute -|D1121 D1122|*inv(|D1111'|*|D1111 D1112| - gamma^2*Im1) . +C |D1112'| +C + CALL DSYMM( 'R', 'L', M2, M1, -ONE, DWORK, M, D( ND1+1, 1 ), LDD, + $ ZERO, DWORK( M1+1 ), M ) +C +C Compute |D1121 D1122|*inv(|D1111'|*|D1111 D1112| - +C |D1112'| +C +C gamma^2*Im1)*|D1121'| + Im2 . +C |D1122'| +C + CALL DLASET( 'Lower', M2, M2, ZERO, ONE, DWORK( M1*(M+1)+1 ), M ) + CALL MB01RX( 'Right', 'Lower', 'Transpose', M2, M1, ONE, -ONE, + $ DWORK( M1*(M+1)+1 ), M, D( ND1+1, 1 ), LDD, + $ DWORK( M1+1 ), M, INFO2 ) +C +C Compute D11'*C1 . +C + CALL DGEMM( 'T', 'N', M1, N, NP1, ONE, D, LDD, C, LDC, ZERO, + $ DWORK( IW2 ), M ) +C +C Compute D1D'*C1 . +C + CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, DWORK( IW2+M1 ), + $ M ) +C +C Compute inv(R)*D1D'*C1 in F . +C + CALL DSYMM( 'L', 'L', M, N, ONE, DWORK, M, DWORK( IW2 ), M, ZERO, + $ F, LDF ) +C +C Compute Ax = A - B*inv(R)*D1D'*C1 . +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IWA ), N ) + CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, F, LDF, ONE, + $ DWORK( IWA ), N ) +C +C Compute Cx = C1'*C1 - C1'*D1D*inv(R)*D1D'*C1 . +C + IF( ND1.EQ.0 ) THEN + CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N ) + ELSE + CALL DSYRK( 'L', 'T', N, NP1, ONE, C, LDC, ZERO, + $ DWORK( IWQ ), N ) + CALL MB01RX( 'Left', 'Lower', 'Transpose', N, M, ONE, -ONE, + $ DWORK( IWQ ), N, DWORK( IW2 ), M, F, LDF, INFO2 ) + END IF +C +C Compute Dx = B*inv(R)*B' . +C + IWRK = IW2 + CALL MB01RU( 'Lower', 'NoTranspose', N, M, ZERO, ONE, + $ DWORK( IWG ), N, B, LDB, DWORK, M, DWORK( IWRK ), + $ M*N, INFO2 ) +C +C Solution of the Riccati equation Ax'*X + X*Ax + Cx - X*Dx*X = 0 . +C Workspace: need M*M + 13*N*N + 12*N + 5; +C prefer larger. +C + IWT = IW2 + IWV = IWT + NN + IWR = IWV + NN + IWI = IWR + N2 + IWS = IWI + N2 + IWRK = IWS + 4*NN +C + CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'NoTranspose', + $ 'Lower', 'GeneralScaling', 'Stable', 'NotFactored', + $ 'Original', N, DWORK( IWA ), N, DWORK( IWT ), N, + $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ X, LDX, SEP, XYCOND( 1 ), FERR, DWORK( IWR ), + $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF +C + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute F = -inv(R)*|D1D'*C1 + B'*X| . +C + IWRK = IW2 + CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, X, LDX, ZERO, + $ DWORK( IWRK ), M ) + CALL DSYMM( 'L', 'L', M, N, -ONE, DWORK, M, DWORK( IWRK ), M, + $ -ONE, F, LDF ) +C +C Workspace usage. +C + IWA = NP*NP + 1 + IWQ = IWA + NN + IWG = IWQ + NN + IW2 = IWG + NN +C +C Compute |D1111|*|D1111' D1121'| - gamma^2*Inp1 . +C |D1121| +C + CALL DLASET( 'U', NP1, NP1, ZERO, -GAMMA*GAMMA, DWORK, NP ) + IF( ND2.GT.0 ) + $ CALL DSYRK( 'U', 'N', NP1, ND2, ONE, D, LDD, ONE, DWORK, NP ) +C +C Compute inv(|D1111|*|D1111' D1121'| - gamma^2*Inp1) . +C |D1121| +C + IWRK = IWA + ANORM = DLANSY( 'I', 'U', NP1, DWORK, NP, DWORK( IWRK ) ) + CALL DSYTRF( 'U', NP1, DWORK, NP, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) + CALL DSYCON( 'U', NP1, DWORK, NP, IWORK, ANORM, RCOND, + $ DWORK( IWRK ), IWORK( NP1+1 ), INFO2 ) + IF( RCOND.LT.EPS ) THEN + INFO = 1 + RETURN + END IF +C +C Compute inv(RT) . +C + CALL DSYTRI( 'U', NP1, DWORK, NP, IWORK, DWORK( IWRK ), INFO2 ) +C +C Compute -inv(|D1111||D1111' D1121'| - gamma^2*Inp1)*|D1112| . +C |D1121| |D1122| +C + CALL DSYMM( 'L', 'U', NP1, NP2, -ONE, DWORK, NP, D( 1, ND2+1 ), + $ LDD, ZERO, DWORK( NP1*NP+1 ), NP ) +C +C Compute [D1112' D1122']*inv(|D1111||D1111' D1121'| - +C |D1121| +C +C gamma^2*Inp1)*|D1112| + Inp2 . +C |D1122| +C + CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK( NP1*(NP+1)+1 ), + $ NP ) + CALL MB01RX( 'Left', 'Upper', 'Transpose', NP2, NP1, ONE, -ONE, + $ DWORK( NP1*(NP+1)+1 ), NP, D( 1, ND2+1 ), LDD, + $ DWORK( NP1*NP+1 ), NP, INFO2 ) +C +C Compute B1*D11' . +C + CALL DGEMM( 'N', 'T', N, NP1, M1, ONE, B, LDB, D, LDD, ZERO, + $ DWORK( IW2 ), N ) +C +C Compute B1*DD1' . +C + CALL DLACPY( 'Full', N, NP2, B( 1, ND2+1 ), LDB, + $ DWORK( IW2+NP1*N ), N ) +C +C Compute B1*DD1'*inv(RT) in H . +C + CALL DSYMM( 'R', 'U', N, NP, ONE, DWORK, NP, DWORK( IW2 ), N, + $ ZERO, H, LDH ) +C +C Compute Ay = A - B1*DD1'*inv(RT)*C . +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IWA ), N ) + CALL DGEMM( 'N', 'N', N, N, NP, -ONE, H, LDH, C, LDC, ONE, + $ DWORK( IWA ), N ) +C +C Compute Cy = B1*B1' - B1*DD1'*inv(RT)*DD1*B1' . +C + IF( ND2.EQ.0 ) THEN + CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N ) + ELSE + CALL DSYRK( 'U', 'N', N, M1, ONE, B, LDB, ZERO, DWORK( IWQ ), + $ N ) + CALL MB01RX( 'Right', 'Upper', 'Transpose', N, NP, ONE, -ONE, + $ DWORK( IWQ ), N, H, LDH, DWORK( IW2 ), N, INFO2 ) + END IF +C +C Compute Dy = C'*inv(RT)*C . +C + IWRK = IW2 + CALL MB01RU( 'Upper', 'Transpose', N, NP, ZERO, ONE, DWORK( IWG ), + $ N, C, LDC, DWORK, NP, DWORK( IWRK), N*NP, INFO2 ) +C +C Solution of the Riccati equation Ay*Y + Y*Ay' + Cy - Y*Dy*Y = 0 . +C Workspace: need NP*NP + 13*N*N + 12*N + 5; +C prefer larger. +C + IWT = IW2 + IWV = IWT + NN + IWR = IWV + NN + IWI = IWR + N2 + IWS = IWI + N2 + IWRK = IWS + 4*NN +C + CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'Transpose', + $ 'Upper', 'GeneralScaling', 'Stable', 'NotFactored', + $ 'Original', N, DWORK( IWA ), N, DWORK( IWT ), N, + $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ Y, LDY, SEP, XYCOND( 2 ), FERR, DWORK( IWR ), + $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 3 + RETURN + END IF +C + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute H = -|B1*DD1' + Y*C'|*inv(RT) . +C + IWRK = IW2 + CALL DGEMM( 'N', 'T', N, NP, N, ONE, Y, LDY, C, LDC, ZERO, + $ DWORK( IWRK ), N ) + CALL DSYMM( 'R', 'U', N, NP, -ONE, DWORK, NP, DWORK( IWRK ), N, + $ -ONE, H, LDH ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10QD *** + END diff --git a/mex/sources/libslicot/SB10RD.f b/mex/sources/libslicot/SB10RD.f new file mode 100644 index 000000000..86d483bb3 --- /dev/null +++ b/mex/sources/libslicot/SB10RD.f @@ -0,0 +1,706 @@ + SUBROUTINE SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, + $ C, LDC, D, LDD, F, LDF, H, LDH, TU, LDTU, TY, + $ LDTY, X, LDX, Y, LDY, AK, LDAK, BK, LDBK, CK, + $ LDCK, DK, LDDK, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of an H-infinity (sub)optimal controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C from the state feedback matrix F and output injection matrix H as +C determined by the SLICOT Library routine SB10QD. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0. +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0. +C M-NCON >= NMEAS. +C +C GAMMA (input) DOUBLE PRECISION +C The value of gamma. It is assumed that gamma is +C sufficiently large so that the controller is admissible. +C GAMMA >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C F (input) DOUBLE PRECISION array, dimension (LDF,N) +C The leading M-by-N part of this array must contain the +C state feedback matrix F. +C +C LDF INTEGER +C The leading dimension of the array F. LDF >= max(1,M). +C +C H (input) DOUBLE PRECISION array, dimension (LDH,NP) +C The leading N-by-NP part of this array must contain the +C output injection matrix H. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C TU (input) DOUBLE PRECISION array, dimension (LDTU,M2) +C The leading M2-by-M2 part of this array must contain the +C control transformation matrix TU, as obtained by the +C SLICOT Library routine SB10PD. +C +C LDTU INTEGER +C The leading dimension of the array TU. LDTU >= max(1,M2). +C +C TY (input) DOUBLE PRECISION array, dimension (LDTY,NP2) +C The leading NP2-by-NP2 part of this array must contain the +C measurement transformation matrix TY, as obtained by the +C SLICOT Library routine SB10PD. +C +C LDTY INTEGER +C The leading dimension of the array TY. +C LDTY >= max(1,NP2). +C +C X (input) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array must contain the +C matrix X, solution of the X-Riccati equation, as obtained +C by the SLICOT Library routine SB10QD. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C Y (input) DOUBLE PRECISION array, dimension (LDY,N) +C The leading N-by-N part of this array must contain the +C matrix Y, solution of the Y-Riccati equation, as obtained +C by the SLICOT Library routine SB10QD. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= max(1,N). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), where +C LIWORK = max(2*(max(NP,M)-M2-NP2,M2,N),NP2) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= max(1, M2*NP2 + NP2*NP2 + M2*M2 + +C max(D1*D1 + max(2*D1, (D1+D2)*NP2), +C D2*D2 + max(2*D2, D2*M2), 3*N, +C N*(2*NP2 + M2) + +C max(2*N*M2, M2*NP2 + +C max(M2*M2+3*M2, NP2*(2*NP2+ +C M2+max(NP2,N)))))) +C where D1 = NP1 - M2, D2 = M1 - NP2, +C NP1 = NP - NP2, M1 = M - M2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is +C max( 1, Q*(3*Q + 3*N + max(2*N, 4*Q + max(Q, N)))). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the controller is not admissible (too small value +C of gamma); +C = 2: if the determinant of Im2 + Tu*D11HAT*Ty*D22 is zero. +C +C METHOD +C +C The routine implements the Glover's and Doyle's formulas [1],[2]. +C +C REFERENCES +C +C [1] Glover, K. and Doyle, J.C. +C State-space formulae for all stabilizing controllers that +C satisfy an Hinf norm bound and relations to risk sensitivity. +C Systems and Control Letters, vol. 11, pp. 167-172, 1988. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C input and output transformations. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Sept. 1999, Oct. 2001. +C +C KEYWORDS +C +C Algebraic Riccati equation, H-infinity optimal control, robust +C control. +C +C ********************************************************************* +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDF, LDH, LDTU, LDTY, LDWORK, LDX, LDY, + $ M, N, NCON, NMEAS, NP + DOUBLE PRECISION GAMMA +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ F( LDF, * ), H( LDH, * ), TU( LDTU, * ), + $ TY( LDTY, * ), X( LDX, * ), Y( LDY, * ) +C .. +C .. Local Scalars .. + INTEGER I, ID11, ID12, ID21, IJ, INFO2, IW1, IW2, IW3, + $ IW4, IWB, IWC, IWRK, J, LWAMAX, M1, M2, MINWRK, + $ ND1, ND2, NP1, NP2 + DOUBLE PRECISION ANORM, EPS, RCOND +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANSY +C .. +C .. External Subroutines .. + EXTERNAL DGECON, DGEMM, DGETRF, DGETRI, DGETRS, DLACPY, + $ DLASET, DPOTRF, DSYCON, DSYRK, DSYTRF, DSYTRS, + $ DTRMM, MA02AD, MB01RX, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( GAMMA.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -14 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -16 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN + INFO = -20 + ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN + INFO = -22 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -24 + ELSE IF( LDY.LT.MAX( 1, N ) ) THEN + INFO = -26 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -28 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -30 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -32 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -34 + ELSE +C +C Compute workspace. +C + ND1 = NP1 - M2 + ND2 = M1 - NP2 + MINWRK = MAX( 1, M2*NP2 + NP2*NP2 + M2*M2 + + $ MAX( ND1*ND1 + MAX( 2*ND1, ( ND1 + ND2 )*NP2 ), + $ ND2*ND2 + MAX( 2*ND2, ND2*M2 ), 3*N, + $ N*( 2*NP2 + M2 ) + + $ MAX( 2*N*M2, M2*NP2 + + $ MAX( M2*M2 + 3*M2, NP2*( 2*NP2 + + $ M2 + MAX( NP2, N ) ) ) ) ) ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -37 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + DWORK( 1 ) = ONE + RETURN + END IF +C +C Get the machine precision. +C + EPS = DLAMCH( 'Epsilon' ) +C +C Workspace usage. +C + ID11 = 1 + ID21 = ID11 + M2*NP2 + ID12 = ID21 + NP2*NP2 + IW1 = ID12 + M2*M2 + IW2 = IW1 + ND1*ND1 + IW3 = IW2 + ND1*NP2 + IWRK = IW2 +C +C Set D11HAT := -D1122 . +C + IJ = ID11 + DO 20 J = 1, NP2 + DO 10 I = 1, M2 + DWORK( IJ ) = -D( ND1+I, ND2+J ) + IJ = IJ + 1 + 10 CONTINUE + 20 CONTINUE +C +C Set D21HAT := Inp2 . +C + CALL DLASET( 'Upper', NP2, NP2, ZERO, ONE, DWORK( ID21 ), NP2 ) +C +C Set D12HAT := Im2 . +C + CALL DLASET( 'Lower', M2, M2, ZERO, ONE, DWORK( ID12 ), M2 ) +C +C Compute D11HAT, D21HAT, D12HAT . +C + LWAMAX = 0 + IF( ND1.GT.0 ) THEN + IF( ND2.EQ.0 ) THEN +C +C Compute D21HAT'*D21HAT = Inp2 - D1112'*D1112/gamma^2 . +C + CALL DSYRK( 'U', 'T', NP2, ND1, -ONE/GAMMA**2, D, LDD, ONE, + $ DWORK( ID21 ), NP2 ) + ELSE +C +C Compute gdum = gamma^2*Ind1 - D1111*D1111' . +C + CALL DLASET( 'U', ND1, ND1, ZERO, GAMMA**2, DWORK( IW1 ), + $ ND1 ) + CALL DSYRK( 'U', 'N', ND1, ND2, -ONE, D, LDD, ONE, + $ DWORK( IW1 ), ND1 ) + ANORM = DLANSY( 'I', 'U', ND1, DWORK( IW1 ), ND1, + $ DWORK( IWRK ) ) + CALL DSYTRF( 'U', ND1, DWORK( IW1 ), ND1, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 + CALL DSYCON( 'U', ND1, DWORK( IW1 ), ND1, IWORK, ANORM, + $ RCOND, DWORK( IWRK ), IWORK( ND1+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.EPS ) THEN + INFO = 1 + RETURN + END IF +C +C Compute inv(gdum)*D1112 . +C + CALL DLACPY( 'Full', ND1, NP2, D( 1, ND2+1 ), LDD, + $ DWORK( IW2 ), ND1 ) + CALL DSYTRS( 'U', ND1, NP2, DWORK( IW1 ), ND1, IWORK, + $ DWORK( IW2 ), ND1, INFO2 ) +C +C Compute D11HAT = -D1121*D1111'*inv(gdum)*D1112 - D1122 . +C + CALL DGEMM( 'T', 'N', ND2, NP2, ND1, ONE, D, LDD, + $ DWORK( IW2 ), ND1, ZERO, DWORK( IW3 ), ND2 ) + CALL DGEMM( 'N', 'N', M2, NP2, ND2, -ONE, D( ND1+1, 1 ), + $ LDD, DWORK( IW3 ), ND2, ONE, DWORK( ID11 ), M2 ) +C +C Compute D21HAT'*D21HAT = Inp2 - D1112'*inv(gdum)*D1112 . +C + CALL MB01RX( 'Left', 'Upper', 'Transpose', NP2, ND1, ONE, + $ -ONE, DWORK( ID21 ), NP2, D( 1, ND2+1 ), LDD, + $ DWORK( IW2 ), ND1, INFO2 ) +C + IW2 = IW1 + ND2*ND2 + IWRK = IW2 +C +C Compute gdum = gamma^2*Ind2 - D1111'*D1111 . +C + CALL DLASET( 'L', ND2, ND2, ZERO, GAMMA**2, DWORK( IW1 ), + $ ND2 ) + CALL DSYRK( 'L', 'T', ND2, ND1, -ONE, D, LDD, ONE, + $ DWORK( IW1 ), ND2 ) + ANORM = DLANSY( 'I', 'L', ND2, DWORK( IW1 ), ND2, + $ DWORK( IWRK ) ) + CALL DSYTRF( 'L', ND2, DWORK( IW1 ), ND2, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) + CALL DSYCON( 'L', ND2, DWORK( IW1 ), ND2, IWORK, ANORM, + $ RCOND, DWORK( IWRK ), IWORK( ND2+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.EPS ) THEN + INFO = 1 + RETURN + END IF +C +C Compute inv(gdum)*D1121' . +C + CALL MA02AD( 'Full', M2, ND2, D( ND1+1, 1 ), LDD, + $ DWORK( IW2 ), ND2 ) + CALL DSYTRS( 'L', ND2, M2, DWORK( IW1 ), ND2, IWORK, + $ DWORK( IW2 ), ND2, INFO2 ) +C +C Compute D12HAT*D12HAT' = Im2 - D1121*inv(gdum)*D1121' . +C + CALL MB01RX( 'Left', 'Lower', 'NoTranspose', M2, ND2, ONE, + $ -ONE, DWORK( ID12 ), M2, D( ND1+1, 1 ), LDD, + $ DWORK( IW2 ), ND2, INFO2 ) + END IF + ELSE + IF( ND2.GT.0 ) THEN +C +C Compute D12HAT*D12HAT' = Im2 - D1121*D1121'/gamma^2 . +C + CALL DSYRK( 'L', 'N', M2, ND2, -ONE/GAMMA**2, D, LDD, ONE, + $ DWORK( ID12 ), M2 ) + END IF + END IF +C +C Compute D21HAT using Cholesky decomposition. +C + CALL DPOTRF( 'U', NP2, DWORK( ID21 ), NP2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C +C Compute D12HAT using Cholesky decomposition. +C + CALL DPOTRF( 'L', M2, DWORK( ID12 ), M2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C _ +C Compute Z = In - Y*X/gamma^2 and its LU factorization in AK . +C + IWRK = IW1 + CALL DLASET( 'Full', N, N, ZERO, ONE, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, N, -ONE/GAMMA**2, Y, LDY, X, LDX, + $ ONE, AK, LDAK ) + ANORM = DLANGE( '1', N, N, AK, LDAK, DWORK( IWRK ) ) + CALL DGETRF( N, N, AK, LDAK, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + CALL DGECON( '1', N, AK, LDAK, ANORM, RCOND, DWORK( IWRK ), + $ IWORK( N+1 ), INFO ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.EPS ) THEN + INFO = 1 + RETURN + END IF +C + IWB = IW1 + IWC = IWB + N*NP2 + IW1 = IWC + ( M2 + NP2 )*N + IW2 = IW1 + N*M2 +C +C Compute C2' + F12' in BK . +C + DO 40 J = 1, N + DO 30 I = 1, NP2 + BK( J, I ) = C( NP1 + I, J ) + F( ND2 + I, J ) + 30 CONTINUE + 40 CONTINUE +C _ +C Compute the transpose of (C2 + F12)*Z , with Z = inv(Z) . +C + CALL DGETRS( 'Transpose', N, NP2, AK, LDAK, IWORK, BK, LDBK, + $ INFO2 ) +C +C Compute the transpose of F2*Z . +C + CALL MA02AD( 'Full', M2, N, F( M1+1, 1 ), LDF, DWORK( IW1 ), N ) + CALL DGETRS( 'Transpose', N, M2, AK, LDAK, IWORK, DWORK( IW1 ), N, + $ INFO2 ) +C +C Compute the transpose of C1HAT = F2*Z - D11HAT*(C2 + F12)*Z . +C + CALL DGEMM( 'N', 'T', N, M2, NP2, -ONE, BK, LDBK, DWORK( ID11 ), + $ M2, ONE, DWORK( IW1 ), N ) +C +C Compute CHAT . +C + CALL DGEMM( 'N', 'T', M2, N, M2, ONE, TU, LDTU, DWORK( IW1 ), N, + $ ZERO, DWORK( IWC ), M2+NP2 ) + CALL MA02AD( 'Full', N, NP2, BK, LDBK, DWORK( IWC+M2 ), M2+NP2 ) + CALL DTRMM( 'L', 'U', 'N', 'N', NP2, N, -ONE, DWORK( ID21 ), NP2, + $ DWORK( IWC+M2 ), M2+NP2 ) +C +C Compute B2 + H12 . +C + IJ = IW2 + DO 60 J = 1, M2 + DO 50 I = 1, N + DWORK( IJ ) = B( I, M1 + J ) + H( I, ND1 + J ) + IJ = IJ + 1 + 50 CONTINUE + 60 CONTINUE +C +C Compute A + HC in AK . +C + CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, NP, ONE, H, LDH, C, LDC, ONE, AK, + $ LDAK ) +C +C Compute AHAT = A + HC + (B2 + H12)*C1HAT in AK . +C + CALL DGEMM( 'N', 'T', N, N, M2, ONE, DWORK( IW2 ), N, + $ DWORK( IW1 ), N, ONE, AK, LDAK ) +C +C Compute B1HAT = -H2 + (B2 + H12)*D11HAT in BK . +C + CALL DLACPY( 'Full', N, NP2, H( 1, NP1+1 ), LDH, BK, LDBK ) + CALL DGEMM( 'N', 'N', N, NP2, M2, ONE, DWORK( IW2 ), N, + $ DWORK( ID11 ), M2, -ONE, BK, LDBK ) +C +C Compute the first block of BHAT, BHAT1 . +C + CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, BK, LDBK, TY, LDTY, ZERO, + $ DWORK( IWB ), N ) +C +C Compute Tu*D11HAT . +C + CALL DGEMM( 'N', 'N', M2, NP2, M2, ONE, TU, LDTU, DWORK( ID11 ), + $ M2, ZERO, DWORK( IW1 ), M2 ) +C +C Compute Tu*D11HAT*Ty in DK . +C + CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DWORK( IW1 ), M2, TY, + $ LDTY, ZERO, DK, LDDK ) +C +C Compute P = Im2 + Tu*D11HAT*Ty*D22 and its condition. +C + IW2 = IW1 + M2*NP2 + IWRK = IW2 + M2*M2 + CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 ) + CALL DGEMM( 'N', 'N', M2, M2, NP2, ONE, DK, LDDK, + $ D( NP1+1, M1+1 ), LDD, ONE, DWORK( IW2 ), M2 ) + ANORM = DLANGE( '1', M2, M2, DWORK( IW2 ), M2, DWORK( IWRK ) ) + CALL DGETRF( M2, M2, DWORK( IW2 ), M2, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF + CALL DGECON( '1', M2, DWORK( IW2 ), M2, ANORM, RCOND, + $ DWORK( IWRK ), IWORK( M2+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.EPS ) THEN + INFO = 2 + RETURN + END IF +C +C Find the controller matrix CK, CK = inv(P)*CHAT(1:M2,:) . +C + CALL DLACPY( 'Full', M2, N, DWORK( IWC ), M2+NP2, CK, LDCK ) + CALL DGETRS( 'NoTranspose', M2, N, DWORK( IW2 ), M2, IWORK, CK, + $ LDCK, INFO2 ) +C +C Find the controller matrices AK, BK, and DK, exploiting the +C special structure of the relations. +C +C Compute Q = Inp2 + D22*Tu*D11HAT*Ty and its LU factorization. +C + IW3 = IW2 + NP2*NP2 + IW4 = IW3 + NP2*M2 + IWRK = IW4 + NP2*NP2 + CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK( IW2 ), NP2 ) + CALL DGEMM( 'N', 'N', NP2, NP2, M2, ONE, D( NP1+1, M1+1 ), LDD, + $ DK, LDDK, ONE, DWORK( IW2 ), NP2 ) + CALL DGETRF( NP2, NP2, DWORK( IW2 ), NP2, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF +C +C Compute A1 = inv(Q)*D22 and inv(Q) . +C + CALL DLACPY( 'Full', NP2, M2, D( NP1+1, M1+1 ), LDD, DWORK( IW3 ), + $ NP2 ) + CALL DGETRS( 'NoTranspose', NP2, M2, DWORK( IW2 ), NP2, IWORK, + $ DWORK( IW3 ), NP2, INFO2 ) + CALL DGETRI( NP2, DWORK( IW2 ), NP2, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute A2 = ( inv(Ty) - inv(Q)*inv(Ty) - +C A1*Tu*D11HAT )*inv(D21HAT) . +C + CALL DLACPY( 'Full', NP2, NP2, TY, LDTY, DWORK( IW4 ), NP2 ) + CALL DGETRF( NP2, NP2, DWORK( IW4 ), NP2, IWORK, INFO2 ) + CALL DGETRI( NP2, DWORK( IW4 ), NP2, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) +C + CALL DLACPY( 'Full', NP2, NP2, DWORK( IW4 ), NP2, DWORK( IWRK ), + $ NP2 ) + CALL DGEMM( 'N', 'N', NP2, NP2, NP2, -ONE, DWORK( IW2), NP2, + $ DWORK( IWRK ), NP2, ONE, DWORK( IW4 ), NP2 ) + CALL DGEMM( 'N', 'N', NP2, NP2, M2, -ONE, DWORK( IW3), NP2, + $ DWORK( IW1 ), M2, ONE, DWORK( IW4 ), NP2 ) + CALL DTRMM( 'R', 'U', 'N', 'N', NP2, NP2, ONE, DWORK( ID21 ), NP2, + $ DWORK( IW4 ), NP2 ) +C +C Compute [ A1 A2 ]*CHAT . +C + CALL DGEMM( 'N', 'N', NP2, N, M2+NP2, ONE, DWORK( IW3 ), NP2, + $ DWORK( IWC ), M2+NP2, ZERO, DWORK( IWRK ), NP2 ) +C +C Compute AK := AHAT - BHAT1*[ A1 A2 ]*CHAT . +C + CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, DWORK( IWB ), N, + $ DWORK( IWRK ), NP2, ONE, AK, LDAK ) +C +C Compute BK := BHAT1*inv(Q) . +C + CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, DWORK( IWB ), N, + $ DWORK( IW2 ), NP2, ZERO, BK, LDBK ) +C +C Compute DK := Tu*D11HAT*Ty*inv(Q) . +C + CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DK, LDDK, DWORK( IW2 ), + $ NP2, ZERO, DWORK( IW3 ), M2 ) + CALL DLACPY( 'Full', M2, NP2, DWORK( IW3 ), M2, DK, LDDK ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10RD *** + END diff --git a/mex/sources/libslicot/SB10SD.f b/mex/sources/libslicot/SB10SD.f new file mode 100644 index 000000000..ee99c78f2 --- /dev/null +++ b/mex/sources/libslicot/SB10SD.f @@ -0,0 +1,629 @@ + SUBROUTINE SB10SD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, + $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, + $ X, LDX, Y, LDY, RCOND, TOL, IWORK, DWORK, + $ LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the H2 optimal controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C for the normalized discrete-time system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 0 | +C +C where B2 has as column size the number of control inputs (NCON) +C and C2 has as row size the number of measurements (NMEAS) being +C provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank with D12 = | 0 | and D21 is +C | I | +C full row rank with D21 = | 0 I | as obtained by the +C SLICOT Library routine SB10PD, +C +C j*Theta +C (A3) | A-e *I B2 | has full column rank for all +C | C1 D12 | +C +C 0 <= Theta < 2*Pi , +C +C +C j*Theta +C (A4) | A-e *I B1 | has full row rank for all +C | C2 D21 | +C +C 0 <= Theta < 2*Pi . +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. Only the leading +C (NP-NP2)-by-(M-M2) submatrix D11 is used. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array contains the matrix +C X, solution of the X-Riccati equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,N) +C The leading N-by-N part of this array contains the matrix +C Y, solution of the Y-Riccati equation. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= max(1,N). +C +C RCOND (output) DOUBLE PRECISION array, dimension (4) +C RCOND contains estimates of the reciprocal condition +C numbers of the matrices which are to be inverted and the +C reciprocal condition numbers of the Riccati equations +C which have to be solved during the computation of the +C controller. (See the description of the algorithm in [2].) +C RCOND(1) contains the reciprocal condition number of the +C matrix Im2 + B2'*X2*B2; +C RCOND(2) contains the reciprocal condition number of the +C matrix Ip2 + C2*Y2*C2'; +C RCOND(3) contains the reciprocal condition number of the +C X-Riccati equation; +C RCOND(4) contains the reciprocal condition number of the +C Y-Riccati equation. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used in determining the nonsingularity of the +C matrices which must be inverted. If TOL <= 0, then a +C default value equal to sqrt(EPS) is used, where EPS is the +C relative machine precision. +C +C Workspace +C +C IWORK INTEGER array, dimension max(M2,2*N,N*N,NP2) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= max(1, 14*N*N+6*N+max(14*N+23,16*N), +C M2*(N+M2+max(3,M1)), NP2*(N+NP2+3)), +C where M1 = M - M2. +C For good performance, LDWORK must generally be larger. +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the X-Riccati equation was not solved +C successfully; +C = 2: if the matrix Im2 + B2'*X2*B2 is not positive +C definite, or it is numerically singular (with +C respect to the tolerance TOL); +C = 3: if the Y-Riccati equation was not solved +C successfully; +C = 4: if the matrix Ip2 + C2*Y2*C2' is not positive +C definite, or it is numerically singular (with +C respect to the tolerance TOL). +C +C METHOD +C +C The routine implements the formulas given in [1]. The X- and +C Y-Riccati equations are solved with condition estimates. +C +C REFERENCES +C +C [1] Zhou, K., Doyle, J.C., and Glover, K. +C Robust and Optimal Control. +C Prentice-Hall, Upper Saddle River, NJ, 1996. +C +C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of linear +C discrete-time control systems. +C Report 99-8, Department of Engineering, Leicester University, +C April 1999. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C matrices which are to be inverted and on the condition numbers of +C the matrix Riccati equations which are to be solved in the +C computation of the controller. (The corresponding reciprocal +C condition numbers are given in the output array RCOND.) +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, April 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C January 2003. +C +C KEYWORDS +C +C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal +C regulator, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, LDX, LDY, M, N, NCON, NMEAS, NP + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( * ), X( LDX, * ), Y( LDY, * ) + LOGICAL BWORK( * ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IW2, IWB, IWC, IWG, IWI, IWQ, IWR, IWRK, + $ IWS, IWT, IWU, IWV, J, LWAMAX, M1, M2, MINWRK, + $ ND1, ND2, NP1, NP2 + DOUBLE PRECISION ANORM, FERR, RCOND2, SEPD, TOLL +C .. +C .. External functions .. + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASET, DPOCON, DPOTRF, DPOTRS, + $ DSWAP, DSYRK, DTRSM, MB01RX, SB02OD, SB02SD, + $ XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -13 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -19 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -21 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -23 + ELSE IF( LDY.LT.MAX( 1, N ) ) THEN + INFO = -25 + ELSE +C +C Compute workspace. +C + MINWRK = MAX( 1, 14*N*N + 6*N + MAX( 14*N + 23, 16*N ), + $ M2*( N + M2 + MAX( 3, M1 ) ), NP2*( N + NP2 + 3 ) ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -30 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10SD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + ND1 = NP1 - M2 + ND2 = M1 - NP2 + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance for nonsingularity test. +C + TOLL = SQRT( DLAMCH( 'Epsilon' ) ) + END IF +C +C Workspace usage. +C + IWQ = 1 + IWG = IWQ + N*N + IWR = IWG + N*N + IWI = IWR + 2*N + IWB = IWI + 2*N + IWS = IWB + 2*N + IWT = IWS + 4*N*N + IWU = IWT + 4*N*N + IWRK = IWU + 4*N*N + IWC = IWR + IWV = IWC + N*N +C +C Compute Ax = A - B2*D12'*C1 in AK . +C + CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, M2, -ONE, B( 1, M1+1 ), LDB, + $ C( ND1+1, 1), LDC, ONE, AK, LDAK ) +C +C Compute Cx = C1'*C1 - C1'*D12*D12'*C1 . +C + IF( ND1.GT.0 ) THEN + CALL DSYRK( 'L', 'T', N, ND1, ONE, C, LDC, ZERO, DWORK( IWQ ), + $ N ) + ELSE + CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N ) + END IF +C +C Compute Dx = B2*B2' . +C + CALL DSYRK( 'L', 'N', N, M2, ONE, B( 1, M1+1 ), LDB, ZERO, + $ DWORK( IWG ), N ) +C +C Solution of the discrete-time Riccati equation +C Ax'*inv(In + X2*Dx)*X2*Ax - X2 + Cx = 0 . +C Workspace: need 14*N*N + 6*N + max(14*N+23,16*N); +C prefer larger. +C + CALL SB02OD( 'D', 'G', 'N', 'L', 'Z', 'S', N, M2, NP1, AK, LDAK, + $ DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWRK ), M, + $ DWORK( IWRK ), N, RCOND2, X, LDX, DWORK( IWR ), + $ DWORK( IWI ), DWORK( IWB ), DWORK( IWS ), 2*N, + $ DWORK( IWT ), 2*N, DWORK( IWU ), 2*N, TOLL, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Condition estimation. +C Workspace: need 4*N*N + max(N*N+5*N,max(3,2*N*N)+N*N); +C prefer larger. +C + IWRK = IWV + N*N + CALL SB02SD( 'C', 'N', 'N', 'L', 'O', N, AK, LDAK, DWORK( IWC ), + $ N, DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ X, LDX, SEPD, RCOND( 3 ), FERR, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) RCOND( 3 ) = ZERO + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IW2 = M2*N + 1 + IWRK = IW2 + M2*M2 +C +C Compute B2'*X2 . +C + CALL DGEMM( 'T', 'N', M2, N, N, ONE, B( 1, M1+1 ), LDB, X, LDX, + $ ZERO, DWORK, M2 ) +C +C Compute Im2 + B2'*X2*B2 . +C + CALL DLASET( 'L', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 ) + CALL MB01RX( 'Left', 'Lower', 'N', M2, N, ONE, ONE, DWORK( IW2 ), + $ M2, DWORK, M2, B( 1, M1+1 ), LDB, INFO2 ) +C +C Compute the Cholesky factorization of Im2 + B2'*X2*B2 . +C Workspace: need M2*N + M2*M2 + max(3*M2,M2*M1); +C prefer larger. +C + ANORM = DLANSY( 'I', 'L', M2, DWORK( IW2 ), M2, DWORK( IWRK ) ) + CALL DPOTRF( 'L', M2, DWORK( IW2 ), M2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF + CALL DPOCON( 'L', M2, DWORK( IW2 ), M2, ANORM, RCOND( 1 ), + $ DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 1 ).LT.TOLL ) THEN + INFO = 2 + RETURN + END IF +C +C Compute -( B2'*X2*A + D12'*C1 ) in CK . +C + CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, CK, LDCK ) + CALL DGEMM( 'N', 'N', M2, N, N, -ONE, DWORK, M2, A, LDA, -ONE, CK, + $ LDCK ) +C +C Compute F2 = -inv( Im2 + B2'*X2*B2 )*( B2'*X2*A + D12'*C1 ) . +C + CALL DPOTRS( 'L', M2, N, DWORK( IW2 ), M2, CK, LDCK, INFO2 ) +C +C Compute -( B2'*X2*B1 + D12'*D11 ) . +C + CALL DLACPY( 'Full', M2, M1, D( ND1+1, 1 ), LDD, DWORK( IWRK ), + $ M2 ) + CALL DGEMM( 'N', 'N', M2, M1, N, -ONE, DWORK, M2, B, LDB, -ONE, + $ DWORK( IWRK ), M2 ) +C +C Compute F0 = -inv( Im2 + B2'*X2*B2 )*( B2'*X2*B1 + D12'*D11 ) . +C + CALL DPOTRS( 'L', M2, M1, DWORK( IW2 ), M2, DWORK( IWRK ), M2, + $ INFO2 ) +C +C Save F0*D21' in DK . +C + CALL DLACPY( 'Full', M2, NP2, DWORK( IWRK+ND2*M2 ), M2, DK, + $ LDDK ) +C +C Workspace usage. +C + IWRK = IWU + 4*N*N +C +C Compute Ay = A - B1*D21'*C2 in AK . +C + CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, B( 1, ND2+1 ), LDB, + $ C( NP1+1, 1 ), LDC, ONE, AK, LDAK ) +C +C Transpose Ay in-situ. +C + DO 20 J = 1, N - 1 + CALL DSWAP( J, AK( J+1, 1 ), LDAK, AK( 1, J+1 ), 1 ) + 20 CONTINUE +C +C Compute Cy = B1*B1' - B1*D21'*D21*B1' . +C + IF( ND2.GT.0 ) THEN + CALL DSYRK( 'U', 'N', N, ND2, ONE, B, LDB, ZERO, DWORK( IWQ ), + $ N ) + ELSE + CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N ) + END IF +C +C Compute Dy = C2'*C2 . +C + CALL DSYRK( 'U', 'T', N, NP2, ONE, C( NP1+1, 1 ), LDC, ZERO, + $ DWORK( IWG ), N ) +C +C Solution of the discrete-time Riccati equation +C Ay*inv( In + Y2*Dy )*Y2*Ay' - Y2 + Cy = 0 . +C + CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, NP2, M1, AK, LDAK, + $ DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWRK ), M, + $ DWORK( IWRK ), N, RCOND2, Y, LDY, DWORK( IWR ), + $ DWORK( IWI ), DWORK( IWB ), DWORK( IWS ), 2*N, + $ DWORK( IWT ), 2*N, DWORK( IWU ), 2*N, TOLL, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Condition estimation. +C + IWRK = IWV + N*N + CALL SB02SD( 'C', 'N', 'N', 'U', 'O', N, AK, LDAK, DWORK( IWC ), + $ N, DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ Y, LDY, SEPD, RCOND( 4 ), FERR, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) RCOND( 4 ) = ZERO + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IW2 = N*NP2 + 1 + IWRK = IW2 + NP2*NP2 +C +C Compute Y2*C2' . +C + CALL DGEMM( 'N', 'T', N, NP2, N, ONE, Y, LDY, C( NP1+1, 1 ), LDC, + $ ZERO, DWORK, N ) +C +C Compute Ip2 + C2*Y2*C2' . +C + CALL DLASET( 'U', NP2, NP2, ZERO, ONE, DWORK( IW2 ), NP2 ) + CALL MB01RX( 'Left', 'Upper', 'N', NP2, N, ONE, ONE, DWORK( IW2 ), + $ NP2, C( NP1+1, 1 ), LDC, DWORK, N, INFO2 ) +C +C Compute the Cholesky factorization of Ip2 + C2*Y2*C2' . +C + ANORM = DLANSY( 'I', 'U', NP2, DWORK( IW2 ), NP2, DWORK( IWRK ) ) + CALL DPOTRF( 'U', NP2, DWORK( IW2 ), NP2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 4 + RETURN + END IF + CALL DPOCON( 'U', NP2, DWORK( IW2 ), NP2, ANORM, RCOND( 2 ), + $ DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 2 ).LT.TOLL ) THEN + INFO = 4 + RETURN + END IF +C +C Compute A*Y2*C2' + B1*D21' in BK . +C + CALL DLACPY ( 'Full', N, NP2, B( 1, ND2+1 ), LDB, BK, LDBK ) + CALL DGEMM( 'N', 'N', N, NP2, N, ONE, A, LDA, DWORK, N, ONE, + $ BK, LDBK ) +C +C Compute L2 = -( A*Y2*C2' + B1*D21' )*inv( Ip2 + C2*Y2*C2' ) . +C + CALL DTRSM( 'R', 'U', 'N', 'N', N, NP2, -ONE, DWORK( IW2 ), NP2, + $ BK, LDBK ) + CALL DTRSM( 'R', 'U', 'T', 'N', N, NP2, ONE, DWORK( IW2 ), NP2, + $ BK, LDBK ) +C +C Compute F2*Y2*C2' + F0*D21' . +C + CALL DGEMM( 'N', 'N', M2, NP2, N, ONE, CK, LDCK, DWORK, N, ONE, + $ DK, LDDK ) +C +C Compute DK = L0 = ( F2*Y2*C2' + F0*D21' )*inv( Ip2 + C2*Y2*C2' ) . +C + CALL DTRSM( 'R', 'U', 'N', 'N', M2, NP2, ONE, DWORK( IW2 ), NP2, + $ DK, LDDK ) + CALL DTRSM( 'R', 'U', 'T', 'N', M2, NP2, ONE, DWORK( IW2 ), NP2, + $ DK, LDDK ) +C +C Compute CK = F2 - L0*C2 . +C + CALL DGEMM( 'N', 'N', M2, N, NP2, -ONE, DK, LDDK, C( NP1+1, 1), + $ LDC, ONE, CK, LDCK ) +C +C Find AK = A + B2*( F2 - L0*C2 ) + L2*C2 . +C + CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, M2, ONE, B(1, M1+1 ), LDB, CK, LDCK, + $ ONE, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, NP2, ONE, BK, LDBK, C( NP1+1, 1), + $ LDC, ONE, AK, LDAK ) +C +C Find BK = -L2 + B2*L0 . +C + CALL DGEMM( 'N', 'N', N, NP2, M2, ONE, B( 1, M1+1 ), LDB, DK, + $ LDDK, -ONE, BK, LDBK ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10SD *** + END diff --git a/mex/sources/libslicot/SB10TD.f b/mex/sources/libslicot/SB10TD.f new file mode 100644 index 000000000..e8d193b41 --- /dev/null +++ b/mex/sources/libslicot/SB10TD.f @@ -0,0 +1,350 @@ + SUBROUTINE SB10TD( N, M, NP, NCON, NMEAS, D, LDD, TU, LDTU, TY, + $ LDTY, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, + $ RCOND, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the H2 optimal discrete-time controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C from the matrices of the controller for the normalized system, +C as determined by the SLICOT Library routine SB10SD. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0. +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0. +C M-NCON >= NMEAS. +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. Only the trailing +C NMEAS-by-NCON submatrix D22 is used. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C TU (input) DOUBLE PRECISION array, dimension (LDTU,M2) +C The leading M2-by-M2 part of this array must contain the +C control transformation matrix TU, as obtained by the +C SLICOT Library routine SB10PD. +C +C LDTU INTEGER +C The leading dimension of the array TU. LDTU >= max(1,M2). +C +C TY (input) DOUBLE PRECISION array, dimension (LDTY,NP2) +C The leading NP2-by-NP2 part of this array must contain the +C measurement transformation matrix TY, as obtained by the +C SLICOT Library routine SB10PD. +C +C LDTY INTEGER +C The leading dimension of the array TY. +C LDTY >= max(1,NP2). +C +C AK (input/output) DOUBLE PRECISION array, dimension (LDAK,N) +C On entry, the leading N-by-N part of this array must +C contain controller state matrix for the normalized system +C as obtained by the SLICOT Library routine SB10SD. +C On exit, the leading N-by-N part of this array contains +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (input/output) DOUBLE PRECISION array, dimension +C (LDBK,NMEAS) +C On entry, the leading N-by-NMEAS part of this array must +C contain controller input matrix for the normalized system +C as obtained by the SLICOT Library routine SB10SD. +C On exit, the leading N-by-NMEAS part of this array +C contains controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (input/output) DOUBLE PRECISION array, dimension (LDCK,N) +C On entry, the leading NCON-by-N part of this array must +C contain controller output matrix for the normalized +C system as obtained by the SLICOT Library routine SB10SD. +C On exit, the leading NCON-by-N part of this array contains +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (input/output) DOUBLE PRECISION array, dimension +C (LDDK,NMEAS) +C On entry, the leading NCON-by-NMEAS part of this array +C must contain controller matrix DK for the normalized +C system as obtained by the SLICOT Library routine SB10SD. +C On exit, the leading NCON-by-NMEAS part of this array +C contains controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C RCOND (output) DOUBLE PRECISION +C RCOND contains an estimate of the reciprocal condition +C number of the matrix Im2 + DKHAT*D22 which must be +C inverted in the computation of the controller. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used in determining the nonsingularity of the +C matrix which must be inverted. If TOL <= 0, then a default +C value equal to sqrt(EPS) is used, where EPS is the +C relative machine precision. +C +C Workspace +C +C IWORK INTEGER array, dimension (2*M2) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= max(N*M2,N*NP2,M2*NP2,M2*M2+4*M2). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix Im2 + DKHAT*D22 is singular, or the +C estimated condition number is larger than or equal +C to 1/TOL. +C +C METHOD +C +C The routine implements the formulas given in [1]. +C +C REFERENCES +C +C [1] Zhou, K., Doyle, J.C., and Glover, K. +C Robust and Optimal Control. +C Prentice-Hall, Upper Saddle River, NJ, 1996. +C +C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of linear +C discrete-time control systems. +C Report 99-8, Department of Engineering, Leicester University, +C April 1999. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C input and output transformations and of the matrix Im2 + +C DKHAT*D22. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, April 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Jan. 2000. +C +C KEYWORDS +C +C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal +C regulator, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDAK, LDBK, LDCK, LDD, LDDK, LDTU, LDTY, + $ LDWORK, M, N, NCON, NMEAS, NP + DOUBLE PRECISION RCOND, TOL +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AK( LDAK, * ), BK( LDBK, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ TU( LDTU, * ), TY( LDTY, * ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IWRK, M1, M2, MINWRK, NP1, NP2 + DOUBLE PRECISION ANORM, TOLL +C .. +C .. External Functions + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE +C .. +C .. External Subroutines .. + EXTERNAL DGECON, DGEMM, DGETRF, DGETRS, DLACPY, DLASET, + $ XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -7 + ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN + INFO = -9 + ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN + INFO = -11 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -17 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -19 + ELSE +C +C Compute workspace. +C + MINWRK = MAX ( N*M2, N*NP2, M2*NP2, M2*( M2 + 4 ) ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -24 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10TD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND = ONE + RETURN + END IF +C + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance for nonsingularity test. +C + TOLL = SQRT( DLAMCH( 'Epsilon' ) ) + END IF +C +C Find BKHAT . +C + CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, BK, LDBK, TY, LDTY, ZERO, + $ DWORK, N ) + CALL DLACPY ('Full', N, NP2, DWORK, N, BK, LDBK ) +C +C Find CKHAT . +C + CALL DGEMM( 'N', 'N', M2, N, M2, ONE, TU, LDTU, CK, LDCK, ZERO, + $ DWORK, M2 ) + CALL DLACPY ('Full', M2, N, DWORK, M2, CK, LDCK ) +C +C Compute DKHAT . +C + CALL DGEMM( 'N', 'N', M2, NP2, M2, ONE, TU, LDTU, DK, LDDK, ZERO, + $ DWORK, M2 ) + CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DWORK, M2, TY, LDTY, + $ ZERO, DK, LDDK ) +C +C Compute Im2 + DKHAT*D22 . +C + IWRK = M2*M2 + 1 + CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK, M2 ) + CALL DGEMM( 'N', 'N', M2, M2, NP2, ONE, DK, LDDK, + $ D( NP1+1, M1+1 ), LDD, ONE, DWORK, M2 ) + ANORM = DLANGE( '1', M2, M2, DWORK, M2, DWORK( IWRK ) ) + CALL DGETRF( M2, M2, DWORK, M2, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + CALL DGECON( '1', M2, DWORK, M2, ANORM, RCOND, DWORK( IWRK ), + $ IWORK( M2+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.TOLL ) THEN + INFO = 1 + RETURN + END IF +C +C Compute CK . +C + CALL DGETRS( 'N', M2, N, DWORK, M2, IWORK, CK, LDCK, INFO2 ) +C +C Compute DK . +C + CALL DGETRS( 'N', M2, NP2, DWORK, M2, IWORK, DK, LDDK, INFO2 ) +C +C Compute AK . +C + CALL DGEMM( 'N', 'N', N, M2, NP2, ONE, BK, LDBK, D( NP1+1, M1+1 ), + $ LDD, ZERO, DWORK, N ) + CALL DGEMM( 'N', 'N', N, N, M2, -ONE, DWORK, N, CK, LDCK, ONE, AK, + $ LDAK ) +C +C Compute BK . +C + CALL DGEMM( 'N', 'N', N, NP2, M2, -ONE, DWORK, N, DK, LDDK, + $ ONE, BK, LDBK ) + RETURN +C *** Last line of SB10TD *** + END diff --git a/mex/sources/libslicot/SB10UD.f b/mex/sources/libslicot/SB10UD.f new file mode 100644 index 000000000..b5919d442 --- /dev/null +++ b/mex/sources/libslicot/SB10UD.f @@ -0,0 +1,419 @@ + SUBROUTINE SB10UD( N, M, NP, NCON, NMEAS, B, LDB, C, LDC, D, LDD, + $ TU, LDTU, TY, LDTY, RCOND, TOL, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the matrices D12 and D21 of the linear time-invariant +C system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | 0 D12 | | C | D | +C | C2 | D21 D22 | +C +C to unit diagonal form, and to transform the matrices B and C to +C satisfy the formulas in the computation of the H2 optimal +C controller. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the system input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading NP-by-N part of this array must +C contain the system output matrix C. +C On exit, the leading NP-by-N part of this array contains +C the transformed system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading NP-by-M part of this array must +C contain the system input/output matrix D. +C The (NP-NMEAS)-by-(M-NCON) leading submatrix D11 is not +C referenced. +C On exit, the trailing NMEAS-by-NCON part (in the leading +C NP-by-M part) of this array contains the transformed +C submatrix D22. +C The transformed submatrices D12 = [ 0 Im2 ]' and +C D21 = [ 0 Inp2 ] are not stored. The corresponding part +C of this array contains no useful information. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C TU (output) DOUBLE PRECISION array, dimension (LDTU,M2) +C The leading M2-by-M2 part of this array contains the +C control transformation matrix TU. +C +C LDTU INTEGER +C The leading dimension of the array TU. LDTU >= max(1,M2). +C +C TY (output) DOUBLE PRECISION array, dimension (LDTY,NP2) +C The leading NP2-by-NP2 part of this array contains the +C measurement transformation matrix TY. +C +C LDTY INTEGER +C The leading dimension of the array TY. +C LDTY >= max(1,NP2). +C +C RCOND (output) DOUBLE PRECISION array, dimension (2) +C RCOND(1) contains the reciprocal condition number of the +C control transformation matrix TU; +C RCOND(2) contains the reciprocal condition number of the +C measurement transformation matrix TY. +C RCOND is set even if INFO = 1 or INFO = 2; if INFO = 1, +C then RCOND(2) was not computed, but it is set to 0. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used for controlling the accuracy of the applied +C transformations. Transformation matrices TU and TY whose +C reciprocal condition numbers are less than TOL are not +C allowed. If TOL <= 0, then a default value equal to +C sqrt(EPS) is used, where EPS is the relative machine +C precision. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= MAX( M2 + NP1*NP1 + MAX(NP1*N,3*M2+NP1,5*M2), +C NP2 + M1*M1 + MAX(M1*N,3*NP2+M1,5*NP2), +C N*M2, NP2*N, NP2*M2, 1 ) +C where M1 = M - M2 and NP1 = NP - NP2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is +C MAX(1,Q*(Q+MAX(N,5)+1)). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix D12 had not full column rank in +C respect to the tolerance TOL; +C = 2: if the matrix D21 had not full row rank in respect +C to the tolerance TOL; +C = 3: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of D12 or +C D21). +C +C METHOD +C +C The routine performs the transformations described in [1], [2]. +C +C REFERENCES +C +C [1] Zhou, K., Doyle, J.C., and Glover, K. +C Robust and Optimal Control. +C Prentice-Hall, Upper Saddle River, NJ, 1996. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C NUMERICAL ASPECTS +C +C The precision of the transformations can be controlled by the +C condition numbers of the matrices TU and TY as given by the +C values of RCOND(1) and RCOND(2), respectively. An error return +C with INFO = 1 or INFO = 2 will be obtained if the condition +C number of TU or TY, respectively, would exceed 1/TOL. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Feb. 2000. +C +C KEYWORDS +C +C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal +C regulator, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDB, LDC, LDD, LDTU, LDTY, LDWORK, M, N, + $ NCON, NMEAS, NP + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), C( LDC, * ), D( LDD, * ), + $ DWORK( * ), RCOND( 2 ), TU( LDTU, * ), + $ TY( LDTY, * ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IQ, IWRK, J, LWAMAX, M1, M2, MINWRK, + $ ND1, ND2, NP1, NP2 + DOUBLE PRECISION TOLL +C .. +C .. External Functions + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DGESVD, DLACPY, DSCAL, DSWAP, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN + INFO = -13 + ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN + INFO = -15 + ELSE +C +C Compute workspace. +C + MINWRK = MAX( 1, M2 + NP1*NP1 + MAX( NP1*N, 3*M2 + NP1, + $ 5*M2 ), + $ NP2 + M1*M1 + MAX( M1*N, 3*NP2 + M1, 5*NP2 ), + $ N*M2, NP2*N, NP2*M2 ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -19 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10UD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + ND1 = NP1 - M2 + ND2 = M1 - NP2 + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance for condition tests. +C + TOLL = SQRT( DLAMCH( 'Epsilon' ) ) + END IF +C +C Determine SVD of D12, D12 = U12 S12 V12', and check if D12 has +C full column rank. V12' is stored in TU. +C Workspace: need M2 + NP1*NP1 + max(3*M2+NP1,5*M2); +C prefer larger. +C + IQ = M2 + 1 + IWRK = IQ + NP1*NP1 +C + CALL DGESVD( 'A', 'A', NP1, M2, D( 1, M1+1 ), LDD, DWORK, + $ DWORK( IQ ), NP1, TU, LDTU, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C + RCOND( 1 ) = DWORK( M2 )/DWORK( 1 ) + IF( RCOND( 1 ).LE.TOLL ) THEN + RCOND( 2 ) = ZERO + INFO = 1 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Determine Q12. +C + IF( ND1.GT.0 ) THEN + CALL DLACPY( 'Full', NP1, M2, DWORK( IQ ), NP1, D( 1, M1+1 ), + $ LDD ) + CALL DLACPY( 'Full', NP1, ND1, DWORK( IQ+NP1*M2 ), NP1, + $ DWORK( IQ ), NP1 ) + CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, + $ DWORK( IQ+NP1*ND1 ), NP1 ) + END IF +C +C Determine Tu by transposing in-situ and scaling. +C + DO 10 J = 1, M2 - 1 + CALL DSWAP( J, TU( J+1, 1 ), LDTU, TU( 1, J+1 ), 1 ) + 10 CONTINUE +C + DO 20 J = 1, M2 + CALL DSCAL( M2, ONE/DWORK( J ), TU( 1, J ), 1 ) + 20 CONTINUE +C +C Determine C1 =: Q12'*C1. +C Workspace: M2 + NP1*NP1 + NP1*N. +C + CALL DGEMM( 'T', 'N', NP1, N, NP1, ONE, DWORK( IQ ), NP1, C, LDC, + $ ZERO, DWORK( IWRK ), NP1 ) + CALL DLACPY( 'Full', NP1, N, DWORK( IWRK ), NP1, C, LDC ) + LWAMAX = MAX( IWRK + NP1*N - 1, LWAMAX ) +C +C Determine SVD of D21, D21 = U21 S21 V21', and check if D21 has +C full row rank. U21 is stored in TY. +C Workspace: need NP2 + M1*M1 + max(3*NP2+M1,5*NP2); +C prefer larger. +C + IQ = NP2 + 1 + IWRK = IQ + M1*M1 +C + CALL DGESVD( 'A', 'A', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, TY, + $ LDTY, DWORK( IQ ), M1, DWORK( IWRK ), LDWORK-IWRK+1, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C + RCOND( 2 ) = DWORK( NP2 )/DWORK( 1 ) + IF( RCOND( 2 ).LE.TOLL ) THEN + INFO = 2 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Determine Q21. +C + IF( ND2.GT.0 ) THEN + CALL DLACPY( 'Full', NP2, M1, DWORK( IQ ), M1, D( NP1+1, 1 ), + $ LDD ) + CALL DLACPY( 'Full', ND2, M1, DWORK( IQ+NP2 ), M1, DWORK( IQ ), + $ M1 ) + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, + $ DWORK( IQ+ND2 ), M1 ) + END IF +C +C Determine Ty by scaling and transposing in-situ. +C + DO 30 J = 1, NP2 + CALL DSCAL( NP2, ONE/DWORK( J ), TY( 1, J ), 1 ) + 30 CONTINUE +C + DO 40 J = 1, NP2 - 1 + CALL DSWAP( J, TY( J+1, 1 ), LDTY, TY( 1, J+1 ), 1 ) + 40 CONTINUE +C +C Determine B1 =: B1*Q21'. +C Workspace: NP2 + M1*M1 + N*M1. +C + CALL DGEMM( 'N', 'T', N, M1, M1, ONE, B, LDB, DWORK( IQ ), M1, + $ ZERO, DWORK( IWRK ), N ) + CALL DLACPY( 'Full', N, M1, DWORK( IWRK ), N, B, LDB ) + LWAMAX = MAX( IWRK + N*M1 - 1, LWAMAX ) +C +C Determine B2 =: B2*Tu. +C Workspace: N*M2. +C + CALL DGEMM( 'N', 'N', N, M2, M2, ONE, B( 1, M1+1 ), LDB, TU, LDTU, + $ ZERO, DWORK, N ) + CALL DLACPY( 'Full', N, M2, DWORK, N, B( 1, M1+1 ), LDB ) +C +C Determine C2 =: Ty*C2. +C Workspace: NP2*N. +C + CALL DGEMM( 'N', 'N', NP2, N, NP2, ONE, TY, LDTY, + $ C( NP1+1, 1 ), LDC, ZERO, DWORK, NP2 ) + CALL DLACPY( 'Full', NP2, N, DWORK, NP2, C( NP1+1, 1 ), LDC ) +C +C Determine D22 =: Ty*D22*Tu. +C Workspace: NP2*M2. +C + CALL DGEMM( 'N', 'N', NP2, M2, NP2, ONE, TY, LDTY, + $ D( NP1+1, M1+1 ), LDD, ZERO, DWORK, NP2 ) + CALL DGEMM( 'N', 'N', NP2, M2, M2, ONE, DWORK, NP2, TU, LDTU, + $ ZERO, D( NP1+1, M1+1 ), LDD ) +C + LWAMAX = MAX( N*MAX( M2, NP2 ), NP2*M2, LWAMAX ) + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10UD *** + END diff --git a/mex/sources/libslicot/SB10VD.f b/mex/sources/libslicot/SB10VD.f new file mode 100644 index 000000000..913a5ab29 --- /dev/null +++ b/mex/sources/libslicot/SB10VD.f @@ -0,0 +1,393 @@ + SUBROUTINE SB10VD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, + $ F, LDF, H, LDH, X, LDX, Y, LDY, XYCOND, IWORK, + $ DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the state feedback and the output injection +C matrices for an H2 optimal n-state controller for the system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | 0 D12 | | C | D | +C | C2 | D21 D22 | +C +C where B2 has as column size the number of control inputs (NCON) +C and C2 has as row size the number of measurements (NMEAS) being +C provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank with D12 = | 0 | and D21 is +C | I | +C full row rank with D21 = | 0 I | as obtained by the +C SLICOT Library routine SB10UD. Matrix D is not used +C explicitly. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C F (output) DOUBLE PRECISION array, dimension (LDF,N) +C The leading NCON-by-N part of this array contains the +C state feedback matrix F. +C +C LDF INTEGER +C The leading dimension of the array F. LDF >= max(1,NCON). +C +C H (output) DOUBLE PRECISION array, dimension (LDH,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C output injection matrix H. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array contains the matrix +C X, solution of the X-Riccati equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,N) +C The leading N-by-N part of this array contains the matrix +C Y, solution of the Y-Riccati equation. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= max(1,N). +C +C XYCOND (output) DOUBLE PRECISION array, dimension (2) +C XYCOND(1) contains an estimate of the reciprocal condition +C number of the X-Riccati equation; +C XYCOND(2) contains an estimate of the reciprocal condition +C number of the Y-Riccati equation. +C +C Workspace +C +C IWORK INTEGER array, dimension max(2*N,N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 13*N*N + 12*N + 5. +C For good performance, LDWORK must generally be larger. +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the X-Riccati equation was not solved +C successfully; +C = 2: if the Y-Riccati equation was not solved +C successfully. +C +C METHOD +C +C The routine implements the formulas given in [1], [2]. The X- +C and Y-Riccati equations are solved with condition and accuracy +C estimates [3]. +C +C REFERENCES +C +C [1] Zhou, K., Doyle, J.C., and Glover, K. +C Robust and Optimal Control. +C Prentice-Hall, Upper Saddle River, NJ, 1996. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C [3] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. +C DGRSVX and DMSRIC: Fortan 77 subroutines for solving +C continuous-time matrix algebraic Riccati equations with +C condition and accuracy estimates. +C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. +C Chemnitz, May 1998. +C +C NUMERICAL ASPECTS +C +C The precision of the solution of the matrix Riccati equations +C can be controlled by the values of the condition numbers +C XYCOND(1) and XYCOND(2) of these equations. +C +C FURTHER COMMENTS +C +C The Riccati equations are solved by the Schur approach +C implementing condition and accuracy estimates. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999. +C +C KEYWORDS +C +C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal +C regulator, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDF, LDH, LDWORK, LDX, + $ LDY, M, N, NCON, NMEAS, NP +C .. +C .. Array Arguments .. + LOGICAL BWORK( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), F( LDF, * ), H( LDH, * ), + $ X( LDX, * ), XYCOND( 2 ), Y( LDY, * ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IWG, IWI, IWQ, IWR, IWRK, IWS, IWT, IWV, + $ LWAMAX, M1, M2, MINWRK, N2, ND1, ND2, NP1, NP2 + DOUBLE PRECISION FERR, SEP +C .. +C .. External Functions .. +C + DOUBLE PRECISION DLANSY + EXTERNAL DLANSY +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASET, DSYRK, SB02RD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( LDF.LT.MAX( 1, NCON ) ) THEN + INFO = -13 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDY.LT.MAX( 1, N ) ) THEN + INFO = -19 + ELSE +C +C Compute workspace. +C + MINWRK = 13*N*N + 12*N + 5 + IF( LDWORK.LT.MINWRK ) + $ INFO = -23 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10VD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + DWORK( 1 ) = ONE + XYCOND( 1 ) = ONE + XYCOND( 2 ) = ONE + RETURN + END IF +C + ND1 = NP1 - M2 + ND2 = M1 - NP2 + N2 = 2*N +C +C Workspace usage. +C + IWQ = N*N + 1 + IWG = IWQ + N*N + IWT = IWG + N*N + IWV = IWT + N*N + IWR = IWV + N*N + IWI = IWR + N2 + IWS = IWI + N2 + IWRK = IWS + 4*N*N +C +C Compute Ax = A - B2*D12'*C1 . +C + CALL DLACPY ('Full', N, N, A, LDA, DWORK, N ) + CALL DGEMM( 'N', 'N', N, N, M2, -ONE, B( 1, M1+1 ), LDB, + $ C( ND1+1, 1), LDC, ONE, DWORK, N ) +C +C Compute Cx = C1'*C1 - C1'*D12*D12'*C1 . +C + IF( ND1.GT.0 ) THEN + CALL DSYRK( 'L', 'T', N, ND1, ONE, C, LDC, ZERO, DWORK( IWQ ), + $ N ) + ELSE + CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N ) + END IF +C +C Compute Dx = B2*B2' . +C + CALL DSYRK( 'L', 'N', N, M2, ONE, B( 1, M1+1 ), LDB, ZERO, + $ DWORK( IWG ), N ) +C +C Solution of the Riccati equation Ax'*X + X*Ax + Cx - X*Dx*X = 0 . +C Workspace: need 13*N*N + 12*N + 5; +C prefer larger. +C + CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'NoTranspose', + $ 'Lower', 'GeneralScaling', 'Stable', 'NotFactored', + $ 'Original', N, DWORK, N, DWORK( IWT ), N, + $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ X, LDX, SEP, XYCOND( 1 ), FERR, DWORK( IWR ), + $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Compute F = -D12'*C1 - B2'*X . +C + CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, F, LDF ) + CALL DGEMM( 'T', 'N', M2, N, N, -ONE, B( 1, M1+1 ), LDB, X, LDX, + $ -ONE, F, LDF ) +C +C Compute Ay = A - B1*D21'*C2 . +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) + CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, B( 1, ND2+1 ), LDB, + $ C( NP1+1, 1 ), LDC, ONE, DWORK, N ) +C +C Compute Cy = B1*B1' - B1*D21'*D21*B1' . +C + IF( ND2.GT.0 ) THEN + CALL DSYRK( 'U', 'N', N, ND2, ONE, B, LDB, ZERO, DWORK( IWQ ), + $ N ) + ELSE + CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N ) + END IF +C +C Compute Dy = C2'*C2 . +C + CALL DSYRK( 'U', 'T', N, NP2, ONE, C( NP1+1, 1 ), LDC, ZERO, + $ DWORK( IWG ), N ) +C +C Solution of the Riccati equation Ay*Y + Y*Ay' + Cy - Y*Dy*Y = 0 . +C Workspace: need 13*N*N + 12*N + 5; +C prefer larger. +C + CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'Transpose', + $ 'Upper', 'GeneralScaling', 'Stable', 'NotFactored', + $ 'Original', N, DWORK, N, DWORK( IWT ), N, + $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ Y, LDY, SEP, XYCOND( 2 ), FERR, DWORK( IWR ), + $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF +C + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute H = -B1*D21' - Y*C2' . +C + CALL DLACPY( 'Full', N, NP2, B( 1, ND2+1 ), LDB, H, LDH ) + CALL DGEMM( 'N', 'T', N, NP2, N, -ONE, Y, LDY, C( NP1+1, 1 ), LDC, + $ -ONE, H, LDH ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10VD *** + END diff --git a/mex/sources/libslicot/SB10WD.f b/mex/sources/libslicot/SB10WD.f new file mode 100644 index 000000000..e2f37b2f3 --- /dev/null +++ b/mex/sources/libslicot/SB10WD.f @@ -0,0 +1,299 @@ + SUBROUTINE SB10WD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, + $ D, LDD, F, LDF, H, LDH, TU, LDTU, TY, LDTY, + $ AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the H2 optimal controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C from the state feedback matrix F and output injection matrix H as +C determined by the SLICOT Library routine SB10VD. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0. +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0. +C M-NCON >= NMEAS. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. Only the submatrix +C B2 = B(:,M-M2+1:M) is used. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. Only the submatrix +C C2 = C(NP-NP2+1:NP,:) is used. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. Only the submatrix +C D22 = D(NP-NP2+1:NP,M-M2+1:M) is used. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C F (input) DOUBLE PRECISION array, dimension (LDF,N) +C The leading NCON-by-N part of this array must contain the +C state feedback matrix F. +C +C LDF INTEGER +C The leading dimension of the array F. LDF >= max(1,NCON). +C +C H (input) DOUBLE PRECISION array, dimension (LDH,NMEAS) +C The leading N-by-NMEAS part of this array must contain the +C output injection matrix H. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C TU (input) DOUBLE PRECISION array, dimension (LDTU,M2) +C The leading M2-by-M2 part of this array must contain the +C control transformation matrix TU, as obtained by the +C SLICOT Library routine SB10UD. +C +C LDTU INTEGER +C The leading dimension of the array TU. LDTU >= max(1,M2). +C +C TY (input) DOUBLE PRECISION array, dimension (LDTY,NP2) +C The leading NP2-by-NP2 part of this array must contain the +C measurement transformation matrix TY, as obtained by the +C SLICOT Library routine SB10UD. +C +C LDTY INTEGER +C The leading dimension of the array TY. +C LDTY >= max(1,NP2). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine implements the formulas given in [1], [2]. +C +C REFERENCES +C +C [1] Zhou, K., Doyle, J.C., and Glover, K. +C Robust and Optimal Control. +C Prentice-Hall, Upper Saddle River, NJ, 1996. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C input and output transformations. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999. +C +C KEYWORDS +C +C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal +C regulator, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDF, LDH, LDTU, LDTY, M, N, NCON, NMEAS, + $ NP +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), F( LDF, * ), + $ H( LDH, * ), TU( LDTU, * ), TY( LDTY, * ) +C .. +C .. Local Scalars .. + INTEGER M1, M2, NP1, NP2 +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASET, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -13 + ELSE IF( LDF.LT.MAX( 1, M2 ) ) THEN + INFO = -15 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN + INFO = -19 + ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN + INFO = -21 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -23 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -25 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -27 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -29 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10WD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) RETURN +C +C Compute the transpose of D22*F . BK is used as workspace. +C + CALL DGEMM( 'T', 'T', N, NP2, M2, ONE, F, LDF, D( NP1+1, M1+1 ), + $ LDD, ZERO, BK, LDBK ) +C +C Find AK = A + H*C2 + B2*F + H*D22*F . +C + CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, NP2, ONE, H, LDH, C( NP1+1, 1 ), LDC, + $ ONE, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, M2, ONE, B( 1, M1+1 ), LDB, + $ F, LDF, ONE, AK, LDAK ) + CALL DGEMM( 'N', 'T', N, N, NP2, ONE, H, LDH, BK, LDBK, ONE, AK, + $ LDAK ) +C +C Find BK = -H*Ty . +C + CALL DGEMM( 'N', 'N', N, NP2, NP2, -ONE, H, LDH, TY, LDTY, ZERO, + $ BK, LDBK ) +C +C Find CK = Tu*F . +C + CALL DGEMM( 'N', 'N', M2, N, M2, ONE, TU, LDTU, F, LDF, ZERO, CK, + $ LDCK ) +C +C Find DK . +C + CALL DLASET( 'Full', M2, NP2, ZERO, ZERO, DK, LDDK ) +C + RETURN +C *** Last line of SB10WD *** + END diff --git a/mex/sources/libslicot/SB10YD.f b/mex/sources/libslicot/SB10YD.f new file mode 100644 index 000000000..fa84e9f01 --- /dev/null +++ b/mex/sources/libslicot/SB10YD.f @@ -0,0 +1,689 @@ + SUBROUTINE SB10YD( DISCFL, FLAG, LENDAT, RFRDAT, IFRDAT, OMEGA, N, + $ A, LDA, B, C, D, TOL, IWORK, DWORK, LDWORK, + $ ZWORK, LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To fit a supplied frequency response data with a stable, minimum +C phase SISO (single-input single-output) system represented by its +C matrices A, B, C, D. It handles both discrete- and continuous-time +C cases. +C +C ARGUMENTS +C +C Input/Output parameters +C +C DISCFL (input) INTEGER +C Indicates the type of the system, as follows: +C = 0: continuous-time system; +C = 1: discrete-time system. +C +C FLAG (input) INTEGER +C If FLAG = 0, then the system zeros and poles are not +C constrained. +C If FLAG = 1, then the system zeros and poles will have +C negative real parts in the continuous-time case, or moduli +C less than 1 in the discrete-time case. Consequently, FLAG +C must be equal to 1 in mu-synthesis routines. +C +C LENDAT (input) INTEGER +C The length of the vectors RFRDAT, IFRDAT and OMEGA. +C LENDAT >= 2. +C +C RFRDAT (input) DOUBLE PRECISION array, dimension (LENDAT) +C The real part of the frequency data to be fitted. +C +C IFRDAT (input) DOUBLE PRECISION array, dimension (LENDAT) +C The imaginary part of the frequency data to be fitted. +C +C OMEGA (input) DOUBLE PRECISION array, dimension (LENDAT) +C The frequencies corresponding to RFRDAT and IFRDAT. +C These values must be nonnegative and monotonically +C increasing. Additionally, for discrete-time systems +C they must be between 0 and PI. +C +C N (input/output) INTEGER +C On entry, the desired order of the system to be fitted. +C N <= LENDAT-1. +C On exit, the order of the obtained system. The value of N +C could only be modified if N > 0 and FLAG = 1. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the +C matrix A. If FLAG = 1, then A is in an upper Hessenberg +C form, and corresponds to a minimal realization. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (output) DOUBLE PRECISION array, dimension (N) +C The computed vector B. +C +C C (output) DOUBLE PRECISION array, dimension (N) +C The computed vector C. If FLAG = 1, the first N-1 elements +C are zero (for the exit value of N). +C +C D (output) DOUBLE PRECISION array, dimension (1) +C The computed scalar D. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for determining the effective +C rank of matrices. If the user sets TOL > 0, then the given +C value of TOL is used as a lower bound for the reciprocal +C condition number; a (sub)matrix whose estimated condition +C number is less than 1/TOL is considered to be of full +C rank. If the user sets TOL <= 0, then an implicitly +C computed, default tolerance, defined by TOLDEF = SIZE*EPS, +C is used instead, where SIZE is the product of the matrix +C dimensions, and EPS is the machine precision (see LAPACK +C Library routine DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension max(2,2*N+1) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK and DWORK(2) contains the optimal value of +C LZWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = max( 2, LW1, LW2, LW3, LW4 ), where +C LW1 = 2*LENDAT + 4*HNPTS; HNPTS = 2048; +C LW2 = LENDAT + 6*HNPTS; +C MN = min( 2*LENDAT, 2*N+1 ) +C LW3 = 2*LENDAT*(2*N+1) + max( 2*LENDAT, 2*N+1 ) + +C max( MN + 6*N + 4, 2*MN + 1 ), if N > 0; +C LW3 = 4*LENDAT + 5 , if N = 0; +C LW4 = max( N*N + 5*N, 6*N + 1 + min( 1,N ) ), if FLAG = 1; +C LW4 = 0, if FLAG = 0. +C For optimum performance LDWORK should be larger. +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK = LENDAT*(2*N+3), if N > 0; +C LZWORK = LENDAT, if N = 0. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the discrete --> continuous transformation cannot +C be made; +C = 2: if the system poles cannot be found; +C = 3: if the inverse system cannot be found, i.e., D is +C (close to) zero; +C = 4: if the system zeros cannot be found; +C = 5: if the state-space representation of the new +C transfer function T(s) cannot be found; +C = 6: if the continuous --> discrete transformation cannot +C be made. +C +C METHOD +C +C First, if the given frequency data are corresponding to a +C continuous-time system, they are changed to a discrete-time +C system using a bilinear transformation with a scaled alpha. +C Then, the magnitude is obtained from the supplied data. +C Then, the frequency data are linearly interpolated around +C the unit-disc. +C Then, Oppenheim and Schafer complex cepstrum method is applied +C to get frequency data corresponding to a stable, minimum- +C phase system. This is done in the following steps: +C - Obtain LOG (magnitude) +C - Obtain IFFT of the result (DG01MD SLICOT subroutine); +C - halve the data at 0; +C - Obtain FFT of the halved data (DG01MD SLICOT subroutine); +C - Obtain EXP of the result. +C Then, the new frequency data are interpolated back to the +C original frequency. +C Then, based on these newly obtained data, the system matrices +C A, B, C, D are constructed; the very identification is +C performed by Least Squares Method using DGELSY LAPACK subroutine. +C If needed, a discrete-to-continuous time transformation is +C applied on the system matrices by AB04MD SLICOT subroutine. +C Finally, if requested, the poles and zeros of the system are +C checked. If some of them have positive real parts in the +C continuous-time case (or are not inside the unit disk in the +C complex plane in the discrete-time case), they are exchanged with +C their negatives (or reciprocals, respectively), to preserve the +C frequency response, while getting a minimum phase and stable +C system. This is done by SB10ZP SLICOT subroutine. +C +C REFERENCES +C +C [1] Oppenheim, A.V. and Schafer, R.W. +C Discrete-Time Signal Processing. +C Prentice-Hall Signal Processing Series, 1989. +C +C [2] Balas, G., Doyle, J., Glover, K., Packard, A., and Smith, R. +C Mu-analysis and Synthesis toolbox - User's Guide, +C The Mathworks Inc., Natick, MA, USA, 1998. +C +C CONTRIBUTORS +C +C Asparuh Markovski, Technical University of Sofia, July 2003. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. +C A. Markovski, Technical University of Sofia, October 2003. +C +C KEYWORDS +C +C Bilinear transformation, frequency response, least-squares +C approximation, stability. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 ZZERO, ZONE + PARAMETER ( ZZERO = ( 0.0D+0, 0.0D+0 ), + $ ZONE = ( 1.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION ZERO, ONE, TWO, FOUR, TEN + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+0, TEN = 1.0D+1 ) + INTEGER HNPTS + PARAMETER ( HNPTS = 2048 ) +C .. +C .. Scalar Arguments .. + INTEGER DISCFL, FLAG, INFO, LDA, LDWORK, LENDAT, + $ LZWORK, N + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA, *), B(*), C(*), D(*), DWORK(*), + $ IFRDAT(*), OMEGA(*), RFRDAT(*) + COMPLEX*16 ZWORK(*) +C .. +C .. Local Scalars .. + INTEGER CLWMAX, DLWMAX, I, II, INFO2, IP1, IP2, ISTART, + $ ISTOP, IWA0, IWAB, IWBMAT, IWBP, IWBX, IWDME, + $ IWDOMO, IWMAG, IWS, IWVAR, IWXI, IWXR, IWYMAG, + $ K, LW1, LW2, LW3, LW4, MN, N1, N2, P, RANK + DOUBLE PRECISION P1, P2, PI, PW, RAT, TOLB, TOLL + COMPLEX*16 XHAT(HNPTS/2) +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 +C .. +C .. External Subroutines .. + EXTERNAL AB04MD, DCOPY, DG01MD, DGELSY, DLASET, DSCAL, + $ SB10ZP, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ACOS, ATAN, COS, DBLE, DCMPLX, DIMAG, EXP, LOG, + $ MAX, MIN, SIN, SQRT +C +C Test input parameters and workspace. +C + PI = FOUR*ATAN( ONE ) + PW = OMEGA(1) + N1 = N + 1 + N2 = N + N1 +C + INFO = 0 + IF( DISCFL.NE.0 .AND. DISCFL.NE.1 ) THEN + INFO = -1 + ELSE IF( FLAG.NE.0 .AND. FLAG.NE.1 ) THEN + INFO = -2 + ELSE IF ( LENDAT.LT.2 ) THEN + INFO = -3 + ELSE IF ( PW.LT.ZERO ) THEN + INFO = -6 + ELSE IF( N.GT.LENDAT - 1 ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE +C + DO 10 K = 2, LENDAT + IF ( OMEGA(K).LT.PW ) + $ INFO = -6 + PW = OMEGA(K) + 10 CONTINUE +C + IF ( DISCFL.EQ.1 .AND. OMEGA(LENDAT).GT.PI ) + $ INFO = -6 + END IF +C + IF ( INFO.EQ.0 ) THEN +C +C Workspace. +C + LW1 = 2*LENDAT + 4*HNPTS + LW2 = LENDAT + 6*HNPTS + MN = MIN( 2*LENDAT, N2 ) +C + IF ( N.GT.0 ) THEN + LW3 = 2*LENDAT*N2 + MAX( 2*LENDAT, N2 ) + + $ MAX( MN + 6*N + 4, 2*MN + 1 ) + ELSE + LW3 = 4*LENDAT + 5 + END IF +C + IF ( FLAG.EQ.0 ) THEN + LW4 = 0 + ELSE + LW4 = MAX( N*N + 5*N, 6*N + 1 + MIN ( 1, N ) ) + END IF +C + DLWMAX = MAX( 2, LW1, LW2, LW3, LW4 ) +C + IF ( N.GT.0 ) THEN + CLWMAX = LENDAT*( N2 + 2 ) + ELSE + CLWMAX = LENDAT + END IF +C + IF ( LDWORK.LT.DLWMAX ) THEN + INFO = -16 + ELSE IF ( LZWORK.LT.CLWMAX ) THEN + INFO = -18 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB10YD', -INFO ) + RETURN + END IF +C +C Set tolerances. +C + TOLB = DLAMCH( 'Epsilon' ) + TOLL = TOL + IF ( TOLL.LE.ZERO ) + $ TOLL = FOUR*DBLE( LENDAT*N )*TOLB +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C +C Workspace usage 1. +C Workspace: need 2*LENDAT + 4*HNPTS. +C + IWDOMO = 1 + IWDME = IWDOMO + LENDAT + IWYMAG = IWDME + 2*HNPTS + IWMAG = IWYMAG + 2*HNPTS +C +C Bilinear transformation. +C + IF ( DISCFL.EQ.0 ) THEN + PW = SQRT( OMEGA(1)*OMEGA(LENDAT) + SQRT( TOLB ) ) +C + DO 20 K = 1, LENDAT + DWORK(IWDME+K-1) = ( OMEGA(K)/PW )**2 + DWORK(IWDOMO+K-1) = + $ ACOS( ( ONE - DWORK(IWDME+K-1) )/ + $ ( ONE + DWORK(IWDME+K-1) ) ) + 20 CONTINUE +C + ELSE + CALL DCOPY( LENDAT, OMEGA, 1, DWORK(IWDOMO), 1 ) + END IF +C +C Linear interpolation. +C + DO 30 K = 1, LENDAT + DWORK(IWMAG+K-1) = DLAPY2( RFRDAT(K), IFRDAT(K) ) + DWORK(IWMAG+K-1) = ( ONE/LOG( TEN ) ) * LOG( DWORK(IWMAG+K-1) ) + 30 CONTINUE +C + DO 40 K = 1, HNPTS + DWORK(IWDME+K-1) = ( K - 1 )*PI/HNPTS + DWORK(IWYMAG+K-1) = ZERO +C + IF ( DWORK(IWDME+K-1).LT.DWORK(IWDOMO) ) THEN + DWORK(IWYMAG+K-1) = DWORK(IWMAG) + ELSE IF ( DWORK(IWDME+K-1).GE.DWORK(IWDOMO+LENDAT-1) ) THEN + DWORK(IWYMAG+K-1) = DWORK(IWMAG+LENDAT-1) + END IF +C + 40 CONTINUE +C + DO 60 I = 2, LENDAT + P1 = HNPTS*DWORK(IWDOMO+I-2)/PI + ONE +C + IP1 = INT( P1 ) + IF ( DBLE( IP1 ).NE.P1 ) + $ IP1 = IP1 + 1 +C + P2 = HNPTS*DWORK(IWDOMO+I-1)/PI + ONE +C + IP2 = INT( P2 ) + IF ( DBLE( IP2 ).NE.P2 ) + $ IP2 = IP2 + 1 +C + DO 50 P = IP1, IP2 - 1 + RAT = DWORK(IWDME+P-1) - DWORK(IWDOMO+I-2) + RAT = RAT/( DWORK(IWDOMO+I-1) - DWORK(IWDOMO+I-2) ) + DWORK(IWYMAG+P-1) = ( ONE - RAT )*DWORK(IWMAG+I-2) + + $ RAT*DWORK(IWMAG+I-1) + 50 CONTINUE +C + 60 CONTINUE +C + DO 70 K = 1, HNPTS + DWORK(IWYMAG+K-1) = EXP( LOG( TEN )*DWORK(IWYMAG+K-1) ) + 70 CONTINUE +C +C Duplicate data around disc. +C + DO 80 K = 1, HNPTS + DWORK(IWDME+HNPTS+K-1) = TWO*PI - DWORK(IWDME+HNPTS-K) + DWORK(IWYMAG+HNPTS+K-1) = DWORK(IWYMAG+HNPTS-K) + 80 CONTINUE +C +C Complex cepstrum to get min phase: +C LOG (Magnitude) +C + DO 90 K = 1, 2*HNPTS + DWORK(IWYMAG+K-1) = TWO*LOG( DWORK(IWYMAG+K-1) ) + 90 CONTINUE +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C +C Workspace usage 2. +C Workspace: need LENDAT + 6*HNPTS. +C + IWXR = IWYMAG + IWXI = IWMAG +C + DO 100 K = 1, 2*HNPTS + DWORK(IWXI+K-1) = ZERO + 100 CONTINUE +C +C IFFT +C + CALL DG01MD( 'I', 2*HNPTS, DWORK(IWXR), DWORK(IWXI), INFO2 ) +C +C Rescale, because DG01MD doesn't do it. +C + CALL DSCAL( HNPTS, ONE/( TWO*HNPTS ), DWORK(IWXR), 1 ) + CALL DSCAL( HNPTS, ONE/( TWO*HNPTS ), DWORK(IWXI), 1 ) +C +C Halve the result at 0. +C + DWORK(IWXR) = DWORK(IWXR)/TWO + DWORK(IWXI) = DWORK(IWXI)/TWO +C +C FFT +C + CALL DG01MD( 'D', HNPTS, DWORK(IWXR), DWORK(IWXI), INFO2 ) +C +C Get the EXP of the result. +C + DO 110 K = 1, HNPTS/2 + XHAT(K) = EXP( DWORK(IWXR+K-1) )* + $ DCMPLX ( COS( DWORK(IWXI+K-1)), SIN( DWORK(IWXI+K-1) ) ) + DWORK(IWDME+K-1) = DWORK(IWDME+2*K-2) + 110 CONTINUE +C +C Interpolate back to original frequency data. +C + ISTART = 1 + ISTOP = LENDAT +C + DO 120 I = 1, LENDAT + ZWORK(I) = ZZERO + IF ( DWORK(IWDOMO+I-1).LE.DWORK(IWDME) ) THEN + ZWORK(I) = XHAT(1) + ISTART = I + 1 + ELSE IF ( DWORK(IWDOMO+I-1).GE.DWORK(IWDME+HNPTS/2-1) ) + $ THEN + ZWORK(I) = XHAT(HNPTS/2) + ISTOP = ISTOP - 1 + END IF + 120 CONTINUE +C + DO 140 I = ISTART, ISTOP + II = HNPTS/2 + 130 CONTINUE + IF ( DWORK(IWDME+II-1).GE.DWORK(IWDOMO+I-1) ) + $ P = II + II = II - 1 + IF ( II.GT.0 ) + $ GOTO 130 + RAT = ( DWORK(IWDOMO+I-1) - DWORK(IWDME+P-2) )/ + $ ( DWORK(IWDME+P-1) - DWORK(IWDME+P-2) ) + ZWORK(I) = RAT*XHAT(P) + ( ONE - RAT )*XHAT(P-1) + 140 CONTINUE +C +C CASE N > 0. +C This is the only allowed case in mu-synthesis subroutines. +C + IF ( N.GT.0 ) THEN +C +C Preparation for frequency identification. +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C +C Complex workspace usage 1. +C Complex workspace: need 2*LENDAT + LENDAT*(N+1). +C + IWA0 = 1 + LENDAT + IWVAR = IWA0 + LENDAT*N1 +C + DO 150 K = 1, LENDAT + IF ( DISCFL.EQ.0 ) THEN + ZWORK(IWVAR+K-1) = DCMPLX( COS( DWORK(IWDOMO+K-1) ), + $ SIN( DWORK(IWDOMO+K-1) ) ) + ELSE + ZWORK(IWVAR+K-1) = DCMPLX( COS( OMEGA(K) ), + $ SIN( OMEGA(K) ) ) + END IF + 150 CONTINUE +C +C Array for DGELSY. +C + DO 160 K = 1, N2 + IWORK(K) = 0 + 160 CONTINUE +C +C Constructing A0. +C + DO 170 K = 1, LENDAT + ZWORK(IWA0+N*LENDAT+K-1) = ZONE + 170 CONTINUE +C + DO 190 I = 1, N + DO 180 K = 1, LENDAT + ZWORK(IWA0+(N-I)*LENDAT+K-1) = + $ ZWORK(IWA0+(N1-I)*LENDAT+K-1)*ZWORK(IWVAR+K-1) + 180 CONTINUE + 190 CONTINUE +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C +C Complex workspace usage 2. +C Complex workspace: need 2*LENDAT + LENDAT*(2*N+1). +C + IWBP = IWVAR + IWAB = IWBP + LENDAT +C +C Constructing BP. +C + DO 200 K = 1, LENDAT + ZWORK(IWBP+K-1) = ZWORK(IWA0+K-1)*ZWORK(K) + 200 CONTINUE +C +C Constructing AB. +C + DO 220 I = 1, N + DO 210 K = 1, LENDAT + ZWORK(IWAB+(I-1)*LENDAT+K-1) = -ZWORK(K)* + $ ZWORK(IWA0+I*LENDAT+K-1) + 210 CONTINUE + 220 CONTINUE +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C +C Workspace usage 3. +C Workspace: need LW3 = 2*LENDAT*(2*N+1) + max(2*LENDAT,2*N+1). +C + IWBX = 1 + 2*LENDAT*N2 + IWS = IWBX + MAX( 2*LENDAT, N2 ) +C +C Constructing AX. +C + DO 240 I = 1, N1 + DO 230 K = 1, LENDAT + DWORK(2*(I-1)*LENDAT+K) = + $ DBLE( ZWORK(IWA0+(I-1)*LENDAT+K-1) ) + DWORK((2*I-1)*LENDAT+K) = + $ DIMAG( ZWORK(IWA0+(I-1)*LENDAT+K-1) ) + 230 CONTINUE + 240 CONTINUE +C + DO 260 I = 1, N + DO 250 K = 1, LENDAT + DWORK(2*N1*LENDAT+2*(I-1)*LENDAT+K) = + $ DBLE( ZWORK(IWAB+(I-1)*LENDAT+K-1) ) + DWORK(2*N1*LENDAT+(2*I-1)*LENDAT+K) = + $ DIMAG( ZWORK(IWAB+(I-1)*LENDAT+K-1) ) + 250 CONTINUE + 260 CONTINUE +C +C Constructing BX. +C + DO 270 K = 1, LENDAT + DWORK(IWBX+K-1) = DBLE( ZWORK(IWBP+K-1) ) + DWORK(IWBX+LENDAT+K-1) = DIMAG( ZWORK(IWBP+K-1) ) + 270 CONTINUE +C +C Estimating X. +C Workspace: need LW3 + max( MN+3*(2*N+1)+1, 2*MN+1 ), +C where MN = min( 2*LENDAT, 2*N+1 ); +C prefer larger. +C + CALL DGELSY( 2*LENDAT, N2, 1, DWORK, 2*LENDAT, DWORK(IWBX), + $ MAX( 2*LENDAT, N2 ), IWORK, TOLL, RANK, + $ DWORK(IWS), LDWORK-IWS+1, INFO2 ) + DLWMAX = MAX( DLWMAX, INT( DWORK(IWS) + IWS - 1 ) ) +C +C Constructing A matrix. +C + DO 280 K = 1, N + A(K,1) = -DWORK(IWBX+N1+K-1) + 280 CONTINUE +C + IF ( N.GT.1 ) + $ CALL DLASET( 'Full', N, N-1, ZERO, ONE, A(1,2), LDA ) +C +C Constructing B matrix. +C + DO 290 K = 1, N + B(K) = DWORK(IWBX+N1+K-1)*DWORK(IWBX) - DWORK(IWBX+K) + 290 CONTINUE +C +C Constructing C matrix. +C + C(1) = -ONE +C + DO 300 K = 2, N + C(K) = ZERO + 300 CONTINUE +C +C Constructing D matrix. +C + D(1) = DWORK(IWBX) +C +C Transform to continuous-time case, if needed. +C Workspace: need max(1,N); +C prefer larger. +C + IF ( DISCFL.EQ.0 ) THEN + CALL AB04MD( 'D', N, 1, 1, ONE, PW, A, LDA, B, LDA, C, 1, + $ D, 1, IWORK, DWORK, LDWORK, INFO2 ) + IF ( INFO2.NE.0 ) THEN + INFO = 1 + RETURN + END IF + DLWMAX = MAX( DLWMAX, INT( DWORK(1) ) ) + END IF +C +C Make all the real parts of the poles and the zeros negative. +C + IF ( FLAG.EQ.1 ) THEN +C +C Workspace: need max(N*N + 5*N, 6*N + 1 + min(1,N)); +C prefer larger. + CALL SB10ZP( DISCFL, N, A, LDA, B, C, D, IWORK, DWORK, + $ LDWORK, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + DLWMAX = MAX( DLWMAX, INT( DWORK(1) ) ) + END IF +C + ELSE +C +C CASE N = 0. +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C +C Workspace usage 4. +C Workspace: need 4*LENDAT. +C + IWBMAT = 1 + 2*LENDAT + IWS = IWBMAT + 2*LENDAT +C +C Constructing AMAT and BMAT. +C + DO 310 K = 1, LENDAT + DWORK(K) = ONE + DWORK(K+LENDAT) = ZERO + DWORK(IWBMAT+K-1) = DBLE( ZWORK(K) ) + DWORK(IWBMAT+LENDAT+K-1) = DIMAG( ZWORK(K) ) + 310 CONTINUE +C +C Estimating D matrix. +C Workspace: need 4*LENDAT + 5; +C prefer larger. +C + IWORK(1) = 0 + CALL DGELSY( 2*LENDAT, 1, 1, DWORK, 2*LENDAT, DWORK(IWBMAT), + $ 2*LENDAT, IWORK, TOLL, RANK, DWORK(IWS), + $ LDWORK-IWS+1, INFO2 ) + DLWMAX = MAX( DLWMAX, INT( DWORK(IWS) + IWS - 1 ) ) +C + D(1) = DWORK(IWBMAT) +C + END IF +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C + DWORK(1) = DLWMAX + DWORK(2) = CLWMAX + RETURN +C +C *** Last line of SB10YD *** + END diff --git a/mex/sources/libslicot/SB10ZD.f b/mex/sources/libslicot/SB10ZD.f new file mode 100644 index 000000000..f70c834dd --- /dev/null +++ b/mex/sources/libslicot/SB10ZD.f @@ -0,0 +1,914 @@ + SUBROUTINE SB10ZD( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, + $ FACTOR, AK, LDAK, BK, LDBK, CK, LDCK, DK, + $ LDDK, RCOND, TOL, IWORK, DWORK, LDWORK, BWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the positive feedback controller +C +C | Ak | Bk | +C K = |----|----| +C | Ck | Dk | +C +C for the shaped plant +C +C | A | B | +C G = |---|---| +C | C | D | +C +C in the Discrete-Time Loop Shaping Design Procedure. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the plant. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A of the shaped plant. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B of the shaped plant. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C of the shaped plant. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D of the shaped plant. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C FACTOR (input) DOUBLE PRECISION +C = 1 implies that an optimal controller is required +C (not recommended); +C > 1 implies that a suboptimal controller is required +C achieving a performance FACTOR less than optimal. +C FACTOR >= 1. +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix Ak. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NP) +C The leading N-by-NP part of this array contains the +C controller input matrix Bk. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading M-by-N part of this array contains the +C controller output matrix Ck. +C +C LDCK INTEGER +C The leading dimension of the array CK. LDCK >= max(1,M). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NP) +C The leading M-by-NP part of this array contains the +C controller matrix Dk. +C +C LDDK INTEGER +C The leading dimension of the array DK. LDDK >= max(1,M). +C +C RCOND (output) DOUBLE PRECISION array, dimension (6) +C RCOND(1) contains an estimate of the reciprocal condition +C number of the linear system of equations from +C which the solution of the P-Riccati equation is +C obtained; +C RCOND(2) contains an estimate of the reciprocal condition +C number of the linear system of equations from +C which the solution of the Q-Riccati equation is +C obtained; +C RCOND(3) contains an estimate of the reciprocal condition +C number of the matrix (gamma^2-1)*In - P*Q; +C RCOND(4) contains an estimate of the reciprocal condition +C number of the matrix Rx + Bx'*X*Bx; +C RCOND(5) contains an estimate of the reciprocal condition +C ^ +C number of the matrix Ip + D*Dk; +C RCOND(6) contains an estimate of the reciprocal condition +C ^ +C number of the matrix Im + Dk*D. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used for checking the nonsingularity of the +C matrices to be inverted. If TOL <= 0, then a default value +C equal to sqrt(EPS) is used, where EPS is the relative +C machine precision. TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension 2*max(N,M+NP) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 16*N*N + 5*M*M + 7*NP*NP + 6*M*N + 7*M*NP + +C 7*N*NP + 6*N + 2*(M + NP) + +C max(14*N+23,16*N,2*M-1,2*NP-1). +C For good performance, LDWORK must generally be larger. +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO (output) INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the P-Riccati equation is not solved successfully; +C = 2: the Q-Riccati equation is not solved successfully; +C = 3: the iteration to compute eigenvalues or singular +C values failed to converge; +C = 4: the matrix (gamma^2-1)*In - P*Q is singular; +C = 5: the matrix Rx + Bx'*X*Bx is singular; +C ^ +C = 6: the matrix Ip + D*Dk is singular; +C ^ +C = 7: the matrix Im + Dk*D is singular; +C = 8: the matrix Ip - D*Dk is singular; +C = 9: the matrix Im - Dk*D is singular; +C = 10: the closed-loop system is unstable. +C +C METHOD +C +C The routine implements the formulas given in [1]. +C +C REFERENCES +C +C [1] Gu, D.-W., Petkov, P.H., and Konstantinov, M.M. +C On discrete H-infinity loop shaping design procedure routines. +C Technical Report 00-6, Dept. of Engineering, Univ. of +C Leicester, UK, 2000. +C +C NUMERICAL ASPECTS +C +C The accuracy of the results depends on the conditioning of the +C two Riccati equations solved in the controller design. For +C better conditioning it is advised to take FACTOR > 1. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 2001. +C +C KEYWORDS +C +C H_infinity control, Loop-shaping design, Robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, M, N, NP + DOUBLE PRECISION FACTOR, TOL +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + LOGICAL BWORK( * ) + DOUBLE PRECISION A ( LDA, * ), AK( LDAK, * ), B ( LDB, * ), + $ BK( LDBK, * ), C ( LDC, * ), CK( LDCK, * ), + $ D ( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( 6 ) +C .. +C .. Local Scalars .. + INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, + $ I11, I12, I13, I14, I15, I16, I17, I18, I19, + $ I20, I21, I22, I23, I24, I25, I26, INFO2, IWRK, + $ J, LWAMAX, MINWRK, N2, NS, SDIM + DOUBLE PRECISION ANORM, GAMMA, TOLL +C .. +C .. External Functions .. + LOGICAL SELECT + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY, DLAPY2 + EXTERNAL DLAMCH, DLANGE, DLANSY, DLAPY2, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DGECON, DGEES, DGEMM, DGETRF, DGETRS, + $ DLACPY, DLASCL, DLASET, DPOTRF, DPOTRS, DSWAP, + $ DSYCON, DSYEV, DSYRK, DSYTRF, DSYTRS, DTRSM, + $ DTRTRS, MA02AD, MB01RX, MB02VD, SB02OD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( FACTOR.LT.ONE ) THEN + INFO = -12 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDCK.LT.MAX( 1, M ) ) THEN + INFO = -18 + ELSE IF( LDDK.LT.MAX( 1, M ) ) THEN + INFO = -20 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -22 + END IF +C +C Compute workspace. +C + MINWRK = 16*N*N + 5*M*M + 7*NP*NP + 6*M*N + 7*M*NP + 7*N*NP + + $ 6*N + 2*(M + NP) + MAX( 14*N+23, 16*N, 2*M-1, 2*NP-1 ) + IF( LDWORK.LT.MINWRK ) THEN + INFO = -25 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10ZD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C Note that some computation could be made if one or two of the +C dimension parameters N, M, and P are zero, but the results are +C not so meaningful. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + RCOND( 5 ) = ONE + RCOND( 6 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C +C Set the default tolerance, if needed. +C + IF( TOL.LE.ZERO ) THEN + TOLL = SQRT( DLAMCH( 'Epsilon' ) ) + ELSE + TOLL = TOL + END IF +C +C Workspace usage. +C + N2 = 2*N + I1 = 1 + N*N + I2 = I1 + N*N + I3 = I2 + NP*NP + I4 = I3 + M*M + I5 = I4 + NP*NP + I6 = I5 + M*M + I7 = I6 + M*N + I8 = I7 + M*N + I9 = I8 + N*N + I10 = I9 + N*N + I11 = I10 + N2 + I12 = I11 + N2 + I13 = I12 + N2 + I14 = I13 + N2*N2 + I15 = I14 + N2*N2 +C + IWRK = I15 + N2*N2 + LWAMAX = 0 +C +C Compute R1 = Ip + D*D' . +C + CALL DLASET( 'U', NP, NP, ZERO, ONE, DWORK( I2 ), NP ) + CALL DSYRK( 'U', 'N', NP, M, ONE, D, LDD, ONE, DWORK( I2 ), NP ) + CALL DLACPY( 'U', NP, NP, DWORK( I2 ), NP, DWORK( I4 ), NP ) +C +C Factorize R1 = R'*R . +C + CALL DPOTRF( 'U', NP, DWORK( I4 ), NP, INFO2 ) +C -1 +C Compute C'*R in BK . +C + CALL MA02AD( 'F', NP, N, C, LDC, BK, LDBK ) + CALL DTRSM( 'R', 'U', 'N', 'N', N, NP, ONE, DWORK( I4 ), NP, BK, + $ LDBK ) +C +C Compute R2 = Im + D'*D . +C + CALL DLASET( 'U', M, M, ZERO, ONE, DWORK( I3 ), M ) + CALL DSYRK( 'U', 'T', M, NP, ONE, D, LDD, ONE, DWORK( I3 ), M ) + CALL DLACPY( 'U', M, M, DWORK( I3 ), M, DWORK( I5 ), M ) +C +C Factorize R2 = U'*U . +C + CALL DPOTRF( 'U', M, DWORK( I5 ), M, INFO2 ) +C -1 +C Compute (U )'*B' . +C + CALL MA02AD( 'F', N, M, B, LDB, DWORK( I6 ), M ) + CALL DTRTRS( 'U', 'T', 'N', M, N, DWORK( I5 ), M, DWORK( I6 ), M, + $ INFO2 ) +C +C Compute D'*C . +C + CALL DGEMM( 'T', 'N', M, N, NP, ONE, D, LDD, C, LDC, ZERO, + $ DWORK( I7 ), M ) +C -1 +C Compute (U )'*D'*C . +C + CALL DTRTRS( 'U', 'T', 'N', M, N, DWORK( I5 ), M, DWORK( I7 ), M, + $ INFO2 ) +C -1 +C Compute Ar = A - B*R2 D'*C . +C + CALL DLACPY( 'F', N, N, A, LDA, DWORK( I8 ), N ) + CALL DGEMM( 'T', 'N', N, N, M, -ONE, DWORK( I6 ), M, DWORK( I7 ), + $ M, ONE, DWORK( I8 ), N ) +C -1 +C Compute Cr = C'*R1 *C . +C + CALL DSYRK( 'U', 'N', N, NP, ONE, BK, LDBK, ZERO, DWORK( I9 ), N ) +C -1 +C Compute Dr = B*R2 B' in AK . +C + CALL DSYRK( 'U', 'T', N, M, ONE, DWORK( I6 ), M, ZERO, AK, LDAK ) +C -1 +C Solution of the Riccati equation Ar'*P*(In + Dr*P) Ar - P + +C Cr = 0 . + CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, DWORK( I8 ), + $ N, AK, LDAK, DWORK( I9 ), N, DWORK, M, DWORK, N, + $ RCOND( 1 ), DWORK, N, DWORK( I10 ), DWORK( I11 ), + $ DWORK( I12 ), DWORK( I13 ), N2, DWORK( I14 ), N2, + $ DWORK( I15 ), N2, -ONE, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) +C +C Transpose Ar . +C + DO 10 J = 1, N - 1 + CALL DSWAP( J, DWORK( I8+J ), N, DWORK( I8+J*N ), 1 ) + 10 CONTINUE +C -1 +C Solution of the Riccati equation Ar*Q*(In + Cr*Q) *Ar' - Q + +C Dr = 0 . + CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, DWORK( I8 ), + $ N, DWORK( I9 ), N, AK, LDAK, DWORK, M, DWORK, N, + $ RCOND( 2 ), DWORK( I1 ), N, DWORK( I10 ), + $ DWORK( I11 ), DWORK( I12 ), DWORK( I13 ), N2, + $ DWORK( I14 ), N2, DWORK( I15 ), N2, -ONE, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 2 + RETURN + END IF + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) +C +C Compute gamma. +C + CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I1 ), N, DWORK, N, + $ ZERO, DWORK( I8 ), N ) + CALL DGEES( 'N', 'N', SELECT, N, DWORK( I8 ), N, SDIM, + $ DWORK( I10 ), DWORK( I11 ), DWORK( IWRK ), N, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) + GAMMA = ZERO +C + DO 20 I = 0, N - 1 + GAMMA = MAX( GAMMA, DWORK( I10+I ) ) + 20 CONTINUE +C + GAMMA = FACTOR*SQRT( ONE + GAMMA ) +C +C Workspace usage. +C + I5 = I4 + NP*NP + I6 = I5 + M*M + I7 = I6 + NP*NP + I8 = I7 + NP*NP + I9 = I8 + NP*NP + I10 = I9 + NP + I11 = I10 + NP*NP + I12 = I11 + M*M + I13 = I12 + M +C + IWRK = I13 + M*M +C +C Compute the eigenvalues and eigenvectors of R1 . +C + CALL DLACPY( 'U', NP, NP, DWORK( I2 ), NP, DWORK( I8 ), NP ) + CALL DSYEV( 'V', 'U', NP, DWORK( I8 ), NP, DWORK( I9 ), + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) +C -1/2 +C Compute R1 . +C + DO 40 J = 1, NP + DO 30 I = 1, NP + DWORK( I10-1+I+(J-1)*NP ) = DWORK( I8-1+J+(I-1)*NP ) / + $ SQRT( DWORK( I9+I-1 ) ) + 30 CONTINUE + 40 CONTINUE +C + CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I8 ), NP, + $ DWORK( I10 ), NP, ZERO, DWORK( I4 ), NP ) +C +C Compute the eigenvalues and eigenvectors of R2 . +C + CALL DLACPY( 'U', M, M, DWORK( I3 ), M, DWORK( I11 ), M ) + CALL DSYEV( 'V', 'U', M, DWORK( I11 ), M, DWORK( I12 ), + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) +C -1/2 +C Compute R2 . +C + DO 60 J = 1, M + DO 50 I = 1, M + DWORK( I13-1+I+(J-1)*M ) = DWORK( I11-1+J+(I-1)*M ) / + $ SQRT( DWORK( I12+I-1 ) ) + 50 CONTINUE + 60 CONTINUE +C + CALL DGEMM( 'N', 'N', M, M, M, ONE, DWORK( I11 ), M, DWORK( I13 ), + $ M, ZERO, DWORK( I5 ), M ) +C +C Compute R1 + C*Q*C' . +C + CALL DGEMM( 'N', 'T', N, NP, N, ONE, DWORK( I1 ), N, C, LDC, + $ ZERO, BK, LDBK ) + CALL MB01RX( 'L', 'U', 'N', NP, N, ONE, ONE, DWORK( I2 ), NP, + $ C, LDC, BK, LDBK, INFO2 ) + CALL DLACPY( 'U', NP, NP, DWORK( I2 ), NP, DWORK( I8 ), NP ) +C +C Compute the eigenvalues and eigenvectors of R1 + C*Q*C' . +C + CALL DSYEV( 'V', 'U', NP, DWORK( I8 ), NP, DWORK( I9 ), + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) +C -1 +C Compute ( R1 + C*Q*C' ) . +C + DO 80 J = 1, NP + DO 70 I = 1, NP + DWORK( I10-1+I+(J-1)*NP ) = DWORK( I8-1+J+(I-1)*NP ) / + $ DWORK( I9+I-1 ) + 70 CONTINUE + 80 CONTINUE +C + CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I8 ), NP, + $ DWORK( I10 ), NP, ZERO, DWORK( I6 ), NP ) +C -1 +C Compute Z2 . +C + DO 100 J = 1, NP + DO 90 I = 1, NP + DWORK( I10-1+I+(J-1)*NP ) = DWORK( I8-1+J+(I-1)*NP )* + $ SQRT( DWORK( I9+I-1 ) ) + 90 CONTINUE + 100 CONTINUE +C + CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I8 ), NP, + $ DWORK( I10 ), NP, ZERO, DWORK( I7 ), NP ) +C +C Workspace usage. +C + I9 = I8 + N*NP + I10 = I9 + N*NP + I11 = I10 + NP*M + I12 = I11 + ( NP + M )*( NP + M ) + I13 = I12 + N*( NP + M ) + I14 = I13 + N*( NP + M ) + I15 = I14 + N*N + I16 = I15 + N*N + I17 = I16 + ( NP + M )*N + I18 = I17 + ( NP + M )*( NP + M ) + I19 = I18 + ( NP + M )*N + I20 = I19 + M*N + I21 = I20 + M*NP + I22 = I21 + NP*N + I23 = I22 + N*N + I24 = I23 + N*NP + I25 = I24 + NP*NP + I26 = I25 + M*M +C + IWRK = I26 + N*M +C +C Compute A*Q*C' + B*D' . +C + CALL DGEMM( 'N', 'T', N, NP, M, ONE, B, LDB, D, LDD, ZERO, + $ DWORK( I8 ), N ) + CALL DGEMM( 'N', 'N', N, NP, N, ONE, A, LDA, BK, LDBK, + $ ONE, DWORK( I8 ), N ) +C -1 +C Compute H = -( A*Q*C'+B*D' )*( R1 + C*Q*C' ) . +C + CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I8 ), N, + $ DWORK( I6 ), NP, ZERO, DWORK( I9 ), N ) +C -1/2 +C Compute R1 D . +C + CALL DGEMM( 'N', 'N', NP, M, NP, ONE, DWORK( I4 ), NP, D, LDD, + $ ZERO, DWORK( I10 ), NP ) +C +C Compute Rx . +C + DO 110 J = 1, NP + CALL DCOPY( J, DWORK( I2+(J-1)*NP ), 1, + $ DWORK( I11+(J-1)*(NP+M) ), 1 ) + DWORK( I11-1+J+(J-1)*(NP+M) ) = DWORK( I2-1+J+(J-1)*NP ) - + $ GAMMA*GAMMA + 110 CONTINUE +C + CALL DGEMM( 'N', 'N', NP, M, NP, ONE, DWORK( I7 ), NP, + $ DWORK( I10 ), NP, ZERO, DWORK( I11+(NP+M)*NP ), + $ NP+M ) + CALL DLASET( 'U', M, M, ZERO, ONE, DWORK( I11+(NP+M)*NP+NP ), + $ NP+M ) +C +C Compute Bx . +C + CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I9 ), N, + $ DWORK( I7 ), NP, ZERO, DWORK( I12 ), N ) + CALL DGEMM( 'N', 'N', N, M, M, ONE, B, LDB, DWORK( I5 ), M, + $ ZERO, DWORK( I12+N*NP ), N ) +C +C Compute Sx . +C + CALL DGEMM( 'T', 'N', N, NP, NP, ONE, C, LDC, DWORK( I7 ), NP, + $ ZERO, DWORK( I13 ), N ) + CALL DGEMM( 'T', 'N', N, M, NP, ONE, C, LDC, DWORK( I10 ), NP, + $ ZERO, DWORK( I13+N*NP ), N ) +C +C Compute (gamma^2 - 1)*In - P*Q . +C + CALL DLASET( 'F', N, N, ZERO, GAMMA*GAMMA-ONE, DWORK( I14 ), N ) + CALL DGEMM( 'N', 'N', N, N, N, -ONE, DWORK, N, DWORK( I1 ), N, + $ ONE, DWORK( I14 ), N ) +C -1 +C Compute X = ((gamma^2 - 1)*In - P*Q) *gamma^2*P . +C + CALL DLACPY( 'F', N, N, DWORK, N, DWORK( I15 ), N ) + CALL DLASCL( 'G', 0, 0, ONE, GAMMA*GAMMA, N, N, DWORK( I15 ), N, + $ INFO ) + ANORM = DLANGE( '1', N, N, DWORK( I14 ), N, DWORK( IWRK ) ) + CALL DGETRF( N, N, DWORK( I14 ), N, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 4 + RETURN + END IF + CALL DGECON( '1', N, DWORK( I14 ), N, ANORM, RCOND( 3 ), + $ DWORK( IWRK ), IWORK( N+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 3 ).LT.TOLL ) THEN + INFO = 4 + RETURN + END IF + CALL DGETRS( 'N', N, N, DWORK( I14 ), N, IWORK, DWORK( I15 ), + $ N, INFO2 ) +C +C Compute Bx'*X . +C + CALL DGEMM( 'T', 'N', NP+M, N, N, ONE, DWORK( I12 ), N, + $ DWORK( I15 ), N, ZERO, DWORK( I16 ), NP+M ) +C +C Compute Rx + Bx'*X*Bx . +C + CALL DLACPY( 'U', NP+M, NP+M, DWORK( I11 ), NP+M, DWORK( I17 ), + $ NP+M ) + CALL MB01RX( 'L', 'U', 'N', NP+M, N, ONE, ONE, DWORK( I17 ), NP+M, + $ DWORK( I16 ), NP+M, DWORK( I12 ), N, INFO2 ) +C +C Compute -( Sx' + Bx'*X*A ) . +C + CALL MA02AD( 'F', N, NP+M, DWORK( I13 ), N, DWORK( I18 ), NP+M ) + CALL DGEMM( 'N', 'N', NP+M, N, N, -ONE, DWORK( I16 ), NP+M, + $ A, LDA, -ONE, DWORK( I18 ), NP+M ) +C +C Factorize Rx + Bx'*X*Bx . +C + ANORM = DLANSY( '1', 'U', NP+M, DWORK( I17 ), NP+M, + $ DWORK( IWRK ) ) + CALL DSYTRF( 'U', NP+M, DWORK( I17 ), NP+M, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF + CALL DSYCON( 'U', NP+M, DWORK( I17 ), NP+M, IWORK, ANORM, + $ RCOND( 4 ), DWORK( IWRK ), IWORK( NP+M+1), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 4 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C -1 +C Compute F = -( Rx + Bx'*X*Bx ) ( Sx' + Bx'*X*A ) . +C + CALL DSYTRS( 'U', NP+M, N, DWORK( I17 ), NP+M, IWORK, + $ DWORK( I18 ), NP+M, INFO2 ) +C +C Compute B'*X . +C + CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, DWORK( I15 ), N, + $ ZERO, DWORK( I19 ), M ) +C +C Compute -( D' - B'*X*H ) . +C + DO 130 J = 1, NP + DO 120 I = 1, M + DWORK( I20-1+I+(J-1)*M ) = -D( J, I ) + 120 CONTINUE + 130 CONTINUE +C + CALL DGEMM( 'N', 'N', M, NP, N, ONE, DWORK( I19 ), M, + $ DWORK( I9 ), N, ONE, DWORK( I20 ), M ) +C -1 +C Compute C + Z2 *F1 . +C + CALL DLACPY( 'F', NP, N, C, LDC, DWORK( I21 ), NP ) + CALL DGEMM( 'N', 'N', NP, N, NP, ONE, DWORK( I7 ), NP, + $ DWORK( I18 ), NP+M, ONE, DWORK( I21 ), NP ) +C +C Compute R2 + B'*X*B . +C + CALL MB01RX( 'L', 'U', 'N', M, N, ONE, ONE, DWORK( I3 ), M, + $ DWORK( I19 ), M, B, LDB, INFO2 ) +C +C Factorize R2 + B'*X*B . +C + CALL DPOTRF( 'U', M, DWORK( I3 ), M, INFO2 ) +C ^ -1 +C Compute Dk = -( R2 + B'*X*B ) (D' - B'*X*H) . +C + CALL DLACPY( 'F', M, NP, DWORK( I20 ), M, DK, LDDK ) + CALL DPOTRS( 'U', M, NP, DWORK( I3 ), M, DK, LDDK, INFO2 ) +C ^ ^ +C Compute Bk = -H + B*Dk . +C + CALL DLACPY( 'F', N, NP, DWORK( I9 ), N, DWORK( I23 ), N ) + CALL DGEMM( 'N', 'N', N, NP, M, ONE, B, LDB, DK, LDDK, + $ -ONE, DWORK( I23 ), N ) +C -1/2 +C Compute R2 *F2 . +C + CALL DGEMM( 'N', 'N', M, N, M, ONE, DWORK( I5 ), M, + $ DWORK( I18+NP ), NP+M, ZERO, CK, LDCK ) +C ^ -1/2 ^ -1 +C Compute Ck = R2 *F2 - Dk*( C + Z2 *F1 ) . +C + CALL DGEMM( 'N', 'N', M, N, NP, -ONE, DK, LDDK, + $ DWORK( I21 ), NP, ONE, CK, LDCK ) +C ^ ^ +C Compute Ak = A + H*C + B*Ck . +C + CALL DLACPY( 'F', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I9 ), N, C, LDC, + $ ONE, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, CK, LDCK, + $ ONE, AK, LDAK ) +C ^ +C Compute Ip + D*Dk . +C + CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK( I24 ), NP ) + CALL DGEMM( 'N', 'N', NP, NP, M, ONE, D, LDD, DK, LDDK, + $ ONE, DWORK( I24 ), NP ) +C ^ +C Compute Im + Dk*D . +C + CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK( I25 ), M ) + CALL DGEMM( 'N', 'N', M, M, NP, ONE, DK, LDDK, D, LDD, + $ ONE, DWORK( I25 ), M ) +C ^ ^ ^ ^ -1 +C Compute Ck = M*Ck, M = (Im + Dk*D) . +C + ANORM = DLANGE( '1', M, M, DWORK( I25 ), M, DWORK( IWRK ) ) + CALL DGETRF( M, M, DWORK( I25 ), M, IWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 7 + RETURN + END IF + CALL DGECON( '1', M, DWORK( I25 ), M, ANORM, RCOND( 6 ), + $ DWORK( IWRK ), IWORK( M+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 6 ).LT.TOLL ) THEN + INFO = 7 + RETURN + END IF + CALL DGETRS( 'N', M, N, DWORK( I25 ), M, IWORK, CK, LDCK, INFO2 ) +C ^ ^ +C Compute Dk = M*Dk . +C + CALL DGETRS( 'N', M, NP, DWORK( I25 ), M, IWORK, DK, LDDK, INFO2 ) +C ^ +C Compute Bk*D . +C + CALL DGEMM( 'N', 'N', N, M, NP, ONE, DWORK( I23 ), N, D, LDD, + $ ZERO, DWORK( I26 ), N ) +C ^ ^ +C Compute Ak = Ak - Bk*D*Ck. +C + CALL DGEMM( 'N', 'N', N, N, M, -ONE, DWORK( I26 ), N, CK, LDCK, + $ ONE, AK, LDAK ) +C ^ ^ -1 +C Compute Bk = Bk*(Ip + D*Dk) . +C + ANORM = DLANGE( '1', NP, NP, DWORK( I24 ), NP, DWORK( IWRK ) ) + CALL DLACPY( 'Full', N, NP, DWORK( I23 ), N, BK, LDBK ) + CALL MB02VD( 'N', N, NP, DWORK( I24 ), NP, IWORK, BK, LDBK, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 6 + RETURN + END IF + CALL DGECON( '1', NP, DWORK( I24 ), NP, ANORM, RCOND( 5 ), + $ DWORK( IWRK ), IWORK( NP+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 5 ).LT.TOLL ) THEN + INFO = 6 + RETURN + END IF +C +C Workspace usage. +C + I2 = 1 + NP*NP + I3 = I2 + N*NP + I4 = I3 + M*M + I5 = I4 + N*M + I6 = I5 + NP*N + I7 = I6 + M*N + I8 = I7 + N2*N2 + I9 = I8 + N2 +C + IWRK = I9 + N2 +C +C Compute Ip - D*Dk . +C + CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK, NP ) + CALL DGEMM( 'N', 'N', NP, NP, M, -ONE, D, LDD, DK, LDDK, ONE, + $ DWORK, NP ) +C -1 +C Compute Bk*(Ip-D*Dk) . +C + CALL DLACPY( 'Full', N, NP, BK, LDBK, DWORK( I2 ), N ) + CALL MB02VD( 'N', N, NP, DWORK, NP, IWORK, DWORK( I2 ), N, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 8 + RETURN + END IF +C +C Compute Im - Dk*D . +C + CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK( I3 ), M ) + CALL DGEMM( 'N', 'N', M, M, NP, -ONE, DK, LDDK, D, LDD, ONE, + $ DWORK( I3 ), M ) +C -1 +C Compute B*(Im-Dk*D) . +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK( I4 ), N ) + CALL MB02VD( 'N', N, M, DWORK( I3 ), M, IWORK, DWORK( I4 ), N, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 9 + RETURN + END IF +C +C Compute D*Ck . +C + CALL DGEMM( 'N', 'N', NP, N, M, ONE, D, LDD, CK, LDCK, ZERO, + $ DWORK( I5 ), NP ) +C +C Compute Dk*C . +C + CALL DGEMM( 'N', 'N', M, N, NP, ONE, DK, LDDK, C, LDC, ZERO, + $ DWORK( I6 ), M ) +C +C Compute the closed-loop state matrix. +C + CALL DLACPY( 'F', N, N, A, LDA, DWORK( I7 ), N2 ) + CALL DGEMM( 'N', 'N', N, N, M, ONE, DWORK( I4 ), N, + $ DWORK( I6 ), M, ONE, DWORK( I7 ), N2 ) + CALL DGEMM( 'N', 'N', N, N, M, ONE, DWORK( I4 ), N, CK, LDCK, + $ ZERO, DWORK( I7+N2*N ), N2 ) + CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I2 ), N, C, LDC, + $ ZERO, DWORK( I7+N ), N2 ) + CALL DLACPY( 'F', N, N, AK, LDAK, DWORK( I7+N2*N+N ), N2 ) + CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I2 ), N, + $ DWORK( I5 ), NP, ONE, DWORK( I7+N2*N+N ), N2 ) +C +C Compute the closed-loop poles. +C + CALL DGEES( 'N', 'N', SELECT, N2, DWORK( I7 ), N2, SDIM, + $ DWORK( I8 ), DWORK( I9 ), DWORK( IWRK ), N, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) +C +C Check the stability of the closed-loop system. +C + NS = 0 +C + DO 140 I = 0, N2 - 1 + IF( DLAPY2( DWORK( I8+I ), DWORK( I9+I ) ).GT.ONE ) + $ NS = NS + 1 + 140 CONTINUE +C + IF( NS.GT.0 ) THEN + INFO = 10 + RETURN + END IF +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10ZD *** + END diff --git a/mex/sources/libslicot/SB10ZP.f b/mex/sources/libslicot/SB10ZP.f new file mode 100644 index 000000000..efaa9ac14 --- /dev/null +++ b/mex/sources/libslicot/SB10ZP.f @@ -0,0 +1,339 @@ + SUBROUTINE SB10ZP( DISCFL, N, A, LDA, B, C, D, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To transform a SISO (single-input single-output) system [A,B;C,D] +C by mirroring its unstable poles and zeros in the boundary of the +C stability domain, thus preserving the frequency response of the +C system, but making it stable and minimum phase. Specifically, for +C a continuous-time system, the positive real parts of its poles +C and zeros are exchanged with their negatives. Discrete-time +C systems are first converted to continuous-time systems using a +C bilinear transformation, and finally converted back. +C +C ARGUMENTS +C +C Input/Output parameters +C +C DISCFL (input) INTEGER +C Indicates the type of the system, as follows: +C = 0: continuous-time system; +C = 1: discrete-time system. +C +C N (input/output) INTEGER +C On entry, the order of the original system. N >= 0. +C On exit, the order of the transformed, minimal system. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original system matrix A. +C On exit, the leading N-by-N part of this array contains +C the transformed matrix A, in an upper Hessenberg form. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the original system +C vector B. +C On exit, this array contains the transformed vector B. +C +C C (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the original system +C vector C. +C On exit, this array contains the transformed vector C. +C The first N-1 elements are zero (for the exit value of N). +C +C D (input/output) DOUBLE PRECISION array, dimension (1) +C On entry, this array must contain the original system +C scalar D. +C On exit, this array contains the transformed scalar D. +C +C Workspace +C +C IWORK INTEGER array, dimension max(2,N+1) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max(N*N + 5*N, 6*N + 1 + min(1,N)). +C For optimum performance LDWORK should be larger. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the discrete --> continuous transformation cannot +C be made; +C = 2: if the system poles cannot be found; +C = 3: if the inverse system cannot be found, i.e., D is +C (close to) zero; +C = 4: if the system zeros cannot be found; +C = 5: if the state-space representation of the new +C transfer function T(s) cannot be found; +C = 6: if the continuous --> discrete transformation cannot +C be made. +C +C METHOD +C +C First, if the system is discrete-time, it is transformed to +C continuous-time using alpha = beta = 1 in the bilinear +C transformation implemented in the SLICOT routine AB04MD. +C Then the eigenvalues of A, i.e., the system poles, are found. +C Then, the inverse of the original system is found and its poles, +C i.e., the system zeros, are evaluated. +C The obtained system poles Pi and zeros Zi are checked and if a +C positive real part is detected, it is exchanged by -Pi or -Zi. +C Then the polynomial coefficients of the transfer function +C T(s) = Q(s)/P(s) are found. +C The state-space representation of T(s) is then obtained. +C The system matrices B, C, D are scaled so that the transformed +C system has the same system gain as the original system. +C If the original system is discrete-time, then the result (which is +C continuous-time) is converted back to discrete-time. +C +C CONTRIBUTORS +C +C Asparuh Markovski, Technical University of Sofia, July 2003. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. +C +C KEYWORDS +C +C Bilinear transformation, stability, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER DISCFL, INFO, LDA, LDWORK, N +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( * ), C( * ), D( * ), DWORK( * ) +C .. +C .. Local Scalars .. + INTEGER I, IDW1, IDW2, IDW3, IMP, IMZ, INFO2, IWA, IWP, + $ IWPS, IWQ, IWQS, LDW1, MAXWRK, REP, REZ + DOUBLE PRECISION RCOND, SCALB, SCALC, SCALD +C .. +C .. Local Arrays .. + INTEGER INDEX(1) +C .. +C .. External Subroutines .. + EXTERNAL AB04MD, AB07ND, DCOPY, DGEEV, DLACPY, DSCAL, + $ MC01PD, TD04AD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX, MIN, SIGN, SQRT +C +C Test input parameters and workspace. +C + INFO = 0 + IF ( DISCFL.NE.0 .AND. DISCFL.NE.1 ) THEN + INFO = -1 + ELSE IF ( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDWORK.LT.MAX( N*N + 5*N, 6*N + 1 + MIN( 1, N ) ) ) THEN + INFO = -10 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB10ZP', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Workspace usage 1. +C + REP = 1 + IMP = REP + N + REZ = IMP + N + IMZ = REZ + N + IWA = REZ + IDW1 = IWA + N*N + LDW1 = LDWORK - IDW1 + 1 +C +C 1. Discrete --> continuous transformation if needed. +C + IF ( DISCFL.EQ.1 ) THEN +C +C Workspace: need max(1,N); +C prefer larger. +C + CALL AB04MD( 'D', N, 1, 1, ONE, ONE, A, LDA, B, LDA, C, 1, + $ D, 1, IWORK, DWORK, LDWORK, INFO2 ) + IF ( INFO2.NE.0 ) THEN + INFO = 1 + RETURN + END IF + MAXWRK = INT( DWORK(1) ) + ELSE + MAXWRK = 0 + END IF +C +C 2. Determine the factors for restoring system gain. +C + SCALD = D(1) + SCALC = SQRT( ABS( SCALD ) ) + SCALB = SIGN( SCALC, SCALD ) +C +C 3. Find the system poles, i.e., the eigenvalues of A. +C Workspace: need N*N + 2*N + 3*N; +C prefer larger. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IWA), N ) +C + CALL DGEEV( 'N', 'N', N, DWORK(IWA), N, DWORK(REP), DWORK(IMP), + $ DWORK(IDW1), 1, DWORK(IDW1), 1, DWORK(IDW1), LDW1, + $ INFO2 ) + IF ( INFO2.NE.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) ) +C +C 4. Compute the inverse system [Ai, Bi; Ci, Di]. +C Workspace: need N*N + 2*N + 4; +C prefer larger. +C + CALL AB07ND( N, 1, A, LDA, B, LDA, C, 1, D, 1, RCOND, IWORK, + $ DWORK(IDW1), LDW1, INFO2 ) + IF ( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) ) +C +C 5. Find the system zeros, i.e., the eigenvalues of Ai. +C Workspace: need 4*N + 3*N; +C prefer larger. +C + IDW1 = IMZ + N + LDW1 = LDWORK - IDW1 + 1 +C + CALL DGEEV( 'N', 'N', N, A, LDA, DWORK(REZ), DWORK(IMZ), + $ DWORK(IDW1), 1, DWORK(IDW1), 1, DWORK(IDW1), LDW1, + $ INFO2 ) + IF ( INFO2.NE.0 ) THEN + INFO = 4 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) ) +C +C 6. Exchange the zeros and the poles with positive real parts with +C their negatives. +C + DO 10 I = 0, N - 1 + IF ( DWORK(REP+I).GT.ZERO ) + $ DWORK(REP+I) = -DWORK(REP+I) + IF ( DWORK(REZ+I).GT.ZERO ) + $ DWORK(REZ+I) = -DWORK(REZ+I) + 10 CONTINUE +C +C Workspace usage 2. +C + IWP = IDW1 + IDW2 = IWP + N + 1 + IWPS = 1 +C +C 7. Construct the nominator and the denominator +C of the system transfer function T( s ) = Q( s )/P( s ). +C 8. Rearrange the coefficients in Q(s) and P(s) because +C MC01PD subroutine produces them in increasing powers of s. +C Workspace: need 6*N + 2. +C + CALL MC01PD( N, DWORK(REP), DWORK(IMP), DWORK(IWP), DWORK(IDW2), + $ INFO2 ) + CALL DCOPY( N+1, DWORK(IWP), -1, DWORK(IWPS), 1 ) +C +C Workspace usage 3. +C + IWQ = IDW1 + IWQS = IWPS + N + 1 + IDW3 = IWQS + N + 1 +C + CALL MC01PD( N, DWORK(REZ), DWORK(IMZ), DWORK(IWQ), DWORK(IDW2), + $ INFO2 ) + CALL DCOPY( N+1, DWORK(IWQ), -1, DWORK(IWQS), 1 ) +C +C 9. Make the conversion T(s) --> [A, B; C, D]. +C Workspace: need 2*N + 2 + N + max(N,3); +C prefer larger. +C + INDEX(1) = N + CALL TD04AD( 'R', 1, 1, INDEX, DWORK(IWPS), 1, DWORK(IWQS), 1, 1, + $ N, A, LDA, B, LDA, C, 1, D, 1, -ONE, IWORK, + $ DWORK(IDW3), LDWORK-IDW3+1, INFO2 ) + IF ( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(IDW3) + IDW3 - 1 ) ) +C +C 10. Scale the transformed system to the previous gain. +C + IF ( N.GT.0 ) THEN + CALL DSCAL( N, SCALB, B, 1 ) + C(N) = SCALC*C(N) + END IF +C + D(1) = SCALD +C +C 11. Continuous --> discrete transformation if needed. +C + IF ( DISCFL.EQ.1 ) THEN + CALL AB04MD( 'C', N, 1, 1, ONE, ONE, A, LDA, B, LDA, C, 1, + $ D, 1, IWORK, DWORK, LDWORK, INFO2 ) + + IF ( INFO2.NE.0 ) THEN + INFO = 6 + RETURN + END IF + END IF +C + DWORK(1) = MAXWRK + RETURN +C +C *** Last line of SB10ZP *** + END diff --git a/mex/sources/libslicot/SB16AD.f b/mex/sources/libslicot/SB16AD.f new file mode 100644 index 000000000..565147c9f --- /dev/null +++ b/mex/sources/libslicot/SB16AD.f @@ -0,0 +1,719 @@ + SUBROUTINE SB16AD( DICO, JOBC, JOBO, JOBMR, WEIGHT, EQUIL, ORDSEL, + $ N, M, P, NC, NCR, ALPHA, A, LDA, B, LDB, + $ C, LDC, D, LDD, AC, LDAC, BC, LDBC, CC, LDCC, + $ DC, LDDC, NCS, HSVC, TOL1, TOL2, IWORK, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order controller (Acr,Bcr,Ccr,Dcr) for an +C original state-space controller representation (Ac,Bc,Cc,Dc) by +C using the frequency-weighted square-root or balancing-free +C square-root Balance & Truncate (B&T) or Singular Perturbation +C Approximation (SPA) model reduction methods. The algorithm tries +C to minimize the norm of the frequency-weighted error +C +C ||V*(K-Kr)*W|| +C +C where K and Kr are the transfer-function matrices of the original +C and reduced order controllers, respectively. V and W are special +C frequency-weighting transfer-function matrices constructed +C to enforce closed-loop stability and/or closed-loop performance. +C If G is the transfer-function matrix of the open-loop system, then +C the following weightings V and W can be used: +C -1 +C (a) V = (I-G*K) *G, W = I - to enforce closed-loop stability; +C -1 +C (b) V = I, W = (I-G*K) *G - to enforce closed-loop stability; +C -1 -1 +C (c) V = (I-G*K) *G, W = (I-G*K) - to enforce closed-loop +C stability and performance. +C +C G has the state space representation (A,B,C,D). +C If K is unstable, only the ALPHA-stable part of K is reduced. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original controller as follows: +C = 'C': continuous-time controller; +C = 'D': discrete-time controller. +C +C JOBC CHARACTER*1 +C Specifies the choice of frequency-weighted controllability +C Grammian as follows: +C = 'S': choice corresponding to standard Enns' method [1]; +C = 'E': choice corresponding to the stability enhanced +C modified Enns' method of [2]. +C +C JOBO CHARACTER*1 +C Specifies the choice of frequency-weighted observability +C Grammian as follows: +C = 'S': choice corresponding to standard Enns' method [1]; +C = 'E': choice corresponding to the stability enhanced +C modified combination method of [2]. +C +C JOBMR CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root B&T method; +C = 'F': use the balancing-free square-root B&T method; +C = 'S': use the square-root SPA method; +C = 'P': use the balancing-free square-root SPA method. +C +C WEIGHT CHARACTER*1 +C Specifies the type of frequency-weighting, as follows: +C = 'N': no weightings are used (V = I, W = I); +C = 'O': stability enforcing left (output) weighting +C -1 +C V = (I-G*K) *G is used (W = I); +C = 'I': stability enforcing right (input) weighting +C -1 +C W = (I-G*K) *G is used (V = I); +C = 'P': stability and performance enforcing weightings +C -1 -1 +C V = (I-G*K) *G , W = (I-G*K) are used. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplets (A,B,C) and (Ac,Bc,Cc) as +C follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NCR is fixed; +C = 'A': the resulting order NCR is automatically +C determined on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the open-loop system state-space +C representation, i.e., the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NC (input) INTEGER +C The order of the controller state-space representation, +C i.e., the order of the matrix AC. NC >= 0. +C +C NCR (input/output) INTEGER +C On entry with ORDSEL = 'F', NCR is the desired order of +C the resulting reduced order controller. 0 <= NCR <= NC. +C On exit, if INFO = 0, NCR is the order of the resulting +C reduced order controller. For a controller with NCU +C ALPHA-unstable eigenvalues and NCS ALPHA-stable +C eigenvalues (NCU+NCS = NC), NCR is set as follows: +C if ORDSEL = 'F', NCR is equal to +C NCU+MIN(MAX(0,NCR-NCU),NCMIN), where NCR is the desired +C order on entry, NCMIN is the number of frequency-weighted +C Hankel singular values greater than NCS*EPS*S1, EPS is the +C machine precision (see LAPACK Library Routine DLAMCH) and +C S1 is the largest Hankel singular value (computed in +C HSVC(1)); NCR can be further reduced to ensure +C HSVC(NCR-NCU) > HSVC(NCR+1-NCU); +C if ORDSEL = 'A', NCR is the sum of NCU and the number of +C Hankel singular values greater than MAX(TOL1,NCS*EPS*S1). +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix AC. For a continuous-time +C controller (DICO = 'C'), ALPHA <= 0 is the boundary value +C for the real parts of eigenvalues; for a discrete-time +C controller (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A of the open-loop +C system. +C On exit, if INFO = 0 and EQUIL = 'S', the leading N-by-N +C part of this array contains the scaled state dynamics +C matrix of the open-loop system. +C If EQUIL = 'N', this array is unchanged on exit. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix B of the open-loop system. +C On exit, if INFO = 0 and EQUIL = 'S', the leading N-by-M +C part of this array contains the scaled input/state matrix +C of the open-loop system. +C If EQUIL = 'N', this array is unchanged on exit. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C of the open-loop system. +C On exit, if INFO = 0 and EQUIL = 'S', the leading P-by-N +C part of this array contains the scaled state/output matrix +C of the open-loop system. +C If EQUIL = 'N', this array is unchanged on exit. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C input/output matrix D of the open-loop system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C AC (input/output) DOUBLE PRECISION array, dimension (LDAC,NC) +C On entry, the leading NC-by-NC part of this array must +C contain the state dynamics matrix Ac of the original +C controller. +C On exit, if INFO = 0, the leading NCR-by-NCR part of this +C array contains the state dynamics matrix Acr of the +C reduced controller. The resulting Ac has a +C block-diagonal form with two blocks. +C For a system with NCU ALPHA-unstable eigenvalues and +C NCS ALPHA-stable eigenvalues (NCU+NCS = NC), the leading +C NCU-by-NCU block contains the unreduced part of Ac +C corresponding to the ALPHA-unstable eigenvalues. +C The trailing (NCR+NCS-NC)-by-(NCR+NCS-NC) block contains +C the reduced part of Ac corresponding to ALPHA-stable +C eigenvalues. +C +C LDAC INTEGER +C The leading dimension of array AC. LDAC >= MAX(1,NC). +C +C BC (input/output) DOUBLE PRECISION array, dimension (LDBC,P) +C On entry, the leading NC-by-P part of this array must +C contain the input/state matrix Bc of the original +C controller. +C On exit, if INFO = 0, the leading NCR-by-P part of this +C array contains the input/state matrix Bcr of the reduced +C controller. +C +C LDBC INTEGER +C The leading dimension of array BC. LDBC >= MAX(1,NC). +C +C CC (input/output) DOUBLE PRECISION array, dimension (LDCC,NC) +C On entry, the leading M-by-NC part of this array must +C contain the state/output matrix Cc of the original +C controller. +C On exit, if INFO = 0, the leading M-by-NCR part of this +C array contains the state/output matrix Ccr of the reduced +C controller. +C +C LDCC INTEGER +C The leading dimension of array CC. LDCC >= MAX(1,M). +C +C DC (input/output) DOUBLE PRECISION array, dimension (LDDC,P) +C On entry, the leading M-by-P part of this array must +C contain the input/output matrix Dc of the original +C controller. +C On exit, if INFO = 0, the leading M-by-P part of this +C array contains the input/output matrix Dcr of the reduced +C controller. +C +C LDDC INTEGER +C The leading dimension of array DC. LDDC >= MAX(1,M). +C +C NCS (output) INTEGER +C The dimension of the ALPHA-stable part of the controller. +C +C HSVC (output) DOUBLE PRECISION array, dimension (NC) +C If INFO = 0, the leading NCS elements of this array +C contain the frequency-weighted Hankel singular values, +C ordered decreasingly, of the ALPHA-stable part of the +C controller. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of the reduced controller. +C For model reduction, the recommended value is +C TOL1 = c*S1, where c is a constant in the +C interval [0.00001,0.001], and S1 is the largest +C frequency-weighted Hankel singular value of the +C ALPHA-stable part of the original controller +C (computed in HSVC(1)). +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = NCS*EPS*S1, where NCS is the number of +C ALPHA-stable eigenvalues of Ac and EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the ALPHA-stable part of the given +C controller. The recommended value is TOL2 = NCS*EPS*S1. +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension MAX(1,LIWRK1,LIWRK2) +C LIWRK1 = 0, if JOBMR = 'B'; +C LIWRK1 = NC, if JOBMR = 'F'; +C LIWRK1 = 2*NC, if JOBMR = 'S' or 'P'; +C LIWRK2 = 0, if WEIGHT = 'N'; +C LIWRK2 = 2*(M+P), if WEIGHT = 'O', 'I', or 'P'. +C On exit, if INFO = 0, IWORK(1) contains NCMIN, the order +C of the computed minimal realization of the stable part of +C the controller. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 2*NC*NC + MAX( 1, LFREQ, LSQRED ), +C where +C LFREQ = (N+NC)*(N+NC+2*M+2*P)+ +C MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), (M+P)*(M+P+4)) +C if WEIGHT = 'I' or 'O' or 'P'; +C LFREQ = NC*(MAX(M,P)+5) if WEIGHT = 'N' and EQUIL = 'N'; +C LFREQ = MAX(N,NC*(MAX(M,P)+5)) if WEIGHT = 'N' and +C EQUIL = 'S'; +C LSQRED = MAX( 1, 2*NC*NC+5*NC ); +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NCR is greater +C than NSMIN, the sum of the order of the +C ALPHA-unstable part and the order of a minimal +C realization of the ALPHA-stable part of the given +C controller; in this case, the resulting NCR is set +C equal to NSMIN; +C = 2: with ORDSEL = 'F', the selected order NCR +C corresponds to repeated singular values for the +C ALPHA-stable part of the controller, which are +C neither all included nor all excluded from the +C reduced model; in this case, the resulting NCR is +C automatically decreased to exclude all repeated +C singular values; +C = 3: with ORDSEL = 'F', the selected order NCR is less +C than the order of the ALPHA-unstable part of the +C given controller. In this case NCR is set equal to +C the order of the ALPHA-unstable part. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the closed-loop system is not well-posed; +C its feedthrough matrix is (numerically) singular; +C = 2: the computation of the real Schur form of the +C closed-loop state matrix failed; +C = 3: the closed-loop state matrix is not stable; +C = 4: the solution of a symmetric eigenproblem failed; +C = 5: the computation of the ordered real Schur form of Ac +C failed; +C = 6: the separation of the ALPHA-stable/unstable +C diagonal blocks failed because of very close +C eigenvalues; +C = 7: the computation of Hankel singular values failed. +C +C METHOD +C +C Let K be the transfer-function matrix of the original linear +C controller +C +C d[xc(t)] = Ac*xc(t) + Bc*y(t) +C u(t) = Cc*xc(t) + Dc*y(t), (1) +C +C where d[xc(t)] is dxc(t)/dt for a continuous-time system and +C xc(t+1) for a discrete-time system. The subroutine SB16AD +C determines the matrices of a reduced order controller +C +C d[z(t)] = Acr*z(t) + Bcr*y(t) +C u(t) = Ccr*z(t) + Dcr*y(t), (2) +C +C such that the corresponding transfer-function matrix Kr minimizes +C the norm of the frequency-weighted error +C +C V*(K-Kr)*W, (3) +C +C where V and W are special stable transfer-function matrices +C chosen to enforce stability and/or performance of the closed-loop +C system [3] (see description of the parameter WEIGHT). +C +C The following procedure is used to reduce K in conjunction +C with the frequency-weighted balancing approach of [2] +C (see also [3]): +C +C 1) Decompose additively K, of order NC, as +C +C K = K1 + K2, +C +C such that K1 has only ALPHA-stable poles and K2, of order NCU, +C has only ALPHA-unstable poles. +C +C 2) Compute for K1 a B&T or SPA frequency-weighted approximation +C K1r of order NCR-NCU using the frequency-weighted balancing +C approach of [1] in conjunction with accuracy enhancing +C techniques specified by the parameter JOBMR. +C +C 3) Assemble the reduced model Kr as +C +C Kr = K1r + K2. +C +C For the reduction of the ALPHA-stable part, several accuracy +C enhancing techniques can be employed (see [2] for details). +C +C If JOBMR = 'B', the square-root B&T method of [1] is used. +C +C If JOBMR = 'F', the balancing-free square-root version of the +C B&T method [1] is used. +C +C If JOBMR = 'S', the square-root version of the SPA method [2,3] +C is used. +C +C If JOBMR = 'P', the balancing-free square-root version of the +C SPA method [2,3] is used. +C +C For each of these methods, two left and right truncation matrices +C are determined using the Cholesky factors of an input +C frequency-weighted controllability Grammian P and an output +C frequency-weighted observability Grammian Q. +C P and Q are determined as the leading NC-by-NC diagonal blocks +C of the controllability Grammian of K*W and of the +C observability Grammian of V*K. Special techniques developed in [2] +C are used to compute the Cholesky factors of P and Q directly +C (see also SLICOT Library routine SB16AY). +C The frequency-weighted Hankel singular values HSVC(1), ...., +C HSVC(NC) are computed as the square roots of the eigenvalues +C of the product P*Q. +C +C REFERENCES +C +C [1] Enns, D. +C Model reduction with balanced realizations: An error bound +C and a frequency weighted generalization. +C Proc. 23-th CDC, Las Vegas, pp. 127-132, 1984. +C +C [2] Varga, A. and Anderson, B.D.O. +C Square-root balancing-free methods for frequency-weighted +C balancing related model reduction. +C (report in preparation) +C +C [3] Anderson, B.D.O and Liu, Y. +C Controller reduction: concepts and approaches. +C IEEE Trans. Autom. Control, Vol. 34, pp. 802-812, 1989. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root +C techniques. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, Sept. 2000. +C D. Sima, University of Bucharest, Sept. 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Sept.2000. +C +C REVISIONS +C +C A. Varga, Australian National University, Canberra, November 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, +C Sep. 2001. +C +C KEYWORDS +C +C Controller reduction, frequency weighting, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION C100, ONE, ZERO + PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOBC, JOBO, JOBMR, ORDSEL, WEIGHT + INTEGER INFO, IWARN, LDA, LDAC, LDB, LDBC, LDC, LDCC, + $ LDD, LDDC, LDWORK, M, N, NC, NCR, NCS, P + DOUBLE PRECISION ALPHA, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), AC(LDAC,*), B(LDB,*), BC(LDBC,*), + $ C(LDC,*), CC(LDCC,*), D(LDD,*), DC(LDDC,*), + $ DWORK(*), HSVC(*) +C .. Local Scalars .. + LOGICAL BAL, BTA, DISCR, FIXORD, FRWGHT, ISTAB, LEFTW, + $ OSTAB, PERF, RIGHTW, SPA + INTEGER IERR, IWARNL, KI, KR, KT, KTI, KU, KW, LW, MP, + $ NCU, NCU1, NMR, NNC, NRA, WRKOPT + DOUBLE PRECISION ALPWRK, MAXRED, SCALEC, SCALEO +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB09IX, SB16AY, TB01ID, TB01KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + BTA = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'F' ) + SPA = LSAME( JOBMR, 'S' ) .OR. LSAME( JOBMR, 'P' ) + BAL = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'S' ) + FIXORD = LSAME( ORDSEL, 'F' ) + ISTAB = LSAME( WEIGHT, 'I' ) + OSTAB = LSAME( WEIGHT, 'O' ) + PERF = LSAME( WEIGHT, 'P' ) + LEFTW = OSTAB .OR. PERF + RIGHTW = ISTAB .OR. PERF + FRWGHT = LEFTW .OR. RIGHTW +C + LW = 1 + NNC = N + NC + MP = M + P + IF( FRWGHT ) THEN + LW = NNC*( NNC + 2*MP ) + + $ MAX( NNC*( NNC + MAX( NNC, M, P ) + 7 ), MP*( MP + 4 ) ) + ELSE + LW = NC*( MAX( M, P ) + 5 ) + IF ( LSAME( EQUIL, 'S' ) ) + $ LW = MAX( N, LW ) + END IF + LW = 2*NC*NC + MAX( 1, LW, NC*( 2*NC + 5 ) ) +C +C Check the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) + $ THEN + INFO = -2 + ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) + $ THEN + INFO = -3 + ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN + INFO = -4 + ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN + INFO = -5 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -6 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -7 + ELSE IF( N.LT.0 ) THEN + INFO = -8 + ELSE IF( M.LT.0 ) THEN + INFO = -9 + ELSE IF( P.LT.0 ) THEN + INFO = -10 + ELSE IF( NC.LT.0 ) THEN + INFO = -11 + ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.NC ) ) THEN + INFO = -12 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -13 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -19 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -21 + ELSE IF( LDAC.LT.MAX( 1, NC ) ) THEN + INFO = -23 + ELSE IF( LDBC.LT.MAX( 1, NC ) ) THEN + INFO = -25 + ELSE IF( LDCC.LT.MAX( 1, M ) ) THEN + INFO = -27 + ELSE IF( LDDC.LT.MAX( 1, M ) ) THEN + INFO = -29 + ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN + INFO = -33 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -36 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB16AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( NC, M, P ).EQ.0 ) THEN + NCR = 0 + NCS = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C and AC, BC and CC; +C A <- inv(T1)*A*T1, B <- inv(T1)*B and C <- C*T1, where T1 is a +C diagonal matrix; +C AC <- inv(T2)*AC*T2, BC <- inv(T2)*BC and CC <- CC*T2, where T2 +C is a diagonal matrix. +C +C Real workspace: need MAX(N,NC). +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + MAXRED = C100 + CALL TB01ID( 'All', NC, P, M, MAXRED, AC, LDAC, BC, LDBC, + $ CC, LDCC, DWORK, INFO ) + END IF +C +C Correct the value of ALPHA to ensure stability. +C + ALPWRK = ALPHA + IF( DISCR ) THEN + IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) + ELSE + IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) + END IF +C +C Reduce Ac to a block-diagonal real Schur form, with the +C ALPHA-unstable part in the leading diagonal position, using a +C non-orthogonal similarity transformation, AC <- inv(T)*AC*T, and +C apply the transformation to BC and CC: +C BC <- inv(T)*BC and CC <- CC*T. +C +C Workspace: need NC*(NC+5); +C prefer larger. +C + WRKOPT = 1 + KU = 1 + KR = KU + NC*NC + KI = KR + NC + KW = KI + NC +C + CALL TB01KD( DICO, 'Unstable', 'General', NC, P, M, ALPWRK, + $ AC, LDAC, BC, LDBC, CC, LDCC, NCU, DWORK(KU), NC, + $ DWORK(KR), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 5 + ELSE + INFO = 6 + END IF + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C + IWARNL = 0 + NCS = NC - NCU + IF( FIXORD ) THEN + NRA = MAX( 0, NCR-NCU ) + IF( NCR.LT.NCU ) + $ IWARNL = 3 + ELSE + NRA = 0 + END IF +C +C Finish if only unstable part is present. +C + IF( NCS.EQ.0 ) THEN + NCR = NCU + IWORK(1) = 0 + DWORK(1) = WRKOPT + RETURN + END IF +C +C Allocate working storage. +C + KT = 1 + KTI = KT + NC*NC + KW = KTI + NC*NC +C +C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors S and R +C of the frequency-weighted controllability and observability +C Grammians, respectively. +C +C Real workspace: need 2*NC*NC + MAX( 1, LFREQ ), +C where +C LFREQ = (N+NC)*(N+NC+2*M+2*P)+ +C MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), +C (M+P)*(M+P+4)) +C if WEIGHT = 'I' or 'O' or 'P'; +C LFREQ = NCS*(MAX(M,P)+5) if WEIGHT = 'N'; +C prefer larger. +C Integer workspace: 2*(M+P) if WEIGHT = 'I' or 'O' or 'P'; +C 0, if WEIGHT = 'N'. +C + CALL SB16AY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NC, NCS, + $ A, LDA, B, LDB, C, LDC, D, LDD, + $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, + $ SCALEC, SCALEO, DWORK(KTI), NC, DWORK(KT), NC, + $ IWORK, DWORK(KW), LDWORK-KW+1, INFO ) + IF( INFO.NE.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Compute a BTA or SPA of the stable part. +C Real workspace: need 2*NC*NC + MAX( 1, 2*NC*NC+5*NC, +C NC*MAX(M,P) ); +C prefer larger. +C Integer workspace: 0, if JOBMR = 'B'; +C NC, if JOBMR = 'F'; +C 2*NC, if JOBMR = 'S' or 'P'. +C + NCU1 = NCU + 1 + CALL AB09IX( DICO, JOBMR, 'Schur', ORDSEL, NCS, P, M, NRA, SCALEC, + $ SCALEO, AC(NCU1,NCU1), LDAC, BC(NCU1,1), LDBC, + $ CC(1,NCU1), LDCC, DC, LDDC, DWORK(KTI), NC, + $ DWORK(KT), NC, NMR, HSVC, TOL1, TOL2, IWORK, + $ DWORK(KW), LDWORK-KW+1, IWARN, IERR ) + IWARN = MAX( IWARN, IWARNL ) + IF( IERR.NE.0 ) THEN + INFO = 7 + RETURN + END IF + NCR = NRA + NCU + IWORK(1) = NMR +C + DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C + RETURN +C *** Last line of SB16AD *** + END diff --git a/mex/sources/libslicot/SB16AY.f b/mex/sources/libslicot/SB16AY.f new file mode 100644 index 000000000..51438021e --- /dev/null +++ b/mex/sources/libslicot/SB16AY.f @@ -0,0 +1,909 @@ + SUBROUTINE SB16AY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NC, NCS, + $ A, LDA, B, LDB, C, LDC, D, LDD, + $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, + $ SCALEC, SCALEO, S, LDS, R, LDR, + $ IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute for given state-space representations (A,B,C,D) and +C (Ac,Bc,Cc,Dc) of the transfer-function matrices of the +C open-loop system G and feedback controller K, respectively, +C the Cholesky factors of the frequency-weighted +C controllability and observability Grammians corresponding +C to a frequency-weighted model reduction problem. +C The controller must stabilize the closed-loop system. +C The state matrix Ac must be in a block-diagonal real Schur form +C Ac = diag(Ac1,Ac2), where Ac1 contains the unstable eigenvalues +C of Ac and Ac2 contains the stable eigenvalues of Ac. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the systems as follows: +C = 'C': G and K are continuous-time systems; +C = 'D': G and K are discrete-time systems. +C +C JOBC CHARACTER*1 +C Specifies the choice of frequency-weighted controllability +C Grammian as follows: +C = 'S': choice corresponding to standard Enns' method [1]; +C = 'E': choice corresponding to the stability enhanced +C modified Enns' method of [2]. +C +C JOBO CHARACTER*1 +C Specifies the choice of frequency-weighted observability +C Grammian as follows: +C = 'S': choice corresponding to standard Enns' method [1]; +C = 'E': choice corresponding to the stability enhanced +C modified combination method of [2]. +C +C WEIGHT CHARACTER*1 +C Specifies the type of frequency-weighting, as follows: +C = 'N': no weightings are used (V = I, W = I); +C = 'O': stability enforcing left (output) weighting +C -1 +C V = (I-G*K) *G is used (W = I); +C = 'I': stability enforcing right (input) weighting +C -1 +C W = (I-G*K) *G is used (V = I); +C = 'P': stability and performance enforcing weightings +C -1 -1 +C V = (I-G*K) *G , W = (I-G*K) are used. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the open-loop system state-space +C representation, i.e., the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NC (input) INTEGER +C The order of the controller state-space representation, +C i.e., the order of the matrix AC. NC >= 0. +C +C NCS (input) INTEGER +C The dimension of the stable part of the controller, i.e., +C the order of matrix Ac2. NC >= NCS >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the system with the transfer-function +C matrix G. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C input/output matrix D of the open-loop system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C AC (input) DOUBLE PRECISION array, dimension (LDAC,NC) +C The leading NC-by-NC part of this array must contain +C the state dynamics matrix Ac of the controller in a +C block diagonal real Schur form Ac = diag(Ac1,Ac2), where +C Ac1 is (NC-NCS)-by-(NC-NCS) and contains the unstable +C eigenvalues of Ac, and Ac2 is NCS-by-NCS and contains +C the stable eigenvalues of Ac. +C +C LDAC INTEGER +C The leading dimension of array AC. LDAC >= MAX(1,NC). +C +C BC (input) DOUBLE PRECISION array, dimension (LDBC,P) +C The leading NC-by-P part of this array must contain +C the input/state matrix Bc of the controller. +C +C LDBC INTEGER +C The leading dimension of array BC. LDBC >= MAX(1,NC). +C +C CC (input) DOUBLE PRECISION array, dimension (LDCC,NC) +C The leading M-by-NC part of this array must contain +C the state/output matrix Cc of the controller. +C +C LDCC INTEGER +C The leading dimension of array CC. LDCC >= MAX(1,M). +C +C DC (input) DOUBLE PRECISION array, dimension (LDDC,P) +C The leading M-by-P part of this array must contain +C the input/output matrix Dc of the controller. +C +C LDDC INTEGER +C The leading dimension of array DC. LDDC >= MAX(1,M). +C +C SCALEC (output) DOUBLE PRECISION +C Scaling factor for the controllability Grammian. +C See METHOD. +C +C SCALEO (output) DOUBLE PRECISION +C Scaling factor for the observability Grammian. See METHOD. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,NCS) +C The leading NCS-by-NCS upper triangular part of this array +C contains the Cholesky factor S of the frequency-weighted +C controllability Grammian P = S*S'. See METHOD. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,NCS). +C +C R (output) DOUBLE PRECISION array, dimension (LDR,NCS) +C The leading NCS-by-NCS upper triangular part of this array +C contains the Cholesky factor R of the frequency-weighted +C observability Grammian Q = R'*R. See METHOD. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,NCS). +C +C Workspace +C +C IWORK INTEGER array, dimension MAX(LIWRK) +C LIWRK = 0, if WEIGHT = 'N'; +C LIWRK = 2(M+P), if WEIGHT = 'O', 'I', or 'P'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, LFREQ ), +C where +C LFREQ = (N+NC)*(N+NC+2*M+2*P)+ +C MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), (M+P)*(M+P+4)) +C if WEIGHT = 'I' or 'O' or 'P'; +C LFREQ = NCS*(MAX(M,P)+5) if WEIGHT = 'N'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the closed-loop system is not well-posed; +C its feedthrough matrix is (numerically) singular; +C = 2: the computation of the real Schur form of the +C closed-loop state matrix failed; +C = 3: the closed-loop state matrix is not stable; +C = 4: the solution of a symmetric eigenproblem failed; +C = 5: the NCS-by-NCS trailing part Ac2 of the state +C matrix Ac is not stable or not in a real Schur form. +C +C METHOD +C +C If JOBC = 'S', the controllability Grammian P is determined as +C follows: +C +C - if WEIGHT = 'O' or 'N', P satisfies for a continuous-time +C controller the Lyapunov equation +C +C Ac2*P + P*Ac2' + scalec^2*Bc*Bc' = 0 +C +C and for a discrete-time controller +C +C Ac2*P*Ac2' - P + scalec^2*Bc*Bc' = 0; +C +C - if WEIGHT = 'I' or 'P', let Pi be the solution of the +C continuous-time Lyapunov equation +C +C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0 +C +C or of the discrete-time Lyapunov equation +C +C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0, +C +C where Ai and Bi are the state and input matrices of a special +C state-space realization of the input frequency weight (see [2]); +C P results as the trailing NCS-by-NCS part of Pi partitioned as +C +C Pi = ( * * ). +C ( * P ) +C +C If JOBC = 'E', a modified controllability Grammian P1 >= P is +C determined to guarantee stability for a modified Enns' method [2]. +C +C If JOBO = 'S', the observability Grammian Q is determined as +C follows: +C +C - if WEIGHT = 'I' or 'N', Q satisfies for a continuous-time +C controller the Lyapunov equation +C +C Ac2'*Q + Q*Ac2 + scaleo^2*Cc'*Cc = 0 +C +C and for a discrete-time controller +C +C Ac2'*Q*Ac2 - Q + scaleo^2*Cc'*Cc = 0; +C +C - if WEIGHT = 'O' or 'P', let Qo be the solution of the +C continuous-time Lyapunov equation +C +C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0 +C +C or of the discrete-time Lyapunov equation +C +C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0, +C +C where Ao and Co are the state and output matrices of a +C special state-space realization of the output frequency weight +C (see [2]); if WEIGHT = 'O', Q results as the leading NCS-by-NCS +C part of Qo partitioned as +C +C Qo = ( Q * ) +C ( * * ) +C +C while if WEIGHT = 'P', Q results as the trailing NCS-by-NCS +C part of Qo partitioned as +C +C Qo = ( * * ). +C ( * Q ) +C +C If JOBO = 'E', a modified observability Grammian Q1 >= Q is +C determined to guarantee stability for a modified Enns' method [2]. +C +C The routine computes directly the Cholesky factors S and R +C such that P = S*S' and Q = R'*R according to formulas +C developed in [2]. +C +C REFERENCES +C +C [1] Enns, D. +C Model reduction with balanced realizations: An error bound +C and a frequency weighted generalization. +C Proc. CDC, Las Vegas, pp. 127-132, 1984. +C +C [2] Varga, A. and Anderson, B.D.O. +C Frequency-weighted balancing related controller reduction. +C Proceedings of the 15th IFAC World Congress, July 21-26, 2002, +C Barcelona, Spain, Vol.15, Part 1, 2002-07-21. +C +C CONTRIBUTORS +C +C A. Varga, Australian National University, Canberra, November 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, +C May 2009. +C A. Varga, DLR Oberpfafenhofen, June 2001. +C +C +C KEYWORDS +C +C Controller reduction, frequency weighting, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBC, JOBO, WEIGHT + INTEGER INFO, LDA, LDAC, LDB, LDBC, LDC, LDCC, LDD, LDDC, + $ LDR, LDS, LDWORK, M, N, NC, NCS, P + DOUBLE PRECISION SCALEC, SCALEO +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), AC(LDAC,*), B(LDB,*), BC(LDBC,*), + $ C(LDC,*), CC(LDCC,*), D(LDD,*), DC(LDDC,*), + $ DWORK(*), R(LDR,*), S(LDS,*) +C .. Local Scalars .. + CHARACTER JOBFAC + LOGICAL DISCR, FRWGHT, LEFTW, PERF, RIGHTW + INTEGER I, IERR, J, JJ, KI, KL, KQ, KR, KTAU, KU, KW, + $ KWA, KWB, KWC, KWD, LDU, LW, MBBAR, ME, MP, + $ NCU, NCU1, NE, NNC, NNCU, PCBAR, PE, WRKOPT + DOUBLE PRECISION RCOND, T, TOL +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB05PD, AB05QD, AB07ND, DCOPY, DLACPY, DLASET, + $ DSCAL, DSYEV, MB01WD, MB04OD, SB03OD, SB03OU, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + LEFTW = LSAME( WEIGHT, 'O' ) + RIGHTW = LSAME( WEIGHT, 'I' ) + PERF = LSAME( WEIGHT, 'P' ) + FRWGHT = LEFTW .OR. RIGHTW .OR. PERF +C + INFO = 0 + NNC = N + NC + MP = M + P + IF( FRWGHT ) THEN + LW = NNC*( NNC + 2*MP ) + + $ MAX( NNC*( NNC + MAX( NNC, M, P ) + 7 ), MP*( MP + 4 ) ) + ELSE + LW = NCS*( MAX( M, P ) + 5 ) + END IF + LW = MAX( 1, LW ) +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) + $ THEN + INFO = -2 + ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) + $ THEN + INFO = -3 + ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( NC.LT.0 ) THEN + INFO = -8 + ELSE IF( NCS.LT.0 .OR. NCS.GT.NC ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -17 + ELSE IF( LDAC.LT.MAX( 1, NC ) ) THEN + INFO = -19 + ELSE IF( LDBC.LT.MAX( 1, NC ) ) THEN + INFO = -21 + ELSE IF( LDCC.LT.MAX( 1, M ) ) THEN + INFO = -23 + ELSE IF( LDDC.LT.MAX( 1, M ) ) THEN + INFO = -25 + ELSE IF( LDS.LT.MAX( 1, NCS ) ) THEN + INFO = -29 + ELSE IF( LDR.LT.MAX( 1, NCS ) ) THEN + INFO = -31 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -34 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB16AY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + SCALEC = ONE + SCALEO = ONE + IF( MIN( NCS, M, P ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + WRKOPT = 1 + NCU = NC - NCS + NCU1 = NCU + 1 +C + IF( .NOT.PERF ) THEN +C +C Compute the Grammians in the case of no weighting or +C one-sided weighting. +C + IF( LEFTW .OR. LSAME( WEIGHT, 'N' ) ) THEN +C +C Compute the standard controllability Grammian. +C +C Solve for the Cholesky factor S of P, P = S*S', +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C Ac2*P + P*Ac2' + scalec^2*Bc2*Bc2' = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C Ac2*P*Ac2' - P + scalec^2*Bc2*Bc2' = 0, +C +C where Bc2 is the matrix formed from the last NCS rows of Bc. +C +C Workspace: need NCS*(P+5); +C prefer larger. + KU = 1 + KTAU = KU + NCS*P + KW = KTAU + NCS +C + CALL DLACPY( 'Full', NCS, P, BC(NCU1,1), LDBC, + $ DWORK(KU), NCS ) + CALL SB03OU( DISCR, .TRUE., NCS, P, AC(NCU1,NCU1), LDAC, + $ DWORK(KU), NCS, DWORK(KTAU), S, LDS, SCALEC, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 5 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF +C + IF( RIGHTW .OR. LSAME( WEIGHT, 'N' ) ) THEN +C +C Compute the standard observability Grammian. +C +C Solve for the Cholesky factor R of Q, Q = R'*R, +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C Ac2'*Q + Q*Ac2 + scaleo^2*Cc2'*Cc2 = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C Ac2'*Q*Ac2 - Q + scaleo^2*Cc2'*Cc2 = 0, +C +C where Cc2 is the matrix formed from the last NCS columns +C of Cc. +C +C Workspace: need NCS*(M + 5); +C prefer larger. + KU = 1 + KTAU = KU + M*NCS + KW = KTAU + NCS +C + CALL DLACPY( 'Full', M, NCS, CC(1,NCU1), LDCC, + $ DWORK(KU), M ) + CALL SB03OU( DISCR, .FALSE., NCS, M, AC(NCU1,NCU1), LDAC, + $ DWORK(KU), M, DWORK(KTAU), R, LDR, SCALEO, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 5 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF +C +C Finish if there are no weights. +C + IF( LSAME( WEIGHT, 'N' ) ) THEN + DWORK(1) = WRKOPT + RETURN + END IF + END IF +C + IF( FRWGHT ) THEN +C +C Allocate working storage for computing the weights. +C +C Real workspace: need MAX(1,NNC*NNC+2*NNC*MP+MP*(MP+4)); +C Integer workspace: need 2*MP. +C + KWA = 1 + KWB = KWA + NNC*NNC + KWC = KWB + NNC*MP + KWD = KWC + NNC*MP + KW = KWD + MP*MP + KL = KWD +C + IF( LEFTW ) THEN +C +C Build the extended matrices +C +C Ao = ( Ac+Bc*inv(R)*D*Cc Bc*inv(R)*C ), +C ( B*inv(Rt)*Cc A+B*Dc*inv(R)*C ) +C +C Co = ( -inv(R)*D*Cc -inv(R)*C ) , +C +C where R = I-D*Dc and Rt = I-Dc*D. +C -1 +C Method: Compute Ge = ( Ge11 Ge12 ), where Ge = ( K -Im ). +C ( Ge21 Ge22 ) ( -Ip G ) +C +C -1 +C Then Ge11 = -(I-G*K) *G . +C +C Construct first Ge = ( K -Im ) such that the stable part +C ( -Ip G ) +C of K is in the leading position (to avoid updating of +C QR factorization). +C + CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KWD), MP ) + CALL AB05PD( 'N', NCS, P, M, NCU, ONE, + $ AC(NCU1,NCU1), LDAC, BC(NCU1,1), LDBC, + $ CC(1,NCU1), LDCC, DWORK(KWD), MP, + $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, + $ NE, DWORK(KWA), NNC, DWORK(KWB), NNC, + $ DWORK(KWC), MP, DWORK(KWD), MP, IERR ) + CALL AB05QD( 'Over', NC, P, M, N, M, P, DWORK(KWA), NNC, + $ DWORK(KWB), NNC, DWORK(KWC), MP, DWORK(KWD), + $ MP, A, LDA, B, LDB, C, LDC, D, LDD, + $ NE, ME, PE, DWORK(KWA), NNC, DWORK(KWB), NNC, + $ DWORK(KWC), MP, DWORK(KWD), MP, IERR ) + CALL DLASET( 'Full', M, M, ZERO, -ONE, DWORK(KWD+MP*P), MP ) + CALL DLASET( 'Full', P, P, ZERO, -ONE, DWORK(KWD+M), MP ) +C + ELSE +C +C Build the extended matrices +C +C Ai = ( A+B*Dc*inv(R)*C B*inv(Rt)*Cc ) , +C ( Bc*inv(R)*C Ac+Bc*inv(R)*D*Cc ) +C +C Bi = ( B*Dc*inv(R) B*inv(Rt) ) , +C ( Bc*inv(R) Bc*D*inv(Rt) ) +C +C Ci = ( -inv(R)*C -inv(R)*D*Cc ) , where +C +C R = I-D*Dc and Rt = I-Dc*D. +C +C -1 +C Method: Compute Ge = ( Ge11 Ge12 ), where Ge = ( G -Ip ). +C ( Ge21 Ge22 ) ( -Im K ) +C +C -1 -1 +C Then Ge22 = -(I-G*K) *G and Ge21 = -(I-G*K) . +C +C Construct first Ge = ( G -Ip ). +C ( -Im K ) +C + CALL AB05QD( 'N', N, M, P, NC, P, M, A, LDA, B, LDB, C, LDC, + $ D, LDD, AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, + $ NE, ME, PE, DWORK(KWA), NNC, DWORK(KWB), NNC, + $ DWORK(KWC), MP, DWORK(KWD), MP, IERR ) + CALL DLASET( 'Full', P, P, ZERO, -ONE, DWORK(KWD+MP*M), MP ) + CALL DLASET( 'Full', M, M, ZERO, -ONE, DWORK(KWD+P), MP ) + END IF +C -1 +C Compute Ge = ( Ge11 Ge12 ). +C ( Ge21 Ge22 ) +C +C Additional real workspace: need 4*MP; +C Integer workspace: need 2*MP. +C + CALL AB07ND( NNC, MP, DWORK(KWA), NNC, DWORK(KWB), NNC, + $ DWORK(KWC), MP, DWORK(KWD), MP, RCOND, + $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C -1 ( A1 | B1 B2 ) +C Partition Ge = (--------------) and select appropriate +C ( C1 | D11 D12 ) +C ( C2 | D21 D22 ) +C +C pointers to matrices and column dimensions to define weights. +C + IF( RIGHTW ) THEN +C +C Define B2 for Ge22. +C + ME = M + KWB = KWB + NNC*P + ELSE IF( PERF ) THEN +C +C Define B1 and C2 for Ge21. +C + ME = P + KWC = KWC + M + END IF + END IF +C + IF( LEFTW .OR. PERF ) THEN +C +C Compute the frequency-weighted observability Grammian. +C +C Solve for the Cholesky factor Ro of Qo, Qo = Ro'*Ro, +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0. +C +C Additional workspace: need NNC*(NNC+MAX(NNC,P)+7); +C prefer larger. +C + LDU = MAX( NNC, P ) + KU = KL + KQ = KU + NNC*LDU + KR = KQ + NNC*NNC + KI = KR + NNC + KW = KI + NNC +C + JOBFAC = 'N' + CALL DLACPY( 'Full', P, NNC, DWORK(KWC), MP, DWORK(KU), LDU ) + CALL SB03OD( DICO, JOBFAC, 'No-transpose', NNC, P, + $ DWORK(KWA), NNC, DWORK(KQ), NNC, DWORK(KU), LDU, + $ SCALEO, DWORK(KR), DWORK(KI), DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.6 ) THEN + INFO = 2 + ELSE + INFO = 3 + END IF + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Partition Ro as Ro = ( R11 R12 ). +C ( 0 R22 ) +C + IF( LEFTW ) THEN +C +C R = R11 (NCS-by-NCS). +C + CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU), LDU, R, LDR ) + ELSE +C +C Compute R such that R'*R = R22'*R22 + R12'*R12, where +C R22 is NCS-by-NCS and R12 is (N+NCU)-by-NCS. +C R22 corresponds to the stable part of the controller. +C + NNCU = N + NCU + CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU+(LDU+1)*NNCU), LDU, + $ R, LDR ) + KTAU = KU + CALL MB04OD( 'Full', NCS, 0, NNCU, R, LDR, + $ DWORK(KU+LDU*NNCU), LDU, DUM, 1, DUM, 1, + $ DWORK(KTAU), DWORK(KW) ) +C + DO 10 J = 1, NCS + IF( R(J,J).LT.ZERO ) + $ CALL DSCAL( NCS-J+1, -ONE, R(J,J), LDR ) + 10 CONTINUE + END IF + END IF +C + IF( RIGHTW .OR. PERF ) THEN +C +C Compute the frequency-weighted controllability Grammian. +C +C Solve for the Cholesky factor Si of Pi, Pi = Si*Si', +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0. +C +C Additional workspace: need NNC*(NNC+MAX(NNC,P,M)+7); +C prefer larger. +C + KU = KL + KQ = KU + NNC*MAX( NNC, ME ) + KR = KQ + NNC*NNC + KI = KR + NNC + KW = KI + NNC +C + CALL DLACPY( 'Full', NNC, ME, DWORK(KWB), NNC, DWORK(KU), NNC ) + JOBFAC = 'F' + IF( RIGHTW ) JOBFAC = 'N' + CALL SB03OD( DICO, JOBFAC, 'Transpose', NNC, ME, + $ DWORK(KWA), NNC, DWORK(KQ), NNC, DWORK(KU), NNC, + $ SCALEC, DWORK(KR), DWORK(KI), DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.6 ) THEN + INFO = 2 + ELSE + INFO = 3 + END IF + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Partition Si as Si = ( S11 S12 ) with S22 NCS-by-NCS and +C ( 0 S22 ) +C set S = S22. +C + NNCU = N + NCU + CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU+(NNC+1)*NNCU), NNC, + $ S, LDS ) + END IF +C + KU = 1 + IF( LEFTW .OR. PERF ) THEN + IF( LSAME( JOBO, 'E' ) ) THEN +C +C Form Y = -Ac2'*(R'*R)-(R'*R)*Ac2 if DICO = 'C', or +C Y = -Ac2'*(R'*R)*Ac2+(R'*R) if DICO = 'D'. +C +C Workspace: need 2*NCS*NCS. +C + CALL DLACPY( 'Upper', NCS, NCS, R, LDR, DWORK(KU), NCS ) + CALL DLACPY( 'Full', NCS, NCS, AC(NCU1,NCU1), LDAC, + $ DWORK(KU+NCS*NCS), NCS ) + CALL MB01WD( DICO, 'Upper', 'No-transpose', 'Hessenberg', + $ NCS, -ONE, ZERO, R, LDR, DWORK(KU+NCS*NCS), + $ NCS, DWORK(KU), NCS, IERR ) +C +C Compute the eigendecomposition of Y as Y = Z*Sigma*Z'. +C + KW = KU + NCS + CALL DSYEV( 'Vectors', 'Upper', NCS, R, LDR, DWORK(KU), + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 4 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Partition Sigma = (Sigma1,Sigma2), such that +C Sigma1 <= 0, Sigma2 > 0. +C Partition correspondingly Z = [Z1 Z2]. +C + TOL = MAX( ABS( DWORK(KU) ), ABS( DWORK(KU+NCS-1) ) ) + $ * DLAMCH( 'Epsilon') +C _ +C Form Cc = [ sqrt(Sigma2)*Z2' ] +C + PCBAR = 0 + JJ = KU + DO 20 J = 1, NCS + IF( DWORK(JJ).GT.TOL ) THEN + CALL DSCAL( NCS, SQRT( DWORK(JJ) ), R(1,J), 1 ) + CALL DCOPY( NCS, R(1,J), 1, DWORK(KW+PCBAR), NCS ) + PCBAR = PCBAR + 1 + END IF + JJ = JJ + 1 + 20 CONTINUE +C +C Solve for the Cholesky factor R of Q, Q = R'*R, +C the continuous-time Lyapunov equation (if DICO = 'C') +C _ _ +C Ac2'*Q + Q*Ac2 + scaleo^2*Cc'*Cc = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C _ _ +C Ac2'*Q*Ac2 - Q + scaleo^2*Cc'*Cc = 0. +C +C Workspace: need NCS*(NCS + 6); +C prefer larger. +C + KU = KW + KTAU = KU + NCS*NCS + KW = KTAU + NCS +C + CALL SB03OU( DISCR, .FALSE., NCS, PCBAR, AC(NCU1,NCU1), + $ LDAC, DWORK(KU), NCS, DWORK(KTAU), R, LDR, T, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 5 + RETURN + END IF + SCALEO = SCALEO*T + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF +C + END IF +C + IF( RIGHTW .OR. PERF ) THEN + IF( LSAME( JOBC, 'E' ) ) THEN +C +C Form X = -A2c*(S*S')-(S*S')*Ac2' if DICO = 'C', or +C X = -Ac2*(S*S')*Ac2'+(S*S') if DICO = 'D'. +C +C Workspace: need 2*NCS*NCS. +C + CALL DLACPY( 'Upper', NCS, NCS, S, LDS, DWORK(KU), NCS ) + CALL DLACPY( 'Full', NCS, NCS, AC(NCU1,NCU1), LDAC, + $ DWORK(KU+NCS*NCS), NCS ) + CALL MB01WD( DICO, 'Upper', 'Transpose', 'Hessenberg', NCS, + $ -ONE, ZERO, S, LDS, DWORK(KU+NCS*NCS), NCS, + $ DWORK(KU), NCS, IERR ) +C +C Compute the eigendecomposition of X as X = Z*Sigma*Z'. +C + KW = KU + NCS + CALL DSYEV( 'Vectors', 'Upper', NCS, S, LDS, DWORK(KU), + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 4 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Partition Sigma = (Sigma1,Sigma2), such that +C Sigma1 =< 0, Sigma2 > 0. +C Partition correspondingly Z = [Z1 Z2]. +C + TOL = MAX( ABS( DWORK(KU) ), ABS( DWORK(KU+NCS-1) ) ) + $ * DLAMCH( 'Epsilon') +C _ +C Form Bc = [ Z2*sqrt(Sigma2) ] +C + MBBAR = 0 + I = KW + JJ = KU + DO 30 J = 1, NCS + IF( DWORK(JJ).GT.TOL ) THEN + MBBAR = MBBAR + 1 + CALL DSCAL( NCS, SQRT( DWORK(JJ) ), S(1,J), 1 ) + CALL DCOPY( NCS, S(1,J), 1, DWORK(I), 1 ) + I = I + NCS + END IF + JJ = JJ + 1 + 30 CONTINUE +C +C Solve for the Cholesky factor S of P, P = S*S', +C the continuous-time Lyapunov equation (if DICO = 'C') +C _ _ +C Ac2*P + P*Ac2' + scalec^2*Bc*Bc' = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C _ _ +C Ac2*P*Ac2' - P + scalec^2*Bc*Bc' = 0. +C +C Workspace: need maximum NCS*(NCS + 6); +C prefer larger. +C + KU = KW + KTAU = KU + MBBAR*NCS + KW = KTAU + NCS +C + CALL SB03OU( DISCR, .TRUE., NCS, MBBAR, AC(NCU1,NCU1), LDAC, + $ DWORK(KU), NCS, DWORK(KTAU), S, LDS, T, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 5 + RETURN + END IF + SCALEC = SCALEC*T + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF +C + END IF +C +C Save optimal workspace. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB16AY *** + END diff --git a/mex/sources/libslicot/SB16BD.f b/mex/sources/libslicot/SB16BD.f new file mode 100644 index 000000000..0141f1d0c --- /dev/null +++ b/mex/sources/libslicot/SB16BD.f @@ -0,0 +1,652 @@ + SUBROUTINE SB16BD( DICO, JOBD, JOBMR, JOBCF, EQUIL, ORDSEL, + $ N, M, P, NCR, A, LDA, B, LDB, C, LDC, D, LDD, + $ F, LDF, G, LDG, DC, LDDC, HSV, TOL1, TOL2, + $ IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute, for a given open-loop model (A,B,C,D), and for +C given state feedback gain F and full observer gain G, +C such that A+B*F and A+G*C are stable, a reduced order +C controller model (Ac,Bc,Cc,Dc) using a coprime factorization +C based controller reduction approach. For reduction, +C either the square-root or the balancing-free square-root +C versions of the Balance & Truncate (B&T) or Singular Perturbation +C Approximation (SPA) model reduction methods are used in +C conjunction with stable coprime factorization techniques. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the open-loop system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears +C in the given state space model: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C JOBMR CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root B&T method; +C = 'F': use the balancing-free square-root B&T method; +C = 'S': use the square-root SPA method; +C = 'P': use the balancing-free square-root SPA method. +C +C JOBCF CHARACTER*1 +C Specifies whether left or right coprime factorization is +C to be used as follows: +C = 'L': use left coprime factorization; +C = 'R': use right coprime factorization. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to perform a +C preliminary equilibration before performing +C order reduction as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting controller order NCR is fixed; +C = 'A': the resulting controller order NCR is +C automatically determined on basis of the given +C tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the open-loop state-space representation, +C i.e., the order of the matrix A. N >= 0. +C N also represents the order of the original state-feedback +C controller. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NCR (input/output) INTEGER +C On entry with ORDSEL = 'F', NCR is the desired order of +C the resulting reduced order controller. 0 <= NCR <= N. +C On exit, if INFO = 0, NCR is the order of the resulting +C reduced order controller. NCR is set as follows: +C if ORDSEL = 'F', NCR is equal to MIN(NCR,NMIN), where NCR +C is the desired order on entry, and NMIN is the order of a +C minimal realization of an extended system Ge (see METHOD); +C NMIN is determined as the number of +C Hankel singular values greater than N*EPS*HNORM(Ge), +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the +C extended system (computed in HSV(1)); +C if ORDSEL = 'A', NCR is equal to the number of Hankel +C singular values greater than MAX(TOL1,N*EPS*HNORM(Ge)). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, if INFO = 0, the leading NCR-by-NCR part of this +C array contains the state dynamics matrix Ac of the reduced +C controller. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must +C contain the original input/state matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must +C contain the original state/output matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C If JOBD = 'D', the leading P-by-M part of this +C array must contain the system direct input/output +C transmission matrix D. +C The array D is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P), if JOBD = 'D'; +C LDD >= 1, if JOBD = 'Z'. +C +C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) +C On entry, the leading M-by-N part of this array must +C contain a stabilizing state feedback matrix. +C On exit, if INFO = 0, the leading M-by-NCR part of this +C array contains the state/output matrix Cc of the reduced +C controller. +C +C LDF INTEGER +C The leading dimension of array F. LDF >= MAX(1,M). +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,P) +C On entry, the leading N-by-P part of this array must +C contain a stabilizing observer gain matrix. +C On exit, if INFO = 0, the leading NCR-by-P part of this +C array contains the input/state matrix Bc of the reduced +C controller. +C +C LDG INTEGER +C The leading dimension of array G. LDG >= MAX(1,N). +C +C DC (output) DOUBLE PRECISION array, dimension (LDDC,P) +C If INFO = 0, the leading M-by-P part of this array +C contains the input/output matrix Dc of the reduced +C controller. +C +C LDDC INTEGER +C The leading dimension of array DC. LDDC >= MAX(1,M). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the N Hankel singular values +C of the extended system ordered decreasingly (see METHOD). +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of the reduced extended system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(Ge), where c is a constant in the +C interval [0.00001,0.001], and HNORM(Ge) is the +C Hankel norm of the extended system (computed in HSV(1)). +C The value TOL1 = N*EPS*HNORM(Ge) is used by default if +C TOL1 <= 0 on entry, where EPS is the machine precision +C (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the coprime factorization controller +C (see METHOD). The recommended value is +C TOL2 = N*EPS*HNORM(Ge) (see METHOD). +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = 0, if ORDSEL = 'F' and NCR = N. +C Otherwise, +C LIWORK = MAX(PM,M), if JOBCF = 'L', +C LIWORK = MAX(PM,P), if JOBCF = 'R', where +C PM = 0, if JOBMR = 'B', +C PM = N, if JOBMR = 'F', +C PM = MAX(1,2*N), if JOBMR = 'S' or 'P'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= P*N, if ORDSEL = 'F' and NCR = N. Otherwise, +C LDWORK >= (N+M)*(M+P) + MAX(LWR,4*M), if JOBCF = 'L', +C LDWORK >= (N+P)*(M+P) + MAX(LWR,4*P), if JOBCF = 'R', +C where LWR = MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NCR is +C greater than the order of a minimal +C realization of the controller. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A+G*C to a real Schur form +C failed; +C = 2: the matrix A+G*C is not stable (if DICO = 'C'), +C or not convergent (if DICO = 'D'); +C = 3: the computation of Hankel singular values failed; +C = 4: the reduction of A+B*F to a real Schur form +C failed; +C = 5: the matrix A+B*F is not stable (if DICO = 'C'), +C or not convergent (if DICO = 'D'). +C +C METHOD +C +C Let be the linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t), (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system, and let Go(d) be the open-loop +C transfer-function matrix +C -1 +C Go(d) = C*(d*I-A) *B + D . +C +C Let F and G be the state feedback and observer gain matrices, +C respectively, chosen so that A+B*F and A+G*C are stable matrices. +C The controller has a transfer-function matrix K(d) given by +C -1 +C K(d) = F*(d*I-A-B*F-G*C-G*D*F) *G . +C +C The closed-loop transfer-function matrix is given by +C -1 +C Gcl(d) = Go(d)(I+K(d)Go(d)) . +C +C K(d) can be expressed as a left coprime factorization (LCF), +C -1 +C K(d) = M_left(d) *N_left(d) , +C +C or as a right coprime factorization (RCF), +C -1 +C K(d) = N_right(d)*M_right(d) , +C +C where M_left(d), N_left(d), N_right(d), and M_right(d) are +C stable transfer-function matrices. +C +C The subroutine SB16BD determines the matrices of a reduced +C controller +C +C d[z(t)] = Ac*z(t) + Bc*y(t) +C u(t) = Cc*z(t) + Dc*y(t), (2) +C +C with the transfer-function matrix Kr as follows: +C +C (1) If JOBCF = 'L', the extended system +C Ge(d) = [ N_left(d) M_left(d) ] is reduced to +C Ger(d) = [ N_leftr(d) M_leftr(d) ] by using either the +C B&T or SPA methods. The reduced order controller Kr(d) +C is computed as +C -1 +C Kr(d) = M_leftr(d) *N_leftr(d) ; +C +C (2) If JOBCF = 'R', the extended system +C Ge(d) = [ N_right(d) ] is reduced to +C [ M_right(d) ] +C Ger(d) = [ N_rightr(d) ] by using either the +C [ M_rightr(d) ] +C B&T or SPA methods. The reduced order controller Kr(d) +C is computed as +C -1 +C Kr(d) = N_rightr(d)* M_rightr(d) . +C +C If ORDSEL = 'A', the order of the controller is determined by +C computing the number of Hankel singular values greater than +C the given tolerance TOL1. The Hankel singular values are +C the square roots of the eigenvalues of the product of +C the controllability and observability Grammians of the +C extended system Ge. +C +C If JOBMR = 'B', the square-root B&T method of [1] is used. +C +C If JOBMR = 'F', the balancing-free square-root version of the +C B&T method [1] is used. +C +C If JOBMR = 'S', the square-root version of the SPA method [2,3] +C is used. +C +C If JOBMR = 'P', the balancing-free square-root version of the +C SPA method [2,3] is used. +C +C REFERENCES +C +C [1] Tombs, M.S. and Postlethwaite, I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [2] Varga, A. +C Efficient minimal realization procedure based on balancing. +C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, +C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2, +C pp. 42-46, 1991. +C +C [3] Varga, A. +C Coprime factors model reduction method based on square-root +C balancing-free techniques. +C System Analysis, Modelling and Simulation, Vol. 11, +C pp. 303-311, 1993. +C +C [4] Liu, Y., Anderson, B.D.O. and Ly, O.L. +C Coprime factorization controller reduction with Bezout +C identity induced frequency weighting. +C Automatica, vol. 26, pp. 233-249, 1990. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. +C D. Sima, University of Bucharest, August 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. +C +C REVISIONS +C +C A. Varga, Australian National University, Canberra, November 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, +C Aug. 2001. +C +C KEYWORDS +C +C Balancing, controller reduction, coprime factorization, +C minimal realization, multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOBCF, JOBD, JOBMR, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDDC, + $ LDF, LDG, LDWORK, M, N, NCR, P + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DC(LDDC,*), DWORK(*), F(LDF,*), G(LDG,*), HSV(*) +C .. Local Scalars .. + CHARACTER JOB + LOGICAL BAL, BTA, DISCR, FIXORD, LEFT, LEQUIL, SPA, + $ WITHD + INTEGER KBE, KCE, KDE, KW, LDBE, LDCE, LDDE, LW1, LW2, + $ LWR, MAXMP, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB09AD, AB09BD, DGEMM, DLACPY, DLASET, SB08GD, + $ SB08HD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + WITHD = LSAME( JOBD, 'D' ) + BTA = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'F' ) + SPA = LSAME( JOBMR, 'S' ) .OR. LSAME( JOBMR, 'P' ) + BAL = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'S' ) + LEFT = LSAME( JOBCF, 'L' ) + LEQUIL = LSAME( EQUIL, 'S' ) + FIXORD = LSAME( ORDSEL, 'F' ) + MAXMP = MAX( M, P ) +C + LWR = MAX( 1, N*( 2*N + MAX( N, M+P ) + 5 ) + ( N*(N+1) )/2 ) + LW1 = (N+M)*(M+P) + MAX( LWR, 4*M ) + LW2 = (N+P)*(M+P) + MAX( LWR, 4*P ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT. ( LEQUIL .OR. LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -5 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -6 + ELSE IF( N.LT.0 ) THEN + INFO = -7 + ELSE IF( M.LT.0 ) THEN + INFO = -8 + ELSE IF( P.LT.0 ) THEN + INFO = -9 + ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.N ) ) THEN + INFO = -10 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN + INFO = -18 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -20 + ELSE IF( LDG.LT.MAX( 1, N ) ) THEN + INFO = -22 + ELSE IF( LDDC.LT.MAX( 1, M ) ) THEN + INFO = -24 + ELSE IF( .NOT.FIXORD .AND. TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN + INFO = -27 + ELSE IF( ( ( .NOT.FIXORD .OR. NCR.LT.N ) .AND. + $ ( ( LEFT .AND. LDWORK.LT.LW1 ) ) .OR. + $ ( .NOT.LEFT .AND. LDWORK.LT.LW2 ) ) .OR. + $ ( FIXORD .AND. NCR.EQ.N .AND. LDWORK.LT.P*N ) ) THEN + INFO = -30 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB16BD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 .OR. + $ ( FIXORD .AND. BTA .AND. NCR.EQ.0 ) ) THEN + NCR = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( NCR.EQ.N ) THEN +C +C Form the controller state matrix, +C Ac = A + B*F + G*C + G*D*F = A + B*F + G*(C+D*F) . +C Real workspace: need P*N. +C Integer workspace: need 0. +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P ) + IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, N, M, + $ ONE, D, LDD, F, LDF, ONE, + $ DWORK, P ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, P, ONE, G, + $ LDG, DWORK, P, ONE, A, LDA ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B, + $ LDB, F, LDF, ONE, A, LDA ) +C + DWORK(1) = P*N + RETURN + END IF +C + IF( BAL ) THEN + JOB = 'B' + ELSE + JOB = 'N' + END IF +C +C Reduce the coprime factors. +C + IF( LEFT ) THEN +C +C Form Ge(d) = [ N_left(d) M_left(d) ] as +C +C ( A+G*C | G B+GD ) +C (------------------) +C ( F | 0 I ) +C +C Real workspace: need (N+M)*(M+P). +C Integer workspace: need 0. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, P, ONE, G, + $ LDG, C, LDC, ONE, A, LDA ) + KBE = 1 + KDE = KBE + N*(P+M) + LDBE = MAX( 1, N ) + LDDE = M + CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KBE), LDBE ) + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KBE+N*P), LDBE ) + IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, P, + $ ONE, G, LDG, D, LDD, ONE, + $ DWORK(KBE+N*P), LDBE ) + CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KDE), LDDE ) + CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK(KDE+M*P), LDDE ) +C +C Compute the reduced coprime factors, +C Ger(d) = [ N_leftr(d) M_leftr(d) ] , +C by using either the B&T or SPA methods. +C +C Real workspace: need (N+M)*(M+P) + +C MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2). +C Integer workspace: need 0, if JOBMR = 'B', +C N, if JOBMR = 'F', and +C MAX(1,2*N) if JOBMR = 'S' or 'P'. +C + KW = KDE + M*(P+M) + IF( BTA ) THEN + CALL AB09AD( DICO, JOB, EQUIL, ORDSEL, N, M+P, M, NCR, A, + $ LDA, DWORK(KBE), LDBE, F, LDF, HSV, TOL1, + $ IWORK, DWORK(KW), LDWORK-KW+1, IWARN, INFO ) + ELSE + CALL AB09BD( DICO, JOB, EQUIL, ORDSEL, N, M+P, M, NCR, A, + $ LDA, DWORK(KBE), LDBE, F, LDF, DWORK(KDE), + $ LDDE, HSV, TOL1, TOL2, IWORK, DWORK(KW), + $ LDWORK-KW+1, IWARN, INFO ) + END IF + IF( INFO.NE.0 ) + $ RETURN +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Compute the reduced order controller, +C -1 +C Kr(d) = M_leftr(d) *N_leftr(d). +C +C Real workspace: need (N+M)*(M+P) + MAX(1,4*M). +C Integer workspace: need M. +C + CALL SB08GD( NCR, P, M, A, LDA, DWORK(KBE), LDBE, F, LDF, + $ DWORK(KDE), LDDE, DWORK(KBE+N*P), LDBE, + $ DWORK(KDE+M*P), LDDE, IWORK, DWORK(KW), INFO ) +C +C Copy the reduced system matrices Bc and Dc. +C + CALL DLACPY( 'Full', NCR, P, DWORK(KBE), LDBE, G, LDG ) + CALL DLACPY( 'Full', M, P, DWORK(KDE), LDDE, DC, LDDC ) +C + ELSE +C +C Form Ge(d) = [ N_right(d) ] +C [ M_right(d) ] as +C +C ( A+B*F | G ) +C (-----------) +C ( F | 0 ) +C ( C+D*F | I ) +C +C Real workspace: need (N+P)*(M+P). +C Integer workspace: need 0. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B, + $ LDB, F, LDF, ONE, A, LDA ) + KCE = 1 + KDE = KCE + N*(P+M) + LDCE = M+P + LDDE = LDCE + CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KCE), LDCE ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KCE+M), LDCE ) + IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, N, M, + $ ONE, D, LDD, F, LDF, ONE, + $ DWORK(KCE+M), LDCE ) + CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KDE), LDDE ) + CALL DLASET( 'Full', P, P, ZERO, ONE, DWORK(KDE+M), LDDE ) +C +C Compute the reduced coprime factors, +C Ger(d) = [ N_rightr(d) ] +C [ M_rightr(d) ], +C by using either the B&T or SPA methods. +C +C Real workspace: need (N+P)*(M+P) + +C MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2). +C Integer workspace: need 0, if JOBMR = 'B', +C N, if JOBMR = 'F', and +C MAX(1,2*N) if JOBMR = 'S' or 'P'. +C + KW = KDE + P*(P+M) + IF( BTA ) THEN + CALL AB09AD( DICO, JOB, EQUIL, ORDSEL, N, P, M+P, NCR, A, + $ LDA, G, LDG, DWORK(KCE), LDCE, HSV, TOL1, + $ IWORK, DWORK(KW), LDWORK-KW+1, IWARN, INFO ) + ELSE + CALL AB09BD( DICO, JOB, EQUIL, ORDSEL, N, P, M+P, NCR, A, + $ LDA, G, LDG, DWORK(KCE), LDCE, DWORK(KDE), + $ LDDE, HSV, TOL1, TOL2, IWORK, DWORK(KW), + $ LDWORK-KW+1, IWARN, INFO ) + END IF + IF( INFO.NE.0 ) THEN + IF( INFO.NE.3 ) INFO = INFO + 3 + RETURN + END IF +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Compute the reduced order controller, +C -1 +C Kr(d) = N_rightr(d)*M_rightr(d) . +C +C Real workspace: need (N+P)*(M+P) + MAX(1,4*P). +C Integer workspace: need P. +C + CALL SB08HD( NCR, P, M, A, LDA, G, LDG, DWORK(KCE), LDCE, + $ DWORK(KDE), LDDE, DWORK(KCE+M), LDCE, + $ DWORK(KDE+M), LDDE, IWORK, DWORK(KW), INFO ) +C +C Copy the reduced system matrices Cc and Dc. +C + CALL DLACPY( 'Full', M, NCR, DWORK(KCE), LDCE, F, LDF ) + CALL DLACPY( 'Full', M, P, DWORK(KDE), LDDE, DC, LDDC ) +C + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB16BD *** + END diff --git a/mex/sources/libslicot/SB16CD.f b/mex/sources/libslicot/SB16CD.f new file mode 100644 index 000000000..677a916d7 --- /dev/null +++ b/mex/sources/libslicot/SB16CD.f @@ -0,0 +1,526 @@ + SUBROUTINE SB16CD( DICO, JOBD, JOBMR, JOBCF, ORDSEL, N, M, P, NCR, + $ A, LDA, B, LDB, C, LDC, D, LDD, F, LDF, G, LDG, + $ HSV, TOL, IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute, for a given open-loop model (A,B,C,D), and for +C given state feedback gain F and full observer gain G, +C such that A+B*F and A+G*C are stable, a reduced order +C controller model (Ac,Bc,Cc) using a coprime factorization +C based controller reduction approach. For reduction of +C coprime factors, a stability enforcing frequency-weighted +C model reduction is performed using either the square-root or +C the balancing-free square-root versions of the Balance & Truncate +C (B&T) model reduction method. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the open-loop system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears +C in the given state space model, as follows: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C JOBMR CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root B&T method; +C = 'F': use the balancing-free square-root B&T method. +C +C JOBCF CHARACTER*1 +C Specifies whether left or right coprime factorization +C of the controller is to be used as follows: +C = 'L': use left coprime factorization; +C = 'R': use right coprime factorization. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting controller order NCR is fixed; +C = 'A': the resulting controller order NCR is +C automatically determined on basis of the given +C tolerance TOL. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C N also represents the order of the original state-feedback +C controller. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NCR (input/output) INTEGER +C On entry with ORDSEL = 'F', NCR is the desired order of +C the resulting reduced order controller. 0 <= NCR <= N. +C On exit, if INFO = 0, NCR is the order of the resulting +C reduced order controller. NCR is set as follows: +C if ORDSEL = 'F', NCR is equal to MIN(NCR,NCRMIN), where +C NCR is the desired order on entry, and NCRMIN is the +C number of Hankel-singular values greater than N*EPS*S1, +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH) and S1 is the largest Hankel singular +C value (computed in HSV(1)); NCR can be further reduced +C to ensure HSV(NCR) > HSV(NCR+1); +C if ORDSEL = 'A', NCR is equal to the number of Hankel +C singular values greater than MAX(TOL,N*EPS*S1). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, if INFO = 0, the leading NCR-by-NCR part of this +C array contains the state dynamics matrix Ac of the reduced +C controller. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the open-loop system input/state matrix B. +C On exit, this array is overwritten with a NCR-by-M +C B&T approximation of the matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the open-loop system state/output matrix C. +C On exit, this array is overwritten with a P-by-NCR +C B&T approximation of the matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, if JOBD = 'D', the leading P-by-M part of this +C array must contain the system direct input/output +C transmission matrix D. +C The array D is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P), if JOBD = 'D'; +C LDD >= 1, if JOBD = 'Z'. +C +C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) +C On entry, the leading M-by-N part of this array must +C contain a stabilizing state feedback matrix. +C On exit, if INFO = 0, the leading M-by-NCR part of this +C array contains the output/state matrix Cc of the reduced +C controller. +C +C LDF INTEGER +C The leading dimension of array F. LDF >= MAX(1,M). +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,P) +C On entry, the leading N-by-P part of this array must +C contain a stabilizing observer gain matrix. +C On exit, if INFO = 0, the leading NCR-by-P part of this +C array contains the input/state matrix Bc of the reduced +C controller. +C +C LDG INTEGER +C The leading dimension of array G. LDG >= MAX(1,N). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, HSV contains the N frequency-weighted +C Hankel singular values ordered decreasingly (see METHOD). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If ORDSEL = 'A', TOL contains the tolerance for +C determining the order of reduced controller. +C The recommended value is TOL = c*S1, where c is a constant +C in the interval [0.00001,0.001], and S1 is the largest +C Hankel singular value (computed in HSV(1)). +C The value TOL = N*EPS*S1 is used by default if +C TOL <= 0 on entry, where EPS is the machine precision +C (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL is ignored. +C +C Workspace +C +C IWORK INTEGER array, dimension LIWORK, where +C LIWORK = 0, if JOBMR = 'B'; +C LIWORK = N, if JOBMR = 'F'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 2*N*N + MAX( 1, 2*N*N + 5*N, N*MAX(M,P), +C N*(N + MAX(N,MP) + MIN(N,MP) + 6)), +C where MP = M, if JOBCF = 'L'; +C MP = P, if JOBCF = 'R'. +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NCR is +C greater than the order of a minimal realization +C of the controller; +C = 2: with ORDSEL = 'F', the selected order NCR +C corresponds to repeated singular values, which are +C neither all included nor all excluded from the +C reduced controller. In this case, the resulting NCR +C is set automatically to the largest value such that +C HSV(NCR) > HSV(NCR+1). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: eigenvalue computation failure; +C = 2: the matrix A+G*C is not stable; +C = 3: the matrix A+B*F is not stable; +C = 4: the Lyapunov equation for computing the +C observability Grammian is (nearly) singular; +C = 5: the Lyapunov equation for computing the +C controllability Grammian is (nearly) singular; +C = 6: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t), (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system, and let Go(d) be the open-loop +C transfer-function matrix +C -1 +C Go(d) = C*(d*I-A) *B + D . +C +C Let F and G be the state feedback and observer gain matrices, +C respectively, chosen such that A+BF and A+GC are stable matrices. +C The controller has a transfer-function matrix K(d) given by +C -1 +C K(d) = F*(d*I-A-B*F-G*C-G*D*F) *G . +C +C The closed-loop transfer function matrix is given by +C -1 +C Gcl(d) = Go(d)(I+K(d)Go(d)) . +C +C K(d) can be expressed as a left coprime factorization (LCF) +C -1 +C K(d) = M_left(d) *N_left(d), +C +C or as a right coprime factorization (RCF) +C -1 +C K(d) = N_right(d)*M_right(d) , +C +C where M_left(d), N_left(d), N_right(d), and M_right(d) are +C stable transfer-function matrices. +C +C The subroutine SB16CD determines the matrices of a reduced +C controller +C +C d[z(t)] = Ac*z(t) + Bc*y(t) +C u(t) = Cc*z(t), (2) +C +C with the transfer-function matrix Kr, using the following +C stability enforcing approach proposed in [1]: +C +C (1) If JOBCF = 'L', the frequency-weighted approximation problem +C is solved +C +C min||[M_left(d)-M_leftr(d) N_left(d)-N_leftr(d)][-Y(d)]|| , +C [ X(d)] +C where +C -1 +C G(d) = Y(d)*X(d) +C +C is a RCF of the open-loop system transfer-function matrix. +C The B&T model reduction technique is used in conjunction +C with the method proposed in [1]. +C +C (2) If JOBCF = 'R', the frequency-weighted approximation problem +C is solved +C +C min || [ -U(d) V(d) ] [ N_right(d)-N_rightr(d) ] || , +C [ M_right(d)-M_rightr(d) ] +C where +C -1 +C G(d) = V(d) *U(d) +C +C is a LCF of the open-loop system transfer-function matrix. +C The B&T model reduction technique is used in conjunction +C with the method proposed in [1]. +C +C If ORDSEL = 'A', the order of the controller is determined by +C computing the number of Hankel singular values greater than +C the given tolerance TOL. The Hankel singular values are +C the square roots of the eigenvalues of the product of +C two frequency-weighted Grammians P and Q, defined as follows. +C +C If JOBCF = 'L', then P is the controllability Grammian of a system +C of the form (A+BF,B,*,*), and Q is the observability Grammian of a +C system of the form (A+GC,*,F,*). This choice corresponds to an +C input frequency-weighted order reduction of left coprime +C factors [1]. +C +C If JOBCF = 'R', then P is the controllability Grammian of a system +C of the form (A+BF,G,*,*), and Q is the observability Grammian of a +C system of the form (A+GC,*,C,*). This choice corresponds to an +C output frequency-weighted order reduction of right coprime +C factors [1]. +C +C For the computation of truncation matrices, the B&T approach +C is used in conjunction with accuracy enhancing techniques. +C If JOBMR = 'B', the square-root B&T method of [2,4] is used. +C If JOBMR = 'F', the balancing-free square-root version of the +C B&T method [3,4] is used. +C +C REFERENCES +C +C [1] Liu, Y., Anderson, B.D.O. and Ly, O.L. +C Coprime factorization controller reduction with Bezout +C identity induced frequency weighting. +C Automatica, vol. 26, pp. 233-249, 1990. +C +C [2] Tombs, M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [3] Varga, A. +C Efficient minimal realization procedure based on balancing. +C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, +C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2, +C pp. 42-46, 1991. +C +C [4] Varga, A. +C Coprime factors model reduction method based on square-root +C balancing-free techniques. +C System Analysis, Modelling and Simulation, Vol. 11, +C pp. 303-311, 1993. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, October 2000. +C D. Sima, University of Bucharest, October 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000. +C +C REVISIONS +C +C A. Varga, Australian National University, Canberra, November 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2001. +C +C KEYWORDS +C +C Controller reduction, coprime factorization, frequency weighting, +C multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBCF, JOBD, JOBMR, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, + $ LDF, LDG, LDWORK, M, N, NCR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), F(LDF,*), G(LDG,*), HSV(*) +C .. Local Scalars .. + LOGICAL BAL, DISCR, FIXORD, LEFT, WITHD + INTEGER IERR, KT, KTI, KW, LW, MP, NMR, WRKOPT + DOUBLE PRECISION SCALEC, SCALEO +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB09IX, DGEMM, DLACPY, SB16CY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + WITHD = LSAME( JOBD, 'D' ) + BAL = LSAME( JOBMR, 'B' ) + LEFT = LSAME( JOBCF, 'L' ) + FIXORD = LSAME( ORDSEL, 'F' ) + IF( LEFT ) THEN + MP = M + ELSE + MP = P + END IF + LW = 2*N*N + MAX( 1, 2*N*N + 5*N, N*MAX( M, P ), + $ N*( N + MAX( N, MP ) + MIN( N, MP ) + 6 ) ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( BAL .OR. LSAME( JOBMR, 'F' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( M.LT.0 ) THEN + INFO = -7 + ELSE IF( P.LT.0 ) THEN + INFO = -8 + ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.N ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN + INFO = -17 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -19 + ELSE IF( LDG.LT.MAX( 1, N ) ) THEN + INFO = -21 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -26 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB16CD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 .OR. + $ ( FIXORD .AND. NCR.EQ.0 ) ) THEN + NCR = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Allocate working storage. +C + KT = 1 + KTI = KT + N*N + KW = KTI + N*N +C +C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors Su and Ru +C of the frequency-weighted controllability and observability +C Grammians, respectively. +C +C Workspace: need 2*N*N + MAX(1, N*(N + MAX(N,M) + MIN(N,M) + 6)), +C if JOBCF = 'L'; +C 2*N*N + MAX(1, N*(N + MAX(N,P) + MIN(N,P) + 6)), +C if JOBCF = 'R'. +C prefer larger. +C + CALL SB16CY( DICO, JOBCF, N, M, P, A, LDA, B, LDB, C, LDC, + $ F, LDF, G, LDG, SCALEC, SCALEO, DWORK(KTI), N, + $ DWORK(KT), N, DWORK(KW), LDWORK-KW+1, INFO ) +C + IF( INFO.NE.0 ) + $ RETURN + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Compute a B&T approximation (Ar,Br,Cr) of (A,B,C) and +C the corresponding truncation matrices TI and T. +C +C Real workspace: need 2*N*N + MAX( 1, 2*N*N+5*N, N*MAX(M,P) ); +C prefer larger. +C Integer workspace: 0, if JOBMR = 'B'; +C N, if JOBMR = 'F'. +C + CALL AB09IX( DICO, JOBMR, 'NotSchur', ORDSEL, N, M, P, NCR, + $ SCALEC, SCALEO, A, LDA, B, LDB, C, LDC, D, LDD, + $ DWORK(KTI), N, DWORK(KT), N, NMR, HSV, TOL, TOL, + $ IWORK, DWORK(KW), LDWORK-KW+1, IWARN, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 6 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Compute reduced gains Bc = Gr = TI*G and Cc = Fr = F*T. +C Workspace: need N*(2*N+MAX(M,P)). +C + CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KW), N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, P, N, ONE, + $ DWORK(KTI), N, DWORK(KW), N, ZERO, G, LDG ) +C + CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KW), M ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, NCR, N, ONE, + $ DWORK(KW), M, DWORK(KT), N, ZERO, F, LDF ) +C +C Form the reduced controller state matrix, +C Ac = Ar + Br*Fr + Gr*Cr + Gr*D*Fr = Ar + Br*Fr + Gr*(Cr+D*Fr) . +C +C Workspace: need P*N. +C + CALL DLACPY( 'Full', P, NCR, C, LDC, DWORK, P ) + IF( WITHD) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NCR, M, + $ ONE, D, LDD, F, LDF, ONE, DWORK, P ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, NCR, P, ONE, G, + $ LDG, DWORK, P, ONE, A, LDA ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, NCR, M, ONE, B, + $ LDB, F, LDF, ONE, A, LDA ) +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB16CD *** + END diff --git a/mex/sources/libslicot/SB16CY.f b/mex/sources/libslicot/SB16CY.f new file mode 100644 index 000000000..34ebaae79 --- /dev/null +++ b/mex/sources/libslicot/SB16CY.f @@ -0,0 +1,409 @@ + SUBROUTINE SB16CY( DICO, JOBCF, N, M, P, A, LDA, B, LDB, C, LDC, + $ F, LDF, G, LDG, SCALEC, SCALEO, S, LDS, R, LDR, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute, for a given open-loop model (A,B,C,0), and for +C given state feedback gain F and full observer gain G, +C such that A+B*F and A+G*C are stable, the Cholesky factors +C Su and Ru of a controllability Grammian P = Su*Su' and of +C an observability Grammian Q = Ru'*Ru corresponding to a +C frequency-weighted model reduction of the left or right coprime +C factors of the state-feedback controller. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the open-loop system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBCF CHARACTER*1 +C Specifies whether a left or right coprime factorization +C of the state-feedback controller is to be used as follows: +C = 'L': use a left coprime factorization; +C = 'R': use a right coprime factorization. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the open-loop state-space representation, +C i.e., the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the open-loop system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B of the open-loop system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C of the open-loop system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C F (input) DOUBLE PRECISION array, dimension (LDF,N) +C The leading M-by-N part of this array must contain a +C stabilizing state feedback matrix. +C +C LDF INTEGER +C The leading dimension of array F. LDF >= MAX(1,M). +C +C G (input) DOUBLE PRECISION array, dimension (LDG,P) +C The leading N-by-P part of this array must contain a +C stabilizing observer gain matrix. +C +C LDG INTEGER +C The leading dimension of array G. LDG >= MAX(1,N). +C +C SCALEC (output) DOUBLE PRECISION +C Scaling factor for the controllability Grammian. +C See METHOD. +C +C SCALEO (output) DOUBLE PRECISION +C Scaling factor for the observability Grammian. +C See METHOD. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,N) +C The leading N-by-N upper triangular part of this array +C contains the Cholesky factor Su of frequency-weighted +C cotrollability Grammian P = Su*Su'. See METHOD. +C +C LDS INTEGER +C The leading dimension of the array S. LDS >= MAX(1,N). +C +C R (output) DOUBLE PRECISION array, dimension (LDR,N) +C The leading N-by-N upper triangular part of this array +C contains the Cholesky factor Ru of the frequency-weighted +C observability Grammian Q = Ru'*Ru. See METHOD. +C +C LDR INTEGER +C The leading dimension of the array R. LDR >= MAX(1,N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N*(N + MAX(N,M) + MIN(N,M) + 6)), +C if JOBCF = 'L'; +C LDWORK >= MAX(1, N*(N + MAX(N,P) + MIN(N,P) + 6)), +C if JOBCF = 'R'. +C For optimum performance LDWORK should be larger. +C An upper bound for both cases is +C LDWORK >= MAX(1, N*(N + MAX(N,M,P) + 7)). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: eigenvalue computation failure; +C = 2: the matrix A+G*C is not stable; +C = 3: the matrix A+B*F is not stable; +C = 4: the Lyapunov equation for computing the +C observability Grammian is (nearly) singular; +C = 5: the Lyapunov equation for computing the +C controllability Grammian is (nearly) singular. +C +C METHOD +C +C In accordance with the type of the coprime factorization +C of the controller (left or right), the Cholesky factors Su and Ru +C of the frequency-weighted controllability Grammian P = Su*Su' and +C of the frequency-weighted observability Grammian Q = Ru'*Ru are +C computed by solving appropriate Lyapunov or Stein equations [1]. +C +C If JOBCF = 'L' and DICO = 'C', P and Q are computed as the +C solutions of the following Lyapunov equations: +C +C (A+B*F)*P + P*(A+B*F)' + scalec^2*B*B' = 0, (1) +C +C (A+G*C)'*Q + Q*(A+G*C) + scaleo^2*F'*F = 0. (2) +C +C If JOBCF = 'L' and DICO = 'D', P and Q are computed as the +C solutions of the following Stein equations: +C +C (A+B*F)*P*(A+B*F)' - P + scalec^2*B*B' = 0, (3) +C +C (A+G*C)'*Q*(A+G*C) - Q + scaleo^2*F'*F = 0. (4) +C +C If JOBCF = 'R' and DICO = 'C', P and Q are computed as the +C solutions of the following Lyapunov equations: +C +C (A+B*F)*P + P*(A+B*F)' + scalec^2*G*G' = 0, (5) +C +C (A+G*C)'*Q + Q*(A+G*C) + scaleo^2*C'*C = 0. (6) +C +C If JOBCF = 'R' and DICO = 'D', P and Q are computed as the +C solutions of the following Stein equations: +C +C (A+B*F)*P*(A+B*F)' - P + scalec^2*G*G' = 0, (7) +C +C (A+G*C)'*Q*(A+G*C) - Q + scaleo^2*C'*C = 0. (8) +C +C REFERENCES +C +C [1] Liu, Y., Anderson, B.D.O. and Ly, O.L. +C Coprime factorization controller reduction with Bezout +C identity induced frequency weighting. +C Automatica, vol. 26, pp. 233-249, 1990. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, October 2000. +C D. Sima, University of Bucharest, October 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000. +C +C REVISIONS +C +C A. Varga, Australian National University, Canberra, November 2000. +C +C KEYWORDS +C +C Controller reduction, frequency weighting, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBCF + INTEGER INFO, LDA, LDB, LDC, LDF, LDG, LDR, LDS, LDWORK, + $ M, N, P + DOUBLE PRECISION SCALEC, SCALEO +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ F(LDF,*), G(LDG,*), R(LDR,*), S(LDS,*) +C .. Local Scalars .. + LOGICAL DISCR, LEFTW + INTEGER IERR, KAW, KU, KW, KWI, KWR, LDU, LW, ME, MP, + $ WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, SB03OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + LEFTW = LSAME( JOBCF, 'L' ) +C + INFO = 0 + IF( LEFTW ) THEN + MP = M + ELSE + MP = P + END IF + LW = N*( N + MAX( N, MP ) + MIN( N, MP ) + 6 ) +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LEFTW .OR. LSAME( JOBCF, 'R' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF( LDG.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN + INFO = -19 + ELSE IF( LDR.LT.MAX( 1, N ) ) THEN + INFO = -21 + ELSE IF( LDWORK.LT.MAX( 1, LW ) ) THEN + INFO = -23 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB16CY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + SCALEC = ONE + SCALEO = ONE + DWORK(1) = ONE + RETURN + END IF +C +C Allocate storage for work arrays. +C + KAW = 1 + KU = KAW + N*N + KWR = KU + N*MAX( N, MP ) + KWI = KWR + N + KW = KWI + N +C +C Form A+G*C. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), N ) + CALL DGEMM( 'No-transpose', 'No-transpose', N, N, P, ONE, + $ G, LDG, C, LDC, ONE, DWORK(KAW), N ) +C +C Form the factor H of the free term. +C + IF( LEFTW ) THEN +C +C H = F. +C + LDU = MAX( N, M ) + ME = M + CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KU), LDU ) + ELSE +C +C H = C. +C + LDU = MAX( N, P ) + ME = P + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), LDU ) + END IF +C +C Solve for the Cholesky factor Ru of Q, Q = Ru'*Ru, +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C (A+G*C)'*Q + Q*(A+G*C) + scaleo^2*H'*H = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C (A+G*C)'*Q*(A+G*C) - Q + scaleo^2*H'*H = 0. +C +C Workspace: need N*(N + MAX(N,M) + MIN(N,M) + 6) if JOBCF = 'L'; +C N*(N + MAX(N,P) + MIN(N,P) + 6) if JOBCF = 'R'. +C prefer larger. +C + CALL SB03OD( DICO, 'NoFact', 'NoTransp', N, ME, DWORK(KAW), N, + $ R, LDR, DWORK(KU), LDU, SCALEO, DWORK(KWR), + $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.2 ) THEN + INFO = 2 + ELSE IF( IERR.EQ.1 ) THEN + INFO = 4 + ELSE IF( IERR.EQ.6 ) THEN + INFO = 1 + END IF + RETURN + END IF +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 + CALL DLACPY( 'Upper', N, N, DWORK(KU), LDU, R, LDR ) +C +C Form A+B*F. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), N ) + CALL DGEMM( 'No-transpose', 'No-transpose', N, N, M, ONE, + $ B, LDB, F, LDF, ONE, DWORK(KAW), N ) +C +C Form the factor K of the free term. +C + LDU = N + IF( LEFTW ) THEN +C +C K = B. +C + ME = M + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), LDU ) + ELSE +C +C K = G. +C + ME = P + CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KU), LDU ) + END IF +C +C Solve for the Cholesky factor Su of P, P = Su*Su', +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C (A+B*F)*P + P*(A+B*F)' + scalec^2*K*K' = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C (A+B*F)*P*(A+B*F)' - P + scalec^2*K*K' = 0. +C +C Workspace: need N*(N + MAX(N,M) + MIN(N,M) + 6) if JOBCF = 'L'; +C N*(N + MAX(N,P) + MIN(N,P) + 6) if JOBCF = 'R'. +C prefer larger. +C + CALL SB03OD( DICO, 'NoFact', 'Transp', N, ME, DWORK(KAW), N, + $ S, LDS, DWORK(KU), LDU, SCALEC, DWORK(KWR), + $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.2 ) THEN + INFO = 3 + ELSE IF( IERR.EQ.1 ) THEN + INFO = 5 + ELSE IF( IERR.EQ.6 ) THEN + INFO = 1 + END IF + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL DLACPY( 'Upper', N, N, DWORK(KU), LDU, S, LDS ) +C +C Save the optimal workspace. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB16CY *** + END diff --git a/mex/sources/libslicot/SG02AD.f b/mex/sources/libslicot/SG02AD.f new file mode 100644 index 000000000..e7a9d9782 --- /dev/null +++ b/mex/sources/libslicot/SG02AD.f @@ -0,0 +1,939 @@ + SUBROUTINE SG02AD( DICO, JOBB, FACT, UPLO, JOBL, SCAL, SORT, ACC, + $ N, M, P, A, LDA, E, LDE, B, LDB, Q, LDQ, R, + $ LDR, L, LDL, RCONDU, X, LDX, ALFAR, ALFAI, + $ BETA, S, LDS, T, LDT, U, LDU, TOL, IWORK, + $ DWORK, LDWORK, BWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X either the continuous-time algebraic Riccati +C equation +C -1 +C Q + A'XE + E'XA - (L+E'XB)R (L+E'XB)' = 0 , (1) +C +C or the discrete-time algebraic Riccati equation +C -1 +C E'XE = A'XA - (L+A'XB)(R + B'XB) (L+A'XB)' + Q , (2) +C +C where A, E, B, Q, R, and L are N-by-N, N-by-N, N-by-M, N-by-N, +C M-by-M and N-by-M matrices, respectively, such that Q = C'C, +C R = D'D and L = C'D; X is an N-by-N symmetric matrix. +C The routine also returns the computed values of the closed-loop +C spectrum of the system, i.e., the stable eigenvalues +C lambda(1),...,lambda(N) of the pencil (A - BF,E), where F is +C the optimal gain matrix, +C -1 +C F = R (L+E'XB)' , for (1), +C +C and +C -1 +C F = (R+B'XB) (L+A'XB)' , for (2). +C -1 +C Optionally, matrix G = BR B' may be given instead of B and R. +C Other options include the case with Q and/or R given in a +C factored form, Q = C'C, R = D'D, and with L a zero matrix. +C +C The routine uses the method of deflating subspaces, based on +C reordering the eigenvalues in a generalized Schur matrix pair. +C +C It is assumed that E is nonsingular, but this condition is not +C checked. Note that the definition (1) of the continuous-time +C algebraic Riccati equation, and the formula for the corresponding +C optimal gain matrix, require R to be nonsingular, but the +C associated linear quadratic optimal problem could have a unique +C solution even when matrix R is singular, under mild assumptions +C (see METHOD). The routine SG02AD works accordingly in this case. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of Riccati equation to be solved as +C follows: +C = 'C': Equation (1), continuous-time case; +C = 'D': Equation (2), discrete-time case. +C +C JOBB CHARACTER*1 +C Specifies whether or not the matrix G is given, instead +C of the matrices B and R, as follows: +C = 'B': B and R are given; +C = 'G': G is given. +C +C FACT CHARACTER*1 +C Specifies whether or not the matrices Q and/or R (if +C JOBB = 'B') are factored, as follows: +C = 'N': Not factored, Q and R are given; +C = 'C': C is given, and Q = C'C; +C = 'D': D is given, and R = D'D; +C = 'B': Both factors C and D are given, Q = C'C, R = D'D. +C +C UPLO CHARACTER*1 +C If JOBB = 'G', or FACT = 'N', specifies which triangle of +C the matrices G, or Q and R, is stored, as follows: +C = 'U': Upper triangle is stored; +C = 'L': Lower triangle is stored. +C +C JOBL CHARACTER*1 +C Specifies whether or not the matrix L is zero, as follows: +C = 'Z': L is zero; +C = 'N': L is nonzero. +C JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed. +C SLICOT Library routine SB02MT should be called just before +C SG02AD, for obtaining the results when JOBB = 'G' and +C JOBL = 'N'. +C +C SCAL CHARACTER*1 +C If JOBB = 'B', specifies whether or not a scaling strategy +C should be used to scale Q, R, and L, as follows: +C = 'G': General scaling should be used; +C = 'N': No scaling should be used. +C SCAL is not used if JOBB = 'G'. +C +C SORT CHARACTER*1 +C Specifies which eigenvalues should be obtained in the top +C of the generalized Schur form, as follows: +C = 'S': Stable eigenvalues come first; +C = 'U': Unstable eigenvalues come first. +C +C ACC CHARACTER*1 +C Specifies whether or not iterative refinement should be +C used to solve the system of algebraic equations giving +C the solution matrix X, as follows: +C = 'R': Use iterative refinement; +C = 'N': Do not use iterative refinement. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e., the order of the +C matrices A, E, Q, and X, and the number of rows of the +C matrices B and L. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. If JOBB = 'B', M is the +C order of the matrix R, and the number of columns of the +C matrix B. M >= 0. +C M is not used if JOBB = 'G'. +C +C P (input) INTEGER +C The number of system outputs. If FACT = 'C' or 'D' or 'B', +C P is the number of rows of the matrices C and/or D. +C P >= 0. +C Otherwise, P is not used. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the descriptor system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N part of this array must contain the +C matrix E of the descriptor system. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,*) +C If JOBB = 'B', the leading N-by-M part of this array must +C contain the input matrix B of the system. +C If JOBB = 'G', the leading N-by-N upper triangular part +C (if UPLO = 'U') or lower triangular part (if UPLO = 'L') +C of this array must contain the upper triangular part or +C lower triangular part, respectively, of the matrix +C -1 +C G = BR B'. The stricly lower triangular part (if +C UPLO = 'U') or stricly upper triangular part (if +C UPLO = 'L') is not referenced. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) +C If FACT = 'N' or 'D', the leading N-by-N upper triangular +C part (if UPLO = 'U') or lower triangular part (if UPLO = +C 'L') of this array must contain the upper triangular part +C or lower triangular part, respectively, of the symmetric +C state weighting matrix Q. The stricly lower triangular +C part (if UPLO = 'U') or stricly upper triangular part (if +C UPLO = 'L') is not referenced. +C If FACT = 'C' or 'B', the leading P-by-N part of this +C array must contain the output matrix C of the system. +C If JOBB = 'B' and SCAL = 'G', then Q is modified +C internally, but is restored on exit. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= MAX(1,N) if FACT = 'N' or 'D'; +C LDQ >= MAX(1,P) if FACT = 'C' or 'B'. +C +C R (input) DOUBLE PRECISION array, dimension (LDR,*) +C If FACT = 'N' or 'C', the leading M-by-M upper triangular +C part (if UPLO = 'U') or lower triangular part (if UPLO = +C 'L') of this array must contain the upper triangular part +C or lower triangular part, respectively, of the symmetric +C input weighting matrix R. The stricly lower triangular +C part (if UPLO = 'U') or stricly upper triangular part (if +C UPLO = 'L') is not referenced. +C If FACT = 'D' or 'B', the leading P-by-M part of this +C array must contain the direct transmission matrix D of the +C system. +C If JOBB = 'B' and SCAL = 'G', then R is modified +C internally, but is restored on exit. +C If JOBB = 'G', this array is not referenced. +C +C LDR INTEGER +C The leading dimension of array R. +C LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C'; +C LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B'; +C LDR >= 1 if JOBB = 'G'. +C +C L (input) DOUBLE PRECISION array, dimension (LDL,*) +C If JOBL = 'N' and JOBB = 'B', the leading N-by-M part of +C this array must contain the cross weighting matrix L. +C If JOBB = 'B' and SCAL = 'G', then L is modified +C internally, but is restored on exit. +C If JOBL = 'Z' or JOBB = 'G', this array is not referenced. +C +C LDL INTEGER +C The leading dimension of array L. +C LDL >= MAX(1,N) if JOBL = 'N' and JOBB = 'B'; +C LDL >= 1 if JOBL = 'Z' or JOBB = 'G'. +C +C RCONDU (output) DOUBLE PRECISION +C If N > 0 and INFO = 0 or INFO = 7, an estimate of the +C reciprocal of the condition number (in the 1-norm) of +C the N-th order system of algebraic equations from which +C the solution matrix X is obtained. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C If INFO = 0, the leading N-by-N part of this array +C contains the solution matrix X of the problem. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= MAX(1,N). +C +C ALFAR (output) DOUBLE PRECISION array, dimension (2*N) +C ALFAI (output) DOUBLE PRECISION array, dimension (2*N) +C BETA (output) DOUBLE PRECISION array, dimension (2*N) +C The generalized eigenvalues of the 2N-by-2N matrix pair, +C ordered as specified by SORT (if INFO = 0, or INFO >= 5). +C For instance, if SORT = 'S', the leading N elements of +C these arrays contain the closed-loop spectrum of the +C system. Specifically, +C lambda(k) = [ALFAR(k)+j*ALFAI(k)]/BETA(k) for +C k = 1,2,...,N. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,*) +C The leading 2N-by-2N part of this array contains the +C ordered real Schur form S of the first matrix in the +C reduced matrix pencil associated to the optimal problem, +C corresponding to the scaled Q, R, and L, if JOBB = 'B' +C and SCAL = 'G'. That is, +C +C (S S ) +C ( 11 12) +C S = ( ), +C (0 S ) +C ( 22) +C +C where S , S and S are N-by-N matrices. +C 11 12 22 +C Array S must have 2*N+M columns if JOBB = 'B', and 2*N +C columns, otherwise. +C +C LDS INTEGER +C The leading dimension of array S. +C LDS >= MAX(1,2*N+M) if JOBB = 'B'; +C LDS >= MAX(1,2*N) if JOBB = 'G'. +C +C T (output) DOUBLE PRECISION array, dimension (LDT,2*N) +C The leading 2N-by-2N part of this array contains the +C ordered upper triangular form T of the second matrix in +C the reduced matrix pencil associated to the optimal +C problem, corresponding to the scaled Q, R, and L, if +C JOBB = 'B' and SCAL = 'G'. That is, +C +C (T T ) +C ( 11 12) +C T = ( ), +C (0 T ) +C ( 22) +C +C where T , T and T are N-by-N matrices. +C 11 12 22 +C +C LDT INTEGER +C The leading dimension of array T. +C LDT >= MAX(1,2*N+M) if JOBB = 'B'; +C LDT >= MAX(1,2*N) if JOBB = 'G'. +C +C U (output) DOUBLE PRECISION array, dimension (LDU,2*N) +C The leading 2N-by-2N part of this array contains the right +C transformation matrix U which reduces the 2N-by-2N matrix +C pencil to the ordered generalized real Schur form (S,T). +C That is, +C +C (U U ) +C ( 11 12) +C U = ( ), +C (U U ) +C ( 21 22) +C +C where U , U , U and U are N-by-N matrices. +C 11 12 21 22 +C If JOBB = 'B' and SCAL = 'G', then U corresponds to the +C scaled pencil. If a basis for the stable deflating +C subspace of the original problem is needed, then the +C submatrix U must be multiplied by the scaling factor +C 21 +C contained in DWORK(4). +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,2*N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the original matrix pencil, specifically of the triangular +C M-by-M factor obtained during the reduction process. If +C the user sets TOL > 0, then the given value of TOL is used +C as a lower bound for the reciprocal condition number of +C that matrix; a matrix whose estimated condition number is +C less than 1/TOL is considered to be nonsingular. If the +C user sets TOL <= 0, then a default tolerance, defined by +C TOLDEF = EPS, is used instead, where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C This parameter is not referenced if JOBB = 'G'. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK >= MAX(1,M,2*N) if JOBB = 'B'; +C LIWORK >= MAX(1,2*N) if JOBB = 'G'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. If JOBB = 'B' and N > 0, DWORK(2) returns the +C reciprocal of the condition number of the M-by-M bottom +C right lower triangular matrix obtained while compressing +C the matrix pencil of order 2N+M to obtain a pencil of +C order 2N. If ACC = 'R', and INFO = 0 or INFO = 7, DWORK(3) +C returns the reciprocal pivot growth factor (see SLICOT +C Library routine MB02PD) for the LU factorization of the +C coefficient matrix of the system of algebraic equations +C giving the solution matrix X; if DWORK(3) is much +C less than 1, then the computed X and RCONDU could be +C unreliable. If INFO = 0 or INFO = 7, DWORK(4) returns the +C scaling factor used to scale Q, R, and L. DWORK(4) is set +C to 1 if JOBB = 'G' or SCAL = 'N'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(7*(2*N+1)+16,16*N), if JOBB = 'G'; +C LDWORK >= MAX(7*(2*N+1)+16,16*N,2*N+M,3*M), if JOBB = 'B'. +C For optimum performance LDWORK should be larger. +C +C BWORK LOGICAL array, dimension (2*N) +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: the computed solution may be inaccurate due to poor +C scaling or eigenvalues too close to the boundary of +C the stability domain (the imaginary axis, if +C DICO = 'C', or the unit circle, if DICO = 'D'). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the computed extended matrix pencil is singular, +C possibly due to rounding errors; +C = 2: if the QZ algorithm failed; +C = 3: if reordering of the generalized eigenvalues failed; +C = 4: if after reordering, roundoff changed values of +C some complex eigenvalues so that leading eigenvalues +C in the generalized Schur form no longer satisfy the +C stability condition; this could also be caused due +C to scaling; +C = 5: if the computed dimension of the solution does not +C equal N; +C = 6: if the spectrum is too close to the boundary of +C the stability domain; +C = 7: if a singular matrix was encountered during the +C computation of the solution matrix X. +C +C METHOD +C +C The routine uses a variant of the method of deflating subspaces +C proposed by van Dooren [1]. See also [2], [3], [4]. +C It is assumed that E is nonsingular, the triple (E,A,B) is +C strongly stabilizable and detectable (see [3]); if, in addition, +C +C - [ Q L ] +C R := [ ] >= 0 , +C [ L' R ] +C +C then the pencils +C +C discrete-time continuous-time +C +C |A 0 B| |E 0 0| |A 0 B| |E 0 0| +C |Q -E' L| - z |0 -A' 0| , |Q A' L| - s |0 -E' 0| , (3) +C |L' 0 R| |0 -B' 0| |L' B' R| |0 0 0| +C +C are dichotomic, i.e., they have no eigenvalues on the boundary of +C the stability domain. The above conditions are sufficient for +C regularity of these pencils. A necessary condition is that +C rank([ B' L' R']') = m. +C +C Under these assumptions the algebraic Riccati equation is known to +C have a unique non-negative definite solution. +C The first step in the method of deflating subspaces is to form the +C extended matrices in (3), of order 2N + M. Next, these pencils are +C compressed to a form of order 2N (see [1]) +C +C lambda x A - B . +C f f +C +C This generalized eigenvalue problem is then solved using the QZ +C algorithm and the stable deflating subspace Ys is determined. +C If [Y1'|Y2']' is a basis for Ys, then the required solution is +C -1 +C X = Y2 x Y1 . +C +C REFERENCES +C +C [1] Van Dooren, P. +C A Generalized Eigenvalue Approach for Solving Riccati +C Equations. +C SIAM J. Sci. Stat. Comp., 2, pp. 121-135, 1981. +C +C [2] Arnold, III, W.F. and Laub, A.J. +C Generalized Eigenproblem Algorithms and Software for +C Algebraic Riccati Equations. +C Proc. IEEE, 72, 1746-1754, 1984. +C +C [3] Mehrmann, V. +C The Autonomous Linear Quadratic Control Problem. Theory and +C Numerical Solution. +C Lect. Notes in Control and Information Sciences, vol. 163, +C Springer-Verlag, Berlin, 1991. +C +C [4] Sima, V. +C Algorithms for Linear-Quadratic Optimization. +C Pure and Applied Mathematics: A Series of Monographs and +C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C +C This routine is particularly suited for systems where the matrix R +C is ill-conditioned, or even singular. +C +C FURTHER COMMENTS +C +C To obtain a stabilizing solution of the algebraic Riccati +C equations set SORT = 'S'. +C +C The routine can also compute the anti-stabilizing solutions of +C the algebraic Riccati equations, by specifying SORT = 'U'. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 2002. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, September 2002, +C December 2002. +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, discrete-time system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, P1, FOUR + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, + $ P1 = 0.1D0, FOUR = 4.0D0 ) +C .. Scalar Arguments .. + CHARACTER ACC, DICO, FACT, JOBB, JOBL, SCAL, SORT, UPLO + INTEGER INFO, IWARN, LDA, LDB, LDE, LDL, LDQ, LDR, LDS, + $ LDT, LDU, LDWORK, LDX, M, N, P + DOUBLE PRECISION RCONDU, TOL +C .. Array Arguments .. + LOGICAL BWORK(*) + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), ALFAI(*), ALFAR(*), B(LDB,*), BETA(*), + $ DWORK(*), E(LDE,*), L(LDL,*), Q(LDQ,*), + $ R(LDR,*), S(LDS,*), T(LDT,*), U(LDU,*), X(LDX,*) +C .. Local Scalars .. + CHARACTER EQUED, QTYPE, RTYPE + LOGICAL COLEQU, DISCR, LFACB, LFACN, LFACQ, LFACR, + $ LJOBB, LJOBL, LJOBLN, LSCAL, LSORT, LUPLO, + $ REFINE, ROWEQU + INTEGER I, INFO1, IW, IWB, IWC, IWF, IWR, J, LDW, MP, + $ NDIM, NN, NNM, NP, NP1, WRKOPT + DOUBLE PRECISION ASYM, EPS, PIVOTU, RCONDL, RNORM, SCALE, SEPS, + $ U12M, UNORM +C .. External Functions .. + LOGICAL LSAME, SB02OU, SB02OV, SB02OW + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02OU, SB02OV, + $ SB02OW +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGECON, DGEMM, DGEQRF, DGGES, + $ DLACPY, DLASCL, DLASET, DORGQR, DSCAL, DSWAP, + $ MB01SD, MB02PD, MB02VD, SB02OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX, SQRT +C .. Executable Statements .. +C + IWARN = 0 + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + LJOBB = LSAME( JOBB, 'B' ) + LFACN = LSAME( FACT, 'N' ) + LFACQ = LSAME( FACT, 'C' ) + LFACR = LSAME( FACT, 'D' ) + LFACB = LSAME( FACT, 'B' ) + LUPLO = LSAME( UPLO, 'U' ) + LSORT = LSAME( SORT, 'S' ) + REFINE = LSAME( ACC, 'R' ) + NN = 2*N + IF ( LJOBB ) THEN + LJOBL = LSAME( JOBL, 'Z' ) + LJOBLN = LSAME( JOBL, 'N' ) + LSCAL = LSAME( SCAL, 'G' ) + NNM = NN + M + LDW = MAX( NNM, 3*M ) + ELSE + LSCAL = .FALSE. + NNM = NN + LDW = 1 + END IF + NP1 = N + 1 +C +C Test the input scalar arguments. +C + IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LJOBB .AND. .NOT.LSAME( JOBB, 'G' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LFACQ .AND. .NOT.LFACR .AND. .NOT.LFACB + $ .AND. .NOT.LFACN ) THEN + INFO = -3 + ELSE IF( .NOT.LJOBB .OR. LFACN ) THEN + IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) + $ INFO = -4 + END IF + IF( INFO.EQ.0 .AND. LJOBB ) THEN + IF( .NOT.LJOBL .AND. .NOT.LJOBLN ) THEN + INFO = -5 + ELSE IF( .NOT.LSCAL .AND. .NOT. LSAME( SCAL, 'N' ) ) THEN + INFO = -6 + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( .NOT.LSORT .AND. .NOT.LSAME( SORT, 'U' ) ) THEN + INFO = -7 + ELSE IF( .NOT.REFINE .AND. .NOT.LSAME( ACC, 'N' ) ) THEN + INFO = -8 + ELSE IF( N.LT.0 ) THEN + INFO = -9 + ELSE IF( LJOBB ) THEN + IF( M.LT.0 ) + $ INFO = -10 + END IF + END IF + IF( INFO.EQ.0 .AND. .NOT.LFACN ) THEN + IF( P.LT.0 ) + $ INFO = -11 + END IF + IF( INFO.EQ.0 ) THEN + IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( ( ( LFACN.OR.LFACR ) .AND. LDQ.LT.MAX( 1, N ) ) .OR. + $ ( ( LFACQ.OR.LFACB ) .AND. LDQ.LT.MAX( 1, P ) ) ) THEN + INFO = -19 + ELSE IF( LJOBB ) THEN + IF ( ( LFACN.OR.LFACQ ) .AND. LDR.LT.MAX( 1, M ) .OR. + $ ( LFACR.OR.LFACB ) .AND. LDR.LT.MAX( 1, P ) ) THEN + INFO = -21 + ELSE IF( ( LJOBLN .AND. LDL.LT.MAX( 1, N ) ) .OR. + $ ( LJOBL .AND. LDL.LT.1 ) ) THEN + INFO = -23 + END IF + ELSE + IF( LDR.LT.1 ) THEN + INFO = -21 + ELSE IF( LDL.LT.1 ) THEN + INFO = -23 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -26 + ELSE IF( LDS.LT.MAX( 1, NNM ) ) THEN + INFO = -31 + ELSE IF( LDT.LT.MAX( 1, NNM ) ) THEN + INFO = -33 + ELSE IF( LDU.LT.MAX( 1, NN ) ) THEN + INFO = -35 + ELSE IF( LDWORK.LT.MAX( 14*N + 23, 16*N, LDW ) ) THEN + INFO = -39 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SG02AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK(1) = FOUR + DWORK(4) = ONE + RETURN + END IF +C +C Start computations. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + LSCAL = LSCAL .AND. LJOBB + IF ( LSCAL ) THEN +C +C Scale the matrices Q, R (or G), and L so that +C norm(Q) + norm(R) + norm(L) = 1, +C using the 1-norm. If Q and/or R are factored, the norms of +C the factors are used. +C Workspace: need max(N,M), if FACT = 'N'; +C N, if FACT = 'D'; +C M, if FACT = 'C'. +C + IF ( LFACN .OR. LFACR ) THEN + SCALE = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) + QTYPE = UPLO + NP = N + ELSE + SCALE = DLANGE( '1-norm', P, N, Q, LDQ, DWORK ) + QTYPE = 'G' + NP = P + END IF +C + IF ( LFACN .OR. LFACQ ) THEN + RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) + RTYPE = UPLO + MP = M + ELSE + RNORM = DLANGE( '1-norm', P, M, R, LDR, DWORK ) + RTYPE = 'G' + MP = P + END IF + SCALE = SCALE + RNORM +C + IF ( LJOBLN ) + $ SCALE = SCALE + DLANGE( '1-norm', N, M, L, LDL, DWORK ) + IF ( SCALE.EQ.ZERO ) + $ SCALE = ONE +C + CALL DLASCL( QTYPE, 0, 0, SCALE, ONE, NP, N, Q, LDQ, INFO1 ) + CALL DLASCL( RTYPE, 0, 0, SCALE, ONE, MP, M, R, LDR, INFO1 ) + IF ( LJOBLN ) + $ CALL DLASCL( 'G', 0, 0, SCALE, ONE, N, M, L, LDL, INFO1 ) + ELSE + SCALE = ONE + END IF +C +C Construct the extended matrix pair. +C Workspace: need 1, if JOBB = 'G', +C max(1,2*N+M,3*M), if JOBB = 'B'; +C prefer larger. +C + CALL SB02OY( 'Optimal control', DICO, JOBB, FACT, UPLO, JOBL, + $ 'Not identity E', N, M, P, A, LDA, B, LDB, Q, LDQ, R, + $ LDR, L, LDL, E, LDE, S, LDS, T, LDT, TOL, IWORK, + $ DWORK, LDWORK, INFO ) +C + IF ( LSCAL ) THEN +C +C Undo scaling of the data arrays. +C + CALL DLASCL( QTYPE, 0, 0, ONE, SCALE, NP, N, Q, LDQ, INFO1 ) + CALL DLASCL( RTYPE, 0, 0, ONE, SCALE, MP, M, R, LDR, INFO1 ) + IF ( LJOBLN ) + $ CALL DLASCL( 'G', 0, 0, ONE, SCALE, N, M, L, LDL, INFO1 ) + END IF +C + IF ( INFO.NE.0 ) + $ RETURN + WRKOPT = DWORK(1) + IF ( LJOBB ) + $ RCONDL = DWORK(2) +C +C Workspace: need max(7*(2*N+1)+16,16*N); +C prefer larger. +C + IF ( DISCR ) THEN + IF ( LSORT ) THEN +C +C The natural tendency of the QZ algorithm to get the largest +C eigenvalues in the leading part of the matrix pair is +C exploited, by computing the unstable eigenvalues of the +C permuted matrix pair. +C + CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, T, + $ LDT, S, LDS, NDIM, ALFAR, ALFAI, BETA, U, LDU, + $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) + CALL DSWAP( N, ALFAR(NP1), 1, ALFAR, 1 ) + CALL DSWAP( N, ALFAI(NP1), 1, ALFAI, 1 ) + CALL DSWAP( N, BETA (NP1), 1, BETA , 1 ) + ELSE + CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, S, + $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, + $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) + END IF + ELSE + IF ( LSORT ) THEN + CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OW, NN, S, + $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, + $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) + ELSE + CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OU, NN, S, + $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, + $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) + END IF + END IF + IF ( INFO1.GT.0 .AND. INFO1.LE.NN+1 ) THEN + INFO = 2 + ELSE IF ( INFO1.EQ.NN+2 ) THEN + INFO = 4 + ELSE IF ( INFO1.EQ.NN+3 ) THEN + INFO = 3 + ELSE IF ( NDIM.NE.N ) THEN + INFO = 5 + END IF + IF ( INFO.NE.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Take the non-identity matrix E into account and orthogonalize the +C basis. Use the array X as workspace. +C Workspace: need N; +C prefer N*NB. +C + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, E, LDE, + $ U, LDU, ZERO, X, LDX ) + CALL DLACPY( 'Full', N, N, X, LDX, U, LDU ) + CALL DGEQRF( NN, N, U, LDU, X, DWORK, LDWORK, INFO1 ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + CALL DORGQR( NN, N, N, U, LDU, X, DWORK, LDWORK, INFO1 ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Check for the symmetry of the solution. The array X is again used +C as workspace. +C + CALL DGEMM( 'Transpose', 'No transpose', N, N, N, ONE, U, LDU, + $ U(NP1,1), LDU, ZERO, X, LDX ) + U12M = ZERO + ASYM = ZERO +C + DO 20 J = 1, N +C + DO 10 I = 1, N + U12M = MAX( U12M, ABS( X(I,J) ) ) + ASYM = MAX( ASYM, ABS( X(I,J) - X(J,I) ) ) + 10 CONTINUE +C + 20 CONTINUE +C + EPS = DLAMCH( 'Epsilon' ) + SEPS = SQRT( EPS ) + ASYM = ASYM - SEPS + IF ( ASYM.GT.P1*U12M ) THEN + INFO = 6 + RETURN + ELSE IF ( ASYM.GT.SEPS ) THEN + IWARN = 1 + END IF +C +C Compute the solution of X*U(1,1) = U(2,1). Use the (2,1) block +C of S as a workspace for factoring U(1,1). +C + IF ( REFINE ) THEN +C +C Use LU factorization and iterative refinement for finding X. +C Workspace: need 8*N. +C +C First transpose U(2,1) in-situ. +C + DO 30 I = 1, N - 1 + CALL DSWAP( N-I, U(N+I,I+1), LDU, U(N+I+1,I), 1 ) + 30 CONTINUE +C + IWR = 1 + IWC = IWR + N + IWF = IWC + N + IWB = IWF + N + IW = IWB + N +C + CALL MB02PD( 'Equilibrate', 'Transpose', N, N, U, LDU, + $ S(NP1,1), LDS, IWORK, EQUED, DWORK(IWR), + $ DWORK(IWC), U(NP1,1), LDU, X, LDX, RCONDU, + $ DWORK(IWF), DWORK(IWB), IWORK(NP1), DWORK(IW), + $ INFO1 ) +C +C Transpose U(2,1) back in-situ. +C + DO 40 I = 1, N - 1 + CALL DSWAP( N-I, U(N+I,I+1), LDU, U(N+I+1,I), 1 ) + 40 CONTINUE +C + IF( .NOT.LSAME( EQUED, 'N' ) ) THEN +C +C Undo the equilibration of U(1,1) and U(2,1). +C + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) +C + IF( ROWEQU ) THEN +C + DO 50 I = 0, N - 1 + DWORK(IWR+I) = ONE / DWORK(IWR+I) + 50 CONTINUE +C + CALL MB01SD( 'Row scaling', N, N, U, LDU, DWORK(IWR), + $ DWORK(IWC) ) + END IF +C + IF( COLEQU ) THEN +C + DO 60 I = 0, N - 1 + DWORK(IWC+I) = ONE / DWORK(IWC+I) + 60 CONTINUE +C + CALL MB01SD( 'Column scaling', NN, N, U, LDU, DWORK(IWR), + $ DWORK(IWC) ) + END IF + END IF +C + PIVOTU = DWORK(IW) +C + IF ( INFO1.GT.0 ) THEN +C +C Singular matrix. Set INFO and DWORK for error return. +C + INFO = 7 + GO TO 80 + END IF +C + ELSE +C +C Use LU factorization and a standard solution algorithm. +C + CALL DLACPY( 'Full', N, N, U, LDU, S(NP1,1), LDS ) + CALL DLACPY( 'Full', N, N, U(NP1,1), LDU, X, LDX ) +C +C Solve the system X*U(1,1) = U(2,1). +C + CALL MB02VD( 'No Transpose', N, N, S(NP1,1), LDS, IWORK, X, + $ LDX, INFO1 ) +C + IF ( INFO1.NE.0 ) THEN + INFO = 7 + RCONDU = ZERO + GO TO 80 + ELSE +C +C Compute the norm of U(1,1). +C + UNORM = DLANGE( '1-norm', N, N, U, LDU, DWORK ) +C +C Estimate the reciprocal condition of U(1,1). +C Workspace: need 4*N. +C + CALL DGECON( '1-norm', N, S(NP1,1), LDS, UNORM, RCONDU, + $ DWORK, IWORK(NP1), INFO ) +C + IF ( RCONDU.LT.EPS ) THEN +C +C Nearly singular matrix. Set IWARN for warning indication. +C + IWARN = 1 + END IF + WRKOPT = MAX( WRKOPT, 4*N ) + END IF + END IF +C +C Set S(2,1) to zero. +C + CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) +C +C Make sure the solution matrix X is symmetric. +C + DO 70 I = 1, N - 1 + CALL DAXPY( N-I, ONE, X(I,I+1), LDX, X(I+1,I), 1 ) + CALL DSCAL( N-I, HALF, X(I+1,I), 1 ) + CALL DCOPY( N-I, X(I+1,I), 1, X(I,I+1), LDX ) + 70 CONTINUE +C + IF ( LSCAL ) THEN +C +C Undo scaling for the solution X. +C + CALL DLASCL( 'G', 0, 0, ONE, SCALE, N, N, X, LDX, INFO1 ) + END IF +C + DWORK(1) = WRKOPT +C + 80 CONTINUE + IF ( LJOBB ) + $ DWORK(2) = RCONDL + IF ( REFINE ) + $ DWORK(3) = PIVOTU + DWORK(4) = SCALE +C + RETURN +C *** Last line of SG02AD *** + END diff --git a/mex/sources/libslicot/SG03AD.f b/mex/sources/libslicot/SG03AD.f new file mode 100644 index 000000000..a08e218ca --- /dev/null +++ b/mex/sources/libslicot/SG03AD.f @@ -0,0 +1,639 @@ + SUBROUTINE SG03AD( DICO, JOB, FACT, TRANS, UPLO, N, A, LDA, E, + $ LDE, Q, LDQ, Z, LDZ, X, LDX, SCALE, SEP, FERR, + $ ALPHAR, ALPHAI, BETA, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X either the generalized continuous-time Lyapunov +C equation +C +C T T +C op(A) X op(E) + op(E) X op(A) = SCALE * Y, (1) +C +C or the generalized discrete-time Lyapunov equation +C +C T T +C op(A) X op(A) - op(E) X op(E) = SCALE * Y, (2) +C +C where op(M) is either M or M**T for M = A, E and the right hand +C side Y is symmetric. A, E, Y, and the solution X are N-by-N +C matrices. SCALE is an output scale factor, set to avoid overflow +C in X. +C +C Estimates of the separation and the relative forward error norm +C are provided. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies which type of the equation is considered: +C = 'C': Continuous-time equation (1); +C = 'D': Discrete-time equation (2). +C +C JOB CHARACTER*1 +C Specifies if the solution is to be computed and if the +C separation is to be estimated: +C = 'X': Compute the solution only; +C = 'S': Estimate the separation only; +C = 'B': Compute the solution and estimate the separation. +C +C FACT CHARACTER*1 +C Specifies whether the generalized real Schur +C factorization of the pencil A - lambda * E is supplied +C on entry or not: +C = 'N': Factorization is not supplied; +C = 'F': Factorization is supplied. +C +C TRANS CHARACTER*1 +C Specifies whether the transposed equation is to be solved +C or not: +C = 'N': op(A) = A, op(E) = E; +C = 'T': op(A) = A**T, op(E) = E**T. +C +C UPLO CHARACTER*1 +C Specifies whether the lower or the upper triangle of the +C array X is needed on input: +C = 'L': Only the lower triangle is needed on input; +C = 'U': Only the upper triangle is needed on input. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, if FACT = 'F', then the leading N-by-N upper +C Hessenberg part of this array must contain the +C generalized Schur factor A_s of the matrix A (see +C definition (3) in section METHOD). A_s must be an upper +C quasitriangular matrix. The elements below the upper +C Hessenberg part of the array A are not referenced. +C If FACT = 'N', then the leading N-by-N part of this +C array must contain the matrix A. +C On exit, the leading N-by-N part of this array contains +C the generalized Schur factor A_s of the matrix A. (A_s is +C an upper quasitriangular matrix.) +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, if FACT = 'F', then the leading N-by-N upper +C triangular part of this array must contain the +C generalized Schur factor E_s of the matrix E (see +C definition (4) in section METHOD). The elements below the +C upper triangular part of the array E are not referenced. +C If FACT = 'N', then the leading N-by-N part of this +C array must contain the coefficient matrix E of the +C equation. +C On exit, the leading N-by-N part of this array contains +C the generalized Schur factor E_s of the matrix E. (E_s is +C an upper triangular matrix.) +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, if FACT = 'F', then the leading N-by-N part of +C this array must contain the orthogonal matrix Q from +C the generalized Schur factorization (see definitions (3) +C and (4) in section METHOD). +C If FACT = 'N', Q need not be set on entry. +C On exit, the leading N-by-N part of this array contains +C the orthogonal matrix Q from the generalized Schur +C factorization. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= MAX(1,N). +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C On entry, if FACT = 'F', then the leading N-by-N part of +C this array must contain the orthogonal matrix Z from +C the generalized Schur factorization (see definitions (3) +C and (4) in section METHOD). +C If FACT = 'N', Z need not be set on entry. +C On exit, the leading N-by-N part of this array contains +C the orthogonal matrix Z from the generalized Schur +C factorization. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= MAX(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, if JOB = 'B' or 'X', then the leading N-by-N +C part of this array must contain the right hand side matrix +C Y of the equation. Either the lower or the upper +C triangular part of this array is needed (see mode +C parameter UPLO). +C If JOB = 'S', X is not referenced. +C On exit, if JOB = 'B' or 'X', and INFO = 0, 3, or 4, then +C the leading N-by-N part of this array contains the +C solution matrix X of the equation. +C If JOB = 'S', X is not referenced. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in X. +C (0 < SCALE <= 1) +C +C SEP (output) DOUBLE PRECISION +C If JOB = 'S' or JOB = 'B', and INFO = 0, 3, or 4, then +C SEP contains an estimate of the separation of the +C Lyapunov operator. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'B', and INFO = 0, 3, or 4, then FERR contains an +C estimated forward error bound for the solution X. If XTRUE +C is the true solution, FERR estimates the relative error +C in the computed solution, measured in the Frobenius norm: +C norm(X - XTRUE) / norm(XTRUE) +C +C ALPHAR (output) DOUBLE PRECISION array, dimension (N) +C ALPHAI (output) DOUBLE PRECISION array, dimension (N) +C BETA (output) DOUBLE PRECISION array, dimension (N) +C If FACT = 'N' and INFO = 0, 3, or 4, then +C (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, are the +C eigenvalues of the matrix pencil A - lambda * E. +C If FACT = 'F', ALPHAR, ALPHAI, and BETA are not +C referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N**2) +C IWORK is not referenced if JOB = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. The following table +C contains the minimal work space requirements depending +C on the choice of JOB and FACT. +C +C JOB FACT | LDWORK +C -------------------+------------------- +C 'X' 'F' | MAX(1,N) +C 'X' 'N' | MAX(1,4*N) +C 'B', 'S' 'F' | MAX(1,2*N**2) +C 'B', 'S' 'N' | MAX(1,2*N**2,4*N) +C +C For optimum performance, LDWORK should be larger. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: FACT = 'F' and the matrix contained in the upper +C Hessenberg part of the array A is not in upper +C quasitriangular form; +C = 2: FACT = 'N' and the pencil A - lambda * E cannot be +C reduced to generalized Schur form: LAPACK routine +C DGEGS has failed to converge; +C = 3: DICO = 'D' and the pencil A - lambda * E has a +C pair of reciprocal eigenvalues. That is, lambda_i = +C 1/lambda_j for some i and j, where lambda_i and +C lambda_j are eigenvalues of A - lambda * E. Hence, +C equation (2) is singular; perturbed values were +C used to solve the equation (but the matrices A and +C E are unchanged); +C = 4: DICO = 'C' and the pencil A - lambda * E has a +C degenerate pair of eigenvalues. That is, lambda_i = +C -lambda_j for some i and j, where lambda_i and +C lambda_j are eigenvalues of A - lambda * E. Hence, +C equation (1) is singular; perturbed values were +C used to solve the equation (but the matrices A and +C E are unchanged). +C +C METHOD +C +C A straightforward generalization [3] of the method proposed by +C Bartels and Stewart [1] is utilized to solve (1) or (2). +C +C First the pencil A - lambda * E is reduced to real generalized +C Schur form A_s - lambda * E_s by means of orthogonal +C transformations (QZ-algorithm): +C +C A_s = Q**T * A * Z (upper quasitriangular) (3) +C +C E_s = Q**T * E * Z (upper triangular). (4) +C +C If FACT = 'F', this step is omitted. Assuming SCALE = 1 and +C defining +C +C ( Z**T * Y * Z : TRANS = 'N' +C Y_s = < +C ( Q**T * Y * Q : TRANS = 'T' +C +C +C ( Q**T * X * Q if TRANS = 'N' +C X_s = < (5) +C ( Z**T * X * Z if TRANS = 'T' +C +C leads to the reduced Lyapunov equation +C +C T T +C op(A_s) X_s op(E_s) + op(E_s) X_s op(A_s) = Y_s, (6) +C +C or +C T T +C op(A_s) X_s op(A_s) - op(E_s) X_s op(E_s) = Y_s, (7) +C +C which are equivalent to (1) or (2), respectively. The solution X_s +C of (6) or (7) is computed via block back substitution (if TRANS = +C 'N') or block forward substitution (if TRANS = 'T'), where the +C block order is at most 2. (See [1] and [3] for details.) +C Equation (5) yields the solution matrix X. +C +C For fast computation the estimates of the separation and the +C forward error are gained from (6) or (7) rather than (1) or +C (2), respectively. We consider (6) and (7) as special cases of the +C generalized Sylvester equation +C +C R * X * S + U * X * V = Y, (8) +C +C whose separation is defined as follows +C +C sep = sep(R,S,U,V) = min || R * X * S + U * X * V || . +C ||X|| = 1 F +C F +C +C Equation (8) is equivalent to the system of linear equations +C +C K * vec(X) = (kron(S**T,R) + kron(V**T,U)) * vec(X) = vec(Y), +C +C where kron is the Kronecker product of two matrices and vec +C is the mapping that stacks the columns of a matrix. If K is +C nonsingular then +C +C sep = 1 / ||K**(-1)|| . +C 2 +C +C We estimate ||K**(-1)|| by a method devised by Higham [2]. Note +C that this method yields an estimation for the 1-norm but we use it +C as an approximation for the 2-norm. Estimates for the forward +C error norm are provided by +C +C FERR = 2 * EPS * ||A_s|| * ||E_s|| / sep +C F F +C +C in the continuous-time case (1) and +C +C FERR = EPS * ( ||A_s|| **2 + ||E_s|| **2 ) / sep +C F F +C +C in the discrete-time case (2). +C The reciprocal condition number, RCOND, of the Lyapunov equation +C can be estimated by FERR/EPS. +C +C REFERENCES +C +C [1] Bartels, R.H., Stewart, G.W. +C Solution of the equation A X + X B = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Higham, N.J. +C FORTRAN codes for estimating the one-norm of a real or complex +C matrix, with applications to condition estimation. +C A.C.M. Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, 1988. +C +C [3] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C NUMERICAL ASPECTS +C +C The number of flops required by the routine is given by the +C following table. Note that we count a single floating point +C arithmetic operation as one flop. c is an integer number of modest +C size (say 4 or 5). +C +C | FACT = 'F' FACT = 'N' +C -----------+------------------------------------------ +C JOB = 'B' | (26+8*c)/3 * N**3 (224+8*c)/3 * N**3 +C JOB = 'S' | 8*c/3 * N**3 (198+8*c)/3 * N**3 +C JOB = 'X' | 26/3 * N**3 224/3 * N**3 +C +C The algorithm is backward stable if the eigenvalues of the pencil +C A - lambda * E are real. Otherwise, linear systems of order at +C most 4 are involved into the computation. These systems are solved +C by Gauss elimination with complete pivoting. The loss of stability +C of the Gauss elimination with complete pivoting is rarely +C encountered in practice. +C +C The Lyapunov equation may be very ill-conditioned. In particular, +C if DICO = 'D' and the pencil A - lambda * E has a pair of almost +C reciprocal eigenvalues, or DICO = 'C' and the pencil has an almost +C degenerate pair of eigenvalues, then the Lyapunov equation will be +C ill-conditioned. Perturbed values were used to solve the equation. +C Ill-conditioning can be detected by a very small value of the +C reciprocal condition number RCOND. +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C Dec. 1998 (V. Sima). +C +C KEYWORDS +C +C Lyapunov equation +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TWO, ZERO + PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER DICO, FACT, JOB, TRANS, UPLO + DOUBLE PRECISION FERR, SCALE, SEP + INTEGER INFO, LDA, LDE, LDQ, LDWORK, LDX, LDZ, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), BETA(*), + $ DWORK(*), E(LDE,*), Q(LDQ,*), X(LDX,*), + $ Z(LDZ,*) + INTEGER IWORK(*) +C .. Local Scalars .. + CHARACTER ETRANS + DOUBLE PRECISION EST, EPS, NORMA, NORME, SCALE1 + INTEGER I, INFO1, KASE, MINWRK, OPTWRK + LOGICAL ISDISC, ISFACT, ISTRAN, ISUPPR, WANTBH, WANTSP, + $ WANTX +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DNRM2 + LOGICAL LSAME + EXTERNAL DLAMCH, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEGS, DLACON, MB01RD, MB01RW, SG03AX, + $ SG03AY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C .. Executable Statements .. +C +C Decode input parameters. +C + ISDISC = LSAME( DICO, 'D' ) + WANTX = LSAME( JOB, 'X' ) + WANTSP = LSAME( JOB, 'S' ) + WANTBH = LSAME( JOB, 'B' ) + ISFACT = LSAME( FACT, 'F' ) + ISTRAN = LSAME( TRANS, 'T' ) + ISUPPR = LSAME( UPLO, 'U' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( ISDISC .OR. LSAME( DICO, 'C' ) ) ) THEN + INFO = -1 + ELSEIF ( .NOT.( WANTX .OR. WANTSP .OR. WANTBH ) ) THEN + INFO = -2 + ELSEIF ( .NOT.( ISFACT .OR. LSAME( FACT, 'N' ) ) ) THEN + INFO = -3 + ELSEIF ( .NOT.( ISTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN + INFO = -4 + ELSEIF ( .NOT.( ISUPPR .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -5 + ELSEIF ( N .LT. 0 ) THEN + INFO = -6 + ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN + INFO = -8 + ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN + INFO = -10 + ELSEIF ( LDQ .LT. MAX( 1, N ) ) THEN + INFO = -12 + ELSEIF ( LDZ .LT. MAX( 1, N ) ) THEN + INFO = -14 + ELSEIF ( LDX .LT. MAX( 1, N ) ) THEN + INFO = -16 + ELSE + INFO = 0 + END IF + IF ( INFO .EQ. 0 ) THEN +C +C Compute minimal workspace. +C + IF ( WANTX ) THEN + IF ( ISFACT ) THEN + MINWRK = MAX( N, 1 ) + ELSE + MINWRK = MAX( 4*N, 1 ) + END IF + ELSE + IF ( ISFACT ) THEN + MINWRK = MAX( 2*N*N, 1 ) + ELSE + MINWRK = MAX( 2*N*N, 4*N, 1 ) + END IF + END IF + IF ( MINWRK .GT. LDWORK ) THEN + INFO = -25 + END IF + END IF + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SG03AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N .EQ. 0 ) THEN + SCALE = ONE + IF ( .NOT.WANTX ) SEP = ZERO + IF ( WANTBH ) FERR = ZERO + DWORK(1) = ONE + RETURN + END IF +C + IF ( ISFACT ) THEN +C +C Make sure the upper Hessenberg part of A is quasitriangular. +C + DO 20 I = 1, N-2 + IF ( A(I+1,I).NE.ZERO .AND. A(I+2,I+1).NE.ZERO ) THEN + INFO = 1 + RETURN + END IF + 20 CONTINUE + END IF +C + IF ( .NOT.ISFACT ) THEN +C +C Reduce A - lambda * E to generalized Schur form. +C +C A := Q**T * A * Z (upper quasitriangular) +C E := Q**T * E * Z (upper triangular) +C +C ( Workspace: >= MAX(1,4*N) ) +C + CALL DGEGS( 'Vectors', 'Vectors', N, A, LDA, E, LDE, ALPHAR, + $ ALPHAI, BETA, Q, LDQ, Z, LDZ, DWORK, LDWORK, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + INFO = 2 + RETURN + END IF + OPTWRK = INT( DWORK(1) ) + ELSE + OPTWRK = MINWRK + END IF +C + IF ( WANTBH .OR. WANTX ) THEN +C +C Transform right hand side. +C +C X := Z**T * X * Z or X := Q**T * X * Q +C +C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. +C +C ( Workspace: >= N ) +C + IF ( LDWORK .LT. N*N ) THEN + IF ( ISTRAN ) THEN + CALL MB01RW( UPLO, 'Transpose', N, N, X, LDX, Q, LDQ, + $ DWORK, INFO1 ) + ELSE + CALL MB01RW( UPLO, 'Transpose', N, N, X, LDX, Z, LDZ, + $ DWORK, INFO1 ) + END IF + ELSE + IF ( ISTRAN ) THEN + CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, + $ Q, LDQ, X, LDX, DWORK, LDWORK, INFO ) + ELSE + CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, + $ Z, LDZ, X, LDX, DWORK, LDWORK, INFO ) + END IF + END IF + IF ( .NOT.ISUPPR ) THEN + DO 40 I = 1, N-1 + CALL DCOPY( N-I, X(I+1,I), 1, X(I,I+1), LDX ) + 40 CONTINUE + END IF + OPTWRK = MAX( OPTWRK, N*N ) +C +C Solve reduced generalized Lyapunov equation. +C + IF ( ISDISC ) THEN + CALL SG03AX( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO1) + IF ( INFO1 .NE. 0 ) + $ INFO = 3 + ELSE + CALL SG03AY( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO1) + IF ( INFO1 .NE. 0 ) + $ INFO = 4 + END IF +C +C Transform the solution matrix back. +C +C X := Q * X * Q**T or X := Z * X * Z**T. +C +C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. +C +C ( Workspace: >= N ) +C + IF ( LDWORK .LT. N*N ) THEN + IF ( ISTRAN ) THEN + CALL MB01RW( 'Upper', 'NoTranspose', N, N, X, LDX, Z, + $ LDZ, DWORK, INFO1 ) + ELSE + CALL MB01RW( 'Upper', 'NoTranspose', N, N, X, LDX, Q, + $ LDQ, DWORK, INFO1 ) + END IF + ELSE + IF ( ISTRAN ) THEN + CALL MB01RD( 'Upper', 'NoTranspose', N, N, ZERO, ONE, X, + $ LDX, Z, LDZ, X, LDX, DWORK, LDWORK, INFO ) + ELSE + CALL MB01RD( 'Upper', 'NoTranspose', N, N, ZERO, ONE, X, + $ LDX, Q, LDQ, X, LDX, DWORK, LDWORK, INFO ) + END IF + END IF + DO 60 I = 1, N-1 + CALL DCOPY( N-I, X(I,I+1), LDX, X(I+1,I), 1 ) + 60 CONTINUE + END IF +C + IF ( WANTBH .OR. WANTSP ) THEN +C +C Estimate the 1-norm of the inverse Kronecker product matrix +C belonging to the reduced generalized Lyapunov equation. +C +C ( Workspace: 2*N*N ) +C + EST = ZERO + KASE = 0 + 80 CONTINUE + CALL DLACON( N*N, DWORK(N*N+1), DWORK, IWORK, EST, KASE ) + IF ( KASE .NE. 0 ) THEN + IF ( ( KASE.EQ.1 .AND. .NOT.ISTRAN ) .OR. + $ ( KASE.NE.1 .AND. ISTRAN ) ) THEN + ETRANS = 'N' + ELSE + ETRANS = 'T' + END IF + IF ( ISDISC ) THEN + CALL SG03AX( ETRANS, N, A, LDA, E, LDE, DWORK, N, SCALE1, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 3 + ELSE + CALL SG03AY( ETRANS, N, A, LDA, E, LDE, DWORK, N, SCALE1, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 4 + END IF + GOTO 80 + END IF + SEP = SCALE1/EST + END IF +C +C Estimate the relative forward error. +C +C ( Workspace: 2*N ) +C + IF ( WANTBH ) THEN + EPS = DLAMCH( 'Precision' ) + DO 100 I = 1, N + DWORK(I) = DNRM2( MIN( I+1, N ), A(1,I), 1 ) + DWORK(N+I) = DNRM2( I, E(1,I), 1 ) + 100 CONTINUE + NORMA = DNRM2( N, DWORK, 1 ) + NORME = DNRM2( N, DWORK(N+1), 1 ) + IF ( ISDISC ) THEN + FERR = ( NORMA**2 + NORME**2 )*EPS/SEP + ELSE + FERR = TWO*NORMA*NORME*EPS/SEP + END IF + END IF +C + DWORK(1) = DBLE( MAX( OPTWRK, MINWRK ) ) + RETURN +C *** Last line of SG03AD *** + END diff --git a/mex/sources/libslicot/SG03AX.f b/mex/sources/libslicot/SG03AX.f new file mode 100644 index 000000000..872ed0282 --- /dev/null +++ b/mex/sources/libslicot/SG03AX.f @@ -0,0 +1,687 @@ + SUBROUTINE SG03AX( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X either the reduced generalized discrete-time +C Lyapunov equation +C +C T T +C A * X * A - E * X * E = SCALE * Y (1) +C +C or +C +C T T +C A * X * A - E * X * E = SCALE * Y (2) +C +C where the right hand side Y is symmetric. A, E, Y, and the +C solution X are N-by-N matrices. The pencil A - lambda * E must be +C in generalized Schur form (A upper quasitriangular, E upper +C triangular). SCALE is an output scale factor, set to avoid +C overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANS CHARACTER*1 +C Specifies whether the transposed equation is to be solved +C or not: +C = 'N': Solve equation (1); +C = 'T': Solve equation (2). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain the quasitriangular matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N upper triangular part of this array +C must contain the matrix E. +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, the leading N-by-N part of this array must +C contain the right hand side matrix Y of the equation. Only +C the upper triangular part of this matrix need be given. +C On exit, the leading N-by-N part of this array contains +C the solution matrix X of the equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in X. +C (0 < SCALE <= 1) +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: equation is (almost) singular to working precision; +C perturbed values were used to solve the equation +C (but the matrices A and E are unchanged). +C +C METHOD +C +C The solution X of (1) or (2) is computed via block back +C substitution or block forward substitution, respectively. (See +C [1] and [2] for details.) +C +C REFERENCES +C +C [1] Bartels, R.H., Stewart, G.W. +C Solution of the equation A X + X B = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C NUMERICAL ASPECTS +C +C 8/3 * N**3 flops are required by the routine. Note that we count a +C single floating point arithmetic operation as one flop. +C +C The algorithm is backward stable if the eigenvalues of the pencil +C A - lambda * E are real. Otherwise, linear systems of order at +C most 4 are involved into the computation. These systems are solved +C by Gauss elimination with complete pivoting. The loss of stability +C of the Gauss elimination with complete pivoting is rarely +C encountered in practice. +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C Dec. 1998 (V. Sima). +C +C KEYWORDS +C +C Lyapunov equation +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION MONE, ONE, ZERO + PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER TRANS + DOUBLE PRECISION SCALE + INTEGER INFO, LDA, LDE, LDX, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), E(LDE,*), X(LDX,*) +C .. Local Scalars .. + DOUBLE PRECISION AK11, AK12, AK21, AK22, AL11, AL12, AL21, AL22, + $ EK11, EK12, EK22, EL11, EL12, EL22, SCALE1 + INTEGER DIMMAT, I, INFO1, KB, KH, KL, LB, LH, LL + LOGICAL NOTRNS +C .. Local Arrays .. + DOUBLE PRECISION MAT(4,4), RHS(4), TM(2,2) + INTEGER PIV1(4), PIV2(4) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DSCAL, MB02UU, + $ MB02UV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Decode input parameter. +C + NOTRNS = LSAME( TRANS, 'N' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN + INFO = -1 + ELSEIF ( N .LT. 0 ) THEN + INFO = -2 + ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN + INFO = -4 + ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN + INFO = -6 + ELSEIF ( LDX .LT. MAX( 1, N ) ) THEN + INFO = -8 + ELSE + INFO = 0 + END IF + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SG03AX', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF ( N .EQ. 0 ) RETURN +C + IF ( NOTRNS ) THEN +C +C Solve equation (1). +C +C Outer Loop. Compute block row X(KL:KH,:). KB denotes the number +C of rows in this block row. +C + KL = 0 + KB = 1 +C WHILE ( KL+KB .LE. N ) DO + 20 IF ( KL+KB .LE. N ) THEN + KL = KL + KB + IF ( KL .EQ. N ) THEN + KB = 1 + ELSE + IF ( A(KL+1,KL) .NE. ZERO ) THEN + KB = 2 + ELSE + KB = 1 + END IF + END IF + KH = KL + KB - 1 +C +C Copy elements of solution already known by symmetry. +C +C X(KL:KH,1:KL-1) = X(1:KL-1,KL:KH)' +C + IF ( KL .GT. 1 ) THEN + DO 40 I = KL, KH + CALL DCOPY( KL-1, X(1,I), 1, X(I,1), LDX ) + 40 CONTINUE + END IF +C +C Inner Loop. Compute block X(KL:KH,LL:LH). LB denotes the +C number of columns in this block. +C + LL = KL - 1 + LB = 1 +C WHILE ( LL+LB .LE. N ) DO + 60 IF ( LL+LB .LE. N ) THEN + LL = LL + LB + IF ( LL .EQ. N ) THEN + LB = 1 + ELSE + IF ( A(LL+1,LL) .NE. ZERO ) THEN + LB = 2 + ELSE + LB = 1 + END IF + END IF + LH = LL + LB - 1 +C +C Update right hand sides (I). +C +C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) - +C A(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*A(1:LL-1,LL:LH)) +C +C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) + +C E(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*E(1:LL-1,LL:LH)) +C + IF ( LL .GT. 1 ) THEN + CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), LDX, + $ A(1,LL), LDA, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', LH-KL+1, LB, KB, MONE, A(KL,KL), + $ LDA, TM, 2, ONE, X(KL,LL), LDX ) + CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), + $ LDX, E(1,LL), LDE, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', LH-KH+1, LB, KB, ONE, E(KL,KH), + $ LDE, TM, 2, ONE, X(KH,LL), LDX ) + IF ( KB .EQ. 2 ) CALL DAXPY( LB, E(KL,KL), TM, 2, + $ X(KL,LL), LDX ) + END IF +C +C Solve small Sylvester equations of order at most (2,2). +C + IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 1 +C + MAT(1,1) = A(LL,LL)*A(KL,KL) - E(LL,LL)*E(KL,KL) +C + RHS(1) = X(KL,LL) +C + ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) + AK12 = A(KL,KH) + AK21 = A(KH,KL) + AK22 = A(KH,KH) +C + AL11 = A(LL,LL) +C + EK11 = E(KL,KL) + EK12 = E(KL,KH) + EK22 = E(KH,KH) +C + EL11 = E(LL,LL) +C + MAT(1,1) = AL11*AK11 - EL11*EK11 + MAT(1,2) = AL11*AK21 + MAT(2,1) = AL11*AK12 - EL11*EK12 + MAT(2,2) = AL11*AK22 - EL11*EK22 +C + RHS(1) = X(KL,LL) + RHS(2) = X(KH,LL) +C + ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) +C + AL11 = A(LL,LL) + AL12 = A(LL,LH) + AL21 = A(LH,LL) + AL22 = A(LH,LH) +C + EK11 = E(KL,KL) +C + EL11 = E(LL,LL) + EL12 = E(LL,LH) + EL22 = E(LH,LH) +C + MAT(1,1) = AL11*AK11 - EL11*EK11 + MAT(1,2) = AL21*AK11 + MAT(2,1) = AL12*AK11 - EL12*EK11 + MAT(2,2) = AL22*AK11 - EL22*EK11 +C + RHS(1) = X(KL,LL) + RHS(2) = X(KL,LH) +C + ELSE +C + DIMMAT = 4 +C + AK11 = A(KL,KL) + AK12 = A(KL,KH) + AK21 = A(KH,KL) + AK22 = A(KH,KH) +C + AL11 = A(LL,LL) + AL12 = A(LL,LH) + AL21 = A(LH,LL) + AL22 = A(LH,LH) +C + EK11 = E(KL,KL) + EK12 = E(KL,KH) + EK22 = E(KH,KH) +C + EL11 = E(LL,LL) + EL12 = E(LL,LH) + EL22 = E(LH,LH) +C + MAT(1,1) = AL11*AK11 - EL11*EK11 + MAT(1,2) = AL11*AK21 + MAT(1,3) = AL21*AK11 + MAT(1,4) = AL21*AK21 +C + MAT(2,1) = AL11*AK12 - EL11*EK12 + MAT(2,2) = AL11*AK22 - EL11*EK22 + MAT(2,3) = AL21*AK12 + MAT(2,4) = AL21*AK22 +C + MAT(3,1) = AL12*AK11 - EL12*EK11 + MAT(3,2) = AL12*AK21 + MAT(3,3) = AL22*AK11 - EL22*EK11 + MAT(3,4) = AL22*AK21 +C + MAT(4,1) = AL12*AK12 - EL12*EK12 + MAT(4,2) = AL12*AK22 - EL12*EK22 + MAT(4,3) = AL22*AK12 - EL22*EK12 + MAT(4,4) = AL22*AK22 - EL22*EK22 +C + RHS(1) = X(KL,LL) + IF ( KL .EQ. LL ) THEN + RHS(2) = X(KL,KH) + ELSE + RHS(2) = X(KH,LL) + END IF + RHS(3) = X(KL,LH) + RHS(4) = X(KH,LH) +C + END IF +C + CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) +C +C Scaling. +C + IF ( SCALE1 .NE. ONE ) THEN + DO 80 I = 1, N + CALL DSCAL( N, SCALE1, X(1,I), 1 ) + 80 CONTINUE + SCALE = SCALE*SCALE1 + END IF +C + IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN + X(KL,LL) = RHS(1) + ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN + X(KL,LL) = RHS(1) + X(KH,LL) = RHS(2) + ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN + X(KL,LL) = RHS(1) + X(KL,LH) = RHS(2) + ELSE + X(KL,LL) = RHS(1) + X(KH,LL) = RHS(2) + X(KL,LH) = RHS(3) + X(KH,LH) = RHS(4) + END IF +C +C Update right hand sides (II). +C +C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) - +C A(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*A(LL:LH,LL:LH)) +C +C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) + +C E(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*E(LL:LH,LL:LH)) +C + IF ( KL .LT. LL ) THEN + CALL DGEMM( 'N', 'N', KB, LB, LB, ONE, X(KL,LL), LDX, + $ A(LL,LL), LDA, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', LH-KH, LB, KB, MONE, A(KL,KH+1), + $ LDA, TM, 2, ONE, X(KH+1,LL), LDX ) + IF ( LB .EQ. 2 ) THEN + CALL DCOPY( KB, X(KL,LL), 1, TM, 1 ) + CALL DSCAL( KB, E(LL,LL), TM, 1 ) + END IF + CALL DGEMV( 'N', KB, LB, ONE, X(KL,LL), LDX, E(LL,LH), + $ 1, ZERO, TM(1,LB), 1 ) + CALL DGEMM( 'T', 'N', LH-KH, LB, KB, ONE, E(KL,KH+1), + $ LDE, TM, 2, ONE, X(KH+1,LL), LDX ) + END IF +C + GOTO 60 + END IF +C END WHILE 60 +C + GOTO 20 + END IF +C END WHILE 20 +C + ELSE +C +C Solve equation (2). +C +C Outer Loop. Compute block column X(:,LL:LH). LB denotes the +C number of columns in this block column. +C + LL = N + 1 +C WHILE ( LL .GT. 1 ) DO + 100 IF ( LL .GT. 1 ) THEN + LH = LL - 1 + IF ( LH .EQ. 1 ) THEN + LB = 1 + ELSE + IF ( A(LL-1,LL-2) .NE. ZERO ) THEN + LB = 2 + ELSE + LB = 1 + END IF + END IF + LL = LL - LB +C +C Copy elements of solution already known by symmetry. +C +C X(LH+1:N,LL:LH) = X(LL:LH,LH+1:N)' +C + IF ( LH .LT. N ) THEN + DO 120 I = LL, LH + CALL DCOPY( N-LH, X(I,LH+1), LDX, X(LH+1,I), 1 ) + 120 CONTINUE + END IF +C +C Inner Loop. Compute block X(KL:KH,LL:LH). KB denotes the +C number of rows in this block. +C + KL = LH + 1 +C WHILE ( KL .GT. 1 ) DO + 140 IF ( KL .GT. 1 ) THEN + KH = KL - 1 + IF ( KH .EQ. 1 ) THEN + KB = 1 + ELSE + IF ( A(KL-1,KL-2) .NE. ZERO ) THEN + KB =2 + ELSE + KB = 1 + END IF + END IF + KL = KL - KB +C +C Update right hand sides (I). +C +C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) - +C (A(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*A(KL:LH,LL:LH)' +C +C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) + +C (E(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*E(KL:LH,LL:LH)' +C + IF ( KH .LT. N ) THEN + CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, A(KL,KH+1), + $ LDA, X(KH+1,LL), LDX, ZERO, TM, 2 ) + CALL DGEMM( 'N', 'T', KB, LH-KL+1, LB, MONE, TM, 2, + $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) + CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, E(KL,KH+1), + $ LDE, X(KH+1,LL), LDX, ZERO, TM, 2 ) + CALL DGEMM( 'N', 'T', KB, LL-KL+1, LB, ONE, TM, 2, + $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) + IF ( LB .EQ. 2 ) CALL DAXPY( KB, E(LH,LH), TM(1,2), 1, + $ X(KL,LH), 1 ) + END IF +C +C Solve small Sylvester equations of order at most (2,2). +C + IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 1 +C + MAT(1,1) = A(LL,LL)*A(KL,KL) - E(LL,LL)*E(KL,KL) +C + RHS(1) = X(KL,LL) +C + ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) + AK12 = A(KL,KH) + AK21 = A(KH,KL) + AK22 = A(KH,KH) +C + AL11 = A(LL,LL) +C + EK11 = E(KL,KL) + EK12 = E(KL,KH) + EK22 = E(KH,KH) +C + EL11 = E(LL,LL) +C + MAT(1,1) = AL11*AK11 - EL11*EK11 + MAT(1,2) = AL11*AK12 - EL11*EK12 + MAT(2,1) = AL11*AK21 + MAT(2,2) = AL11*AK22 - EL11*EK22 +C + RHS(1) = X(KL,LL) + RHS(2) = X(KH,LL) +C + ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) +C + AL11 = A(LL,LL) + AL12 = A(LL,LH) + AL21 = A(LH,LL) + AL22 = A(LH,LH) +C + EK11 = E(KL,KL) +C + EL11 = E(LL,LL) + EL12 = E(LL,LH) + EL22 = E(LH,LH) +C + MAT(1,1) = AL11*AK11 - EL11*EK11 + MAT(1,2) = AL12*AK11 - EL12*EK11 + MAT(2,1) = AL21*AK11 + MAT(2,2) = AL22*AK11 - EL22*EK11 +C + RHS(1) = X(KL,LL) + RHS(2) = X(KL,LH) +C + ELSE +C + DIMMAT = 4 +C + AK11 = A(KL,KL) + AK12 = A(KL,KH) + AK21 = A(KH,KL) + AK22 = A(KH,KH) +C + AL11 = A(LL,LL) + AL12 = A(LL,LH) + AL21 = A(LH,LL) + AL22 = A(LH,LH) +C + EK11 = E(KL,KL) + EK12 = E(KL,KH) + EK22 = E(KH,KH) +C + EL11 = E(LL,LL) + EL12 = E(LL,LH) + EL22 = E(LH,LH) +C + MAT(1,1) = AL11*AK11 - EL11*EK11 + MAT(1,2) = AL11*AK12 - EL11*EK12 + MAT(1,3) = AL12*AK11 - EL12*EK11 + MAT(1,4) = AL12*AK12 - EL12*EK12 +C + MAT(2,1) = AL11*AK21 + MAT(2,2) = AL11*AK22 - EL11*EK22 + MAT(2,3) = AL12*AK21 + MAT(2,4) = AL12*AK22 - EL12*EK22 +C + MAT(3,1) = AL21*AK11 + MAT(3,2) = AL21*AK12 + MAT(3,3) = AL22*AK11 - EL22*EK11 + MAT(3,4) = AL22*AK12 - EL22*EK12 +C + MAT(4,1) = AL21*AK21 + MAT(4,2) = AL21*AK22 + MAT(4,3) = AL22*AK21 + MAT(4,4) = AL22*AK22 - EL22*EK22 +C + RHS(1) = X(KL,LL) + IF ( KL .EQ. LL ) THEN + RHS(2) = X(KL,KH) + ELSE + RHS(2) = X(KH,LL) + END IF + RHS(3) = X(KL,LH) + RHS(4) = X(KH,LH) +C + END IF +C + CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) +C +C Scaling. +C + IF ( SCALE1 .NE. ONE ) THEN + DO 160 I = 1, N + CALL DSCAL( N, SCALE1, X(1,I), 1 ) + 160 CONTINUE + SCALE = SCALE*SCALE1 + END IF +C + IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN + X(KL,LL) = RHS(1) + ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN + X(KL,LL) = RHS(1) + X(KH,LL) = RHS(2) + ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN + X(KL,LL) = RHS(1) + X(KL,LH) = RHS(2) + ELSE + X(KL,LL) = RHS(1) + X(KH,LL) = RHS(2) + X(KL,LH) = RHS(3) + X(KH,LH) = RHS(4) + END IF +C +C Update right hand sides (II). +C +C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) - +C (A(KL:KH,KL:KH)*X(KL:KH,LL:LH))*A(KL:LL-1,LL:LH)' +C +C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) + +C (E(KL:KH,KL:KH)*X(KL:KH,LL:LH))*E(KL:LL-1,LL:LH)' +C + IF ( KL .LT. LL ) THEN + CALL DGEMM( 'N', 'N', KB, LB, KB, ONE, A(KL,KL), LDA, + $ X(KL,LL), LDX, ZERO, TM, 2 ) + CALL DGEMM( 'N', 'T', KB, LL-KL, LB, MONE, TM, 2, + $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) + CALL DGEMV( 'T', KB, LB, ONE, X(KL,LL), LDX, E(KL,KL), + $ LDE, ZERO, TM, 2 ) + IF ( KB .EQ. 2 ) THEN + CALL DCOPY( LB, X(KH,LL), LDX, TM(2,1), 2 ) + CALL DSCAL( LB, E(KH,KH), TM(2,1), 2 ) + END IF + CALL DGEMM( 'N', 'T', KB, LL-KL, LB, ONE, TM, 2, + $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) + END IF +C + GOTO 140 + END IF +C END WHILE 140 +C + GOTO 100 + END IF +C END WHILE 100 +C + END IF +C + RETURN +C *** Last line of SG03AX *** + END diff --git a/mex/sources/libslicot/SG03AY.f b/mex/sources/libslicot/SG03AY.f new file mode 100644 index 000000000..4f2dfe5ab --- /dev/null +++ b/mex/sources/libslicot/SG03AY.f @@ -0,0 +1,686 @@ + SUBROUTINE SG03AY( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X either the reduced generalized continuous-time +C Lyapunov equation +C +C T T +C A * X * E + E * X * A = SCALE * Y (1) +C +C or +C +C T T +C A * X * E + E * X * A = SCALE * Y (2) +C +C where the right hand side Y is symmetric. A, E, Y, and the +C solution X are N-by-N matrices. The pencil A - lambda * E must be +C in generalized Schur form (A upper quasitriangular, E upper +C triangular). SCALE is an output scale factor, set to avoid +C overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANS CHARACTER*1 +C Specifies whether the transposed equation is to be solved +C or not: +C = 'N': Solve equation (1); +C = 'T': Solve equation (2). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain the quasitriangular matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N upper triangular part of this array +C must contain the matrix E. +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, the leading N-by-N part of this array must +C contain the right hand side matrix Y of the equation. Only +C the upper triangular part of this matrix need be given. +C On exit, the leading N-by-N part of this array contains +C the solution matrix X of the equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in X. +C (0 < SCALE <= 1) +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: equation is (almost) singular to working precision; +C perturbed values were used to solve the equation +C (but the matrices A and E are unchanged). +C +C METHOD +C +C The solution X of (1) or (2) is computed via block back +C substitution or block forward substitution, respectively. (See +C [1] and [2] for details.) +C +C REFERENCES +C +C [1] Bartels, R.H., Stewart, G.W. +C Solution of the equation A X + X B = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C NUMERICAL ASPECTS +C +C 8/3 * N**3 flops are required by the routine. Note that we count a +C single floating point arithmetic operation as one flop. +C +C The algorithm is backward stable if the eigenvalues of the pencil +C A - lambda * E are real. Otherwise, linear systems of order at +C most 4 are involved into the computation. These systems are solved +C by Gauss elimination with complete pivoting. The loss of stability +C of the Gauss elimination with complete pivoting is rarely +C encountered in practice. +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C Dec. 1998 (V. Sima). +C +C KEYWORDS +C +C Lyapunov equation +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION MONE, ONE, ZERO + PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER TRANS + DOUBLE PRECISION SCALE + INTEGER INFO, LDA, LDE, LDX, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), E(LDE,*), X(LDX,*) +C .. Local Scalars .. + INTEGER DIMMAT, I, INFO1, KB, KH, KL, LB, LH, LL + DOUBLE PRECISION AK11, AK12, AK21, AK22, AL11, AL12, AL21, AL22, + $ EK11, EK12, EK22, EL11, EL12, EL22, SCALE1 + LOGICAL NOTRNS +C .. Local Arrays .. + DOUBLE PRECISION MAT(4,4), RHS(4), TM(2,2) + INTEGER PIV1(4), PIV2(4) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DSCAL, MB02UU, + $ MB02UV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Decode input parameters. +C + NOTRNS = LSAME( TRANS, 'N' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN + INFO = -1 + ELSEIF ( N .LT. 0 ) THEN + INFO = -2 + ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN + INFO = -4 + ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN + INFO = -6 + ELSEIF ( LDX .LT. MAX( 1, N ) ) THEN + INFO = -8 + ELSE + INFO = 0 + END IF + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SG03AY', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF ( N .EQ. 0 ) RETURN +C + IF ( NOTRNS ) THEN +C +C Solve equation (1). +C +C Outer Loop. Compute block row X(KL:KH,:). KB denotes the number +C of rows in this block row. +C + KL = 0 + KB = 1 +C WHILE ( KL+KB .LE. N ) DO + 20 IF ( KL+KB .LE. N ) THEN + KL = KL + KB + IF ( KL .EQ. N ) THEN + KB = 1 + ELSE + IF ( A(KL+1,KL) .NE. ZERO ) THEN + KB = 2 + ELSE + KB = 1 + END IF + END IF + KH = KL + KB - 1 +C +C Copy elements of solution already known by symmetry. +C +C X(KL:KH,1:KL-1) = X(1:KL-1,KL:KH)' +C + IF ( KL .GT. 1 ) THEN + DO 40 I = KL, KH + CALL DCOPY( KL-1, X(1,I), 1, X(I,1), LDX ) + 40 CONTINUE + END IF +C +C Inner Loop. Compute block X(KL:KH,LL:LH). LB denotes the +C number of columns in this block. +C + LL = KL - 1 + LB = 1 +C WHILE ( LL+LB .LE. N ) DO + 60 IF ( LL+LB .LE. N ) THEN + LL = LL + LB + IF ( LL .EQ. N ) THEN + LB = 1 + ELSE + IF ( A(LL+1,LL) .NE. ZERO ) THEN + LB = 2 + ELSE + LB = 1 + END IF + END IF + LH = LL + LB - 1 +C +C Update right hand sides (I). +C +C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) - +C A(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*E(1:LL-1,LL:LH)) +C +C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) - +C E(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*A(1:LL-1,LL:LH)) +C + IF ( LL .GT. 1 ) THEN + CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), LDX, + $ E(1,LL), LDE, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', LH-KL+1, LB, KB, MONE, A(KL,KL), + $ LDA, TM, 2, ONE, X(KL,LL), LDX ) + CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), LDX, + $ A(1,LL), LDA, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', LH-KH+1, LB, KB, MONE, E(KL,KH), + $ LDE, TM, 2, ONE, X(KH,LL), LDX ) + IF ( KB .EQ. 2 ) CALL DAXPY( LB, -E(KL,KL), TM, 2, + $ X(KL,LL), LDX ) + END IF +C +C Solve small Sylvester equations of order at most (2,2). +C + IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 1 +C + MAT(1,1) = E(LL,LL)*A(KL,KL) + A(LL,LL)*E(KL,KL) +C + RHS(1) = X(KL,LL) +C + ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) + AK12 = A(KL,KH) + AK21 = A(KH,KL) + AK22 = A(KH,KH) +C + AL11 = A(LL,LL) +C + EK11 = E(KL,KL) + EK12 = E(KL,KH) + EK22 = E(KH,KH) +C + EL11 = E(LL,LL) +C + MAT(1,1) = EL11*AK11 + AL11*EK11 + MAT(1,2) = EL11*AK21 + MAT(2,1) = EL11*AK12 + AL11*EK12 + MAT(2,2) = EL11*AK22 + AL11*EK22 +C + RHS(1) = X(KL,LL) + RHS(2) = X(KH,LL) +C + ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) +C + AL11 = A(LL,LL) + AL12 = A(LL,LH) + AL21 = A(LH,LL) + AL22 = A(LH,LH) +C + EK11 = E(KL,KL) +C + EL11 = E(LL,LL) + EL12 = E(LL,LH) + EL22 = E(LH,LH) +C + MAT(1,1) = EL11*AK11 + AL11*EK11 + MAT(1,2) = AL21*EK11 + MAT(2,1) = EL12*AK11 + AL12*EK11 + MAT(2,2) = EL22*AK11 + AL22*EK11 +C + RHS(1) = X(KL,LL) + RHS(2) = X(KL,LH) +C + ELSE +C + DIMMAT = 4 +C + AK11 = A(KL,KL) + AK12 = A(KL,KH) + AK21 = A(KH,KL) + AK22 = A(KH,KH) +C + AL11 = A(LL,LL) + AL12 = A(LL,LH) + AL21 = A(LH,LL) + AL22 = A(LH,LH) +C + EK11 = E(KL,KL) + EK12 = E(KL,KH) + EK22 = E(KH,KH) +C + EL11 = E(LL,LL) + EL12 = E(LL,LH) + EL22 = E(LH,LH) +C + MAT(1,1) = EL11*AK11 + AL11*EK11 + MAT(1,2) = EL11*AK21 + MAT(1,3) = AL21*EK11 + MAT(1,4) = ZERO +C + MAT(2,1) = EL11*AK12 + AL11*EK12 + MAT(2,2) = EL11*AK22 + AL11*EK22 + MAT(2,3) = AL21*EK12 + MAT(2,4) = AL21*EK22 +C + MAT(3,1) = EL12*AK11 + AL12*EK11 + MAT(3,2) = EL12*AK21 + MAT(3,3) = EL22*AK11 + AL22*EK11 + MAT(3,4) = EL22*AK21 +C + MAT(4,1) = EL12*AK12 + AL12*EK12 + MAT(4,2) = EL12*AK22 + AL12*EK22 + MAT(4,3) = EL22*AK12 + AL22*EK12 + MAT(4,4) = EL22*AK22 + AL22*EK22 +C + RHS(1) = X(KL,LL) + IF ( KL .EQ. LL ) THEN + RHS(2) = X(KL,KH) + ELSE + RHS(2) = X(KH,LL) + END IF + RHS(3) = X(KL,LH) + RHS(4) = X(KH,LH) +C + END IF +C + CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) +C +C Scaling. +C + IF ( SCALE1 .NE. ONE ) THEN + DO 80 I = 1, N + CALL DSCAL( N, SCALE1, X(1,I), 1 ) + 80 CONTINUE + SCALE = SCALE*SCALE1 + END IF +C + IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN + X(KL,LL) = RHS(1) + ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN + X(KL,LL) = RHS(1) + X(KH,LL) = RHS(2) + ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN + X(KL,LL) = RHS(1) + X(KL,LH) = RHS(2) + ELSE + X(KL,LL) = RHS(1) + X(KH,LL) = RHS(2) + X(KL,LH) = RHS(3) + X(KH,LH) = RHS(4) + END IF +C +C Update right hand sides (II). +C +C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) - +C A(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*E(LL:LH,LL:LH)) +C +C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) - +C E(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*A(LL:LH,LL:LH)) +C + IF ( KL .LT. LL ) THEN + IF ( LB .EQ. 2 ) + $ CALL DGEMV( 'N', KB, 2, ONE, X(KL,LL), LDX, + $ E(LL,LH), 1, ZERO, TM(1,2), 1 ) + CALL DCOPY( KB, X(KL,LL), 1, TM, 1 ) + CALL DSCAL( KB, E(LL,LL), TM, 1 ) + CALL DGEMM( 'T', 'N', LH-KH, LB, KB, MONE, A(KL,KH+1), + $ LDA, TM, 2, ONE, X(KH+1,LL), LDX ) + CALL DGEMM( 'N', 'N', KB, LB, LB, ONE, X(KL,LL), LDX, + $ A(LL,LL), LDA, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', LH-KH, LB, KB, MONE, E(KL,KH+1), + $ LDE, TM, 2, ONE, X(KH+1,LL), LDX ) + END IF +C + GOTO 60 + END IF +C END WHILE 60 +C + GOTO 20 + END IF +C END WHILE 20 +C + ELSE +C +C Solve equation (2). +C +C Outer Loop. Compute block column X(:,LL:LH). LB denotes the +C number of columns in this block column. +C + LL = N + 1 +C WHILE ( LL .GT. 1 ) DO + 100 IF ( LL .GT. 1 ) THEN + LH = LL - 1 + IF ( LH .EQ. 1 ) THEN + LB = 1 + ELSE + IF ( A(LL-1,LL-2) .NE. ZERO ) THEN + LB = 2 + ELSE + LB = 1 + END IF + END IF + LL = LL - LB +C +C Copy elements of solution already known by symmetry. +C +C X(LH+1:N,LL:LH) = X(LL:LH,LH+1:N)' +C + IF ( LH .LT. N ) THEN + DO 120 I = LL, LH + CALL DCOPY( N-LH, X(I,LH+1), LDX, X(LH+1,I), 1 ) + 120 CONTINUE + END IF +C +C Inner Loop. Compute block X(KL:KH,LL:LH). KB denotes the +C number of rows in this block. +C + KL = LH + 1 +C WHILE ( KL .GT. 1 ) DO + 140 IF ( KL .GT. 1 ) THEN + KH = KL - 1 + IF ( KH .EQ. 1 ) THEN + KB = 1 + ELSE + IF ( A(KL-1,KL-2) .NE. ZERO ) THEN + KB = 2 + ELSE + KB = 1 + END IF + END IF + KL = KL - KB +C +C Update right hand sides (I). +C +C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) - +C (A(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*E(KL:LH,LL:LH)' +C +C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) - +C (E(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*A(KL:LH,LL:LH)' +C + IF ( KH .LT. N ) THEN + CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, A(KL,KH+1), + $ LDA, X(KH+1,LL), LDX, ZERO, TM, 2 ) + CALL DGEMM( 'N', 'T', KB, LL-KL+1, LB, MONE, TM, 2, + $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) + IF ( LB .EQ. 2 ) CALL DAXPY( KB, -E(LH,LH), TM(1,2), + $ 1, X(KL,LH), 1 ) + CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, E(KL,KH+1), + $ LDE, X(KH+1,LL), LDX, ZERO, TM, 2 ) + CALL DGEMM( 'N', 'T', KB, LH-KL+1, LB, MONE, TM, 2, + $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) + END IF +C +C Solve small Sylvester equations of order at most (2,2). +C + IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 1 +C + MAT(1,1) = E(LL,LL)*A(KL,KL) + A(LL,LL)*E(KL,KL) +C + RHS(1) = X(KL,LL) +C + ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) + AK12 = A(KL,KH) + AK21 = A(KH,KL) + AK22 = A(KH,KH) +C + AL11 = A(LL,LL) +C + EK11 = E(KL,KL) + EK12 = E(KL,KH) + EK22 = E(KH,KH) +C + EL11 = E(LL,LL) +C + MAT(1,1) = EL11*AK11 + AL11*EK11 + MAT(1,2) = EL11*AK12 + AL11*EK12 + MAT(2,1) = EL11*AK21 + MAT(2,2) = EL11*AK22 + AL11*EK22 +C + RHS(1) = X(KL,LL) + RHS(2) = X(KH,LL) +C + ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) +C + AL11 = A(LL,LL) + AL12 = A(LL,LH) + AL21 = A(LH,LL) + AL22 = A(LH,LH) +C + EK11 = E(KL,KL) +C + EL11 = E(LL,LL) + EL12 = E(LL,LH) + EL22 = E(LH,LH) +C + MAT(1,1) = EL11*AK11 + AL11*EK11 + MAT(1,2) = EL12*AK11 + AL12*EK11 + MAT(2,1) = AL21*EK11 + MAT(2,2) = EL22*AK11 + AL22*EK11 +C + RHS(1) = X(KL,LL) + RHS(2) = X(KL,LH) +C + ELSE +C + DIMMAT = 4 +C + AK11 = A(KL,KL) + AK12 = A(KL,KH) + AK21 = A(KH,KL) + AK22 = A(KH,KH) +C + AL11 = A(LL,LL) + AL12 = A(LL,LH) + AL21 = A(LH,LL) + AL22 = A(LH,LH) +C + EK11 = E(KL,KL) + EK12 = E(KL,KH) + EK22 = E(KH,KH) +C + EL11 = E(LL,LL) + EL12 = E(LL,LH) + EL22 = E(LH,LH) +C + MAT(1,1) = EL11*AK11 + AL11*EK11 + MAT(1,2) = EL11*AK12 + AL11*EK12 + MAT(1,3) = EL12*AK11 + AL12*EK11 + MAT(1,4) = EL12*AK12 + AL12*EK12 +C + MAT(2,1) = EL11*AK21 + MAT(2,2) = EL11*AK22 + AL11*EK22 + MAT(2,3) = EL12*AK21 + MAT(2,4) = EL12*AK22 + AL12*EK22 +C + MAT(3,1) = AL21*EK11 + MAT(3,2) = AL21*EK12 + MAT(3,3) = EL22*AK11 + AL22*EK11 + MAT(3,4) = EL22*AK12 + AL22*EK12 +C + MAT(4,1) = ZERO + MAT(4,2) = AL21*EK22 + MAT(4,3) = EL22*AK21 + MAT(4,4) = EL22*AK22 + AL22*EK22 +C + RHS(1) = X(KL,LL) + IF ( KL .EQ. LL ) THEN + RHS(2) = X(KL,KH) + ELSE + RHS(2) = X(KH,LL) + END IF + RHS(3) = X(KL,LH) + RHS(4) = X(KH,LH) +C + END IF +C + CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) +C +C Scaling. +C + IF ( SCALE1 .NE. ONE ) THEN + DO 160 I = 1, N + CALL DSCAL( N, SCALE1, X(1,I), 1 ) + 160 CONTINUE + SCALE = SCALE*SCALE1 + END IF +C + IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN + X(KL,LL) = RHS(1) + ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN + X(KL,LL) = RHS(1) + X(KH,LL) = RHS(2) + ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN + X(KL,LL) = RHS(1) + X(KL,LH) = RHS(2) + ELSE + X(KL,LL) = RHS(1) + X(KH,LL) = RHS(2) + X(KL,LH) = RHS(3) + X(KH,LH) = RHS(4) + END IF +C +C Update right hand sides (II). +C +C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) - +C (A(KL:KH,KL:KH)*X(KL:KH,LL:LH))*E(KL:LL-1,LL:LH)' +C +C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) - +C (E(KL:KH,KL:KH)*X(KL:KH,LL:LH))*A(KL:LL-1,LL:LH)' +C + IF ( KL .LT. LL ) THEN + CALL DGEMM( 'N', 'N', KB, LB, KB, ONE, A(KL,KL), LDA, + $ X(KL,LL), LDX, ZERO, TM, 2 ) + CALL DGEMM( 'N', 'T', KB, LL-KL, LB, MONE, TM, 2, + $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) + CALL DGEMV( 'T', KB, LB, ONE, X(KL,LL), LDX, E(KL,KL), + $ LDE, ZERO, TM, 2 ) + IF ( KB .EQ. 2 ) THEN + CALL DCOPY( LB, X(KH,LL), LDX, TM(2,1), 2 ) + CALL DSCAL( LB, E(KH,KH), TM(2,1), 2 ) + END IF + CALL DGEMM( 'N', 'T', KB, LL-KL, LB, MONE, TM, 2, + $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) + END IF +C + GOTO 140 + END IF +C END WHILE 140 +C + GOTO 100 + END IF +C END WHILE 100 +C + END IF +C + RETURN +C *** Last line of SG03AY *** + END diff --git a/mex/sources/libslicot/SG03BD.f b/mex/sources/libslicot/SG03BD.f new file mode 100644 index 000000000..6bcd7400b --- /dev/null +++ b/mex/sources/libslicot/SG03BD.f @@ -0,0 +1,814 @@ + SUBROUTINE SG03BD( DICO, FACT, TRANS, N, M, A, LDA, E, LDE, Q, + $ LDQ, Z, LDZ, B, LDB, SCALE, ALPHAR, ALPHAI, + $ BETA, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Cholesky factor U of the matrix X, +C +C T +C X = op(U) * op(U), +C +C which is the solution of either the generalized +C c-stable continuous-time Lyapunov equation +C +C T T +C op(A) * X * op(E) + op(E) * X * op(A) +C +C 2 T +C = - SCALE * op(B) * op(B), (1) +C +C or the generalized d-stable discrete-time Lyapunov equation +C +C T T +C op(A) * X * op(A) - op(E) * X * op(E) +C +C 2 T +C = - SCALE * op(B) * op(B), (2) +C +C without first finding X and without the need to form the matrix +C op(B)**T * op(B). +C +C op(K) is either K or K**T for K = A, B, E, U. A and E are N-by-N +C matrices, op(B) is an M-by-N matrix. The resulting matrix U is an +C N-by-N upper triangular matrix with non-negative entries on its +C main diagonal. SCALE is an output scale factor set to avoid +C overflow in U. +C +C In the continuous-time case (1) the pencil A - lambda * E must be +C c-stable (that is, all eigenvalues must have negative real parts). +C In the discrete-time case (2) the pencil A - lambda * E must be +C d-stable (that is, the moduli of all eigenvalues must be smaller +C than one). +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies which type of the equation is considered: +C = 'C': Continuous-time equation (1); +C = 'D': Discrete-time equation (2). +C +C FACT CHARACTER*1 +C Specifies whether the generalized real Schur +C factorization of the pencil A - lambda * E is supplied +C on entry or not: +C = 'N': Factorization is not supplied; +C = 'F': Factorization is supplied. +C +C TRANS CHARACTER*1 +C Specifies whether the transposed equation is to be solved +C or not: +C = 'N': op(A) = A, op(E) = E; +C = 'T': op(A) = A**T, op(E) = E**T. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of rows in the matrix op(B). M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, if FACT = 'F', then the leading N-by-N upper +C Hessenberg part of this array must contain the +C generalized Schur factor A_s of the matrix A (see +C definition (3) in section METHOD). A_s must be an upper +C quasitriangular matrix. The elements below the upper +C Hessenberg part of the array A are not referenced. +C If FACT = 'N', then the leading N-by-N part of this +C array must contain the matrix A. +C On exit, the leading N-by-N part of this array contains +C the generalized Schur factor A_s of the matrix A. (A_s is +C an upper quasitriangular matrix.) +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, if FACT = 'F', then the leading N-by-N upper +C triangular part of this array must contain the +C generalized Schur factor E_s of the matrix E (see +C definition (4) in section METHOD). The elements below the +C upper triangular part of the array E are not referenced. +C If FACT = 'N', then the leading N-by-N part of this +C array must contain the coefficient matrix E of the +C equation. +C On exit, the leading N-by-N part of this array contains +C the generalized Schur factor E_s of the matrix E. (E_s is +C an upper triangular matrix.) +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, if FACT = 'F', then the leading N-by-N part of +C this array must contain the orthogonal matrix Q from +C the generalized Schur factorization (see definitions (3) +C and (4) in section METHOD). +C If FACT = 'N', Q need not be set on entry. +C On exit, the leading N-by-N part of this array contains +C the orthogonal matrix Q from the generalized Schur +C factorization. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= MAX(1,N). +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C On entry, if FACT = 'F', then the leading N-by-N part of +C this array must contain the orthogonal matrix Z from +C the generalized Schur factorization (see definitions (3) +C and (4) in section METHOD). +C If FACT = 'N', Z need not be set on entry. +C On exit, the leading N-by-N part of this array contains +C the orthogonal matrix Z from the generalized Schur +C factorization. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N1) +C On entry, if TRANS = 'T', the leading N-by-M part of this +C array must contain the matrix B and N1 >= MAX(M,N). +C If TRANS = 'N', the leading M-by-N part of this array +C must contain the matrix B and N1 >= N. +C On exit, the leading N-by-N part of this array contains +C the Cholesky factor U of the solution matrix X of the +C problem, X = op(U)**T * op(U). +C If M = 0 and N > 0, then U is set to zero. +C +C LDB INTEGER +C The leading dimension of the array B. +C If TRANS = 'T', LDB >= MAX(1,N). +C If TRANS = 'N', LDB >= MAX(1,M,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in U. +C 0 < SCALE <= 1. +C +C ALPHAR (output) DOUBLE PRECISION array, dimension (N) +C ALPHAI (output) DOUBLE PRECISION array, dimension (N) +C BETA (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, 3, 5, 6, or 7, then +C (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, are the +C eigenvalues of the matrix pencil A - lambda * E. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= MAX(1,4*N,6*N-6), if FACT = 'N'; +C LDWORK >= MAX(1,2*N,6*N-6), if FACT = 'F'. +C For good performance, LDWORK should be larger. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the pencil A - lambda * E is (nearly) singular; +C perturbed values were used to solve the equation +C (but the reduced (quasi)triangular matrices A and E +C are unchanged); +C = 2: FACT = 'F' and the matrix contained in the upper +C Hessenberg part of the array A is not in upper +C quasitriangular form; +C = 3: FACT = 'F' and there is a 2-by-2 block on the main +C diagonal of the pencil A_s - lambda * E_s whose +C eigenvalues are not conjugate complex; +C = 4: FACT = 'N' and the pencil A - lambda * E cannot be +C reduced to generalized Schur form: LAPACK routine +C DGEGS has failed to converge; +C = 5: DICO = 'C' and the pencil A - lambda * E is not +C c-stable; +C = 6: DICO = 'D' and the pencil A - lambda * E is not +C d-stable; +C = 7: the LAPACK routine DSYEVX utilized to factorize M3 +C failed to converge in the discrete-time case (see +C section METHOD for SLICOT Library routine SG03BU). +C This error is unlikely to occur. +C +C METHOD +C +C An extension [2] of Hammarling's method [1] to generalized +C Lyapunov equations is utilized to solve (1) or (2). +C +C First the pencil A - lambda * E is reduced to real generalized +C Schur form A_s - lambda * E_s by means of orthogonal +C transformations (QZ-algorithm): +C +C A_s = Q**T * A * Z (upper quasitriangular) (3) +C +C E_s = Q**T * E * Z (upper triangular). (4) +C +C If the pencil A - lambda * E has already been factorized prior to +C calling the routine however, then the factors A_s, E_s, Q and Z +C may be supplied and the initial factorization omitted. +C +C Depending on the parameters TRANS and M the N-by-N upper +C triangular matrix B_s is defined as follows. In any case Q_B is +C an M-by-M orthogonal matrix, which need not be accumulated. +C +C 1. If TRANS = 'N' and M < N, B_s is the upper triangular matrix +C from the QR-factorization +C +C ( Q_B O ) ( B * Z ) +C ( ) * B_s = ( ), +C ( O I ) ( O ) +C +C where the O's are zero matrices of proper size and I is the +C identity matrix of order N-M. +C +C 2. If TRANS = 'N' and M >= N, B_s is the upper triangular matrix +C from the (rectangular) QR-factorization +C +C ( B_s ) +C Q_B * ( ) = B * Z, +C ( O ) +C +C where O is the (M-N)-by-N zero matrix. +C +C 3. If TRANS = 'T' and M < N, B_s is the upper triangular matrix +C from the RQ-factorization +C +C ( Q_B O ) +C (B_s O ) * ( ) = ( Q**T * B O ). +C ( O I ) +C +C 4. If TRANS = 'T' and M >= N, B_s is the upper triangular matrix +C from the (rectangular) RQ-factorization +C +C ( B_s O ) * Q_B = Q**T * B, +C +C where O is the N-by-(M-N) zero matrix. +C +C Assuming SCALE = 1, the transformation of A, E and B described +C above leads to the reduced continuous-time equation +C +C T T +C op(A_s) op(U_s) op(U_s) op(E_s) +C +C T T +C + op(E_s) op(U_s) op(U_s) op(A_s) +C +C T +C = - op(B_s) op(B_s) (5) +C +C or to the reduced discrete-time equation +C +C T T +C op(A_s) op(U_s) op(U_s) op(A_s) +C +C T T +C - op(E_s) op(U_s) op(U_s) op(E_s) +C +C T +C = - op(B_s) op(B_s). (6) +C +C For brevity we restrict ourself to equation (5) and the case +C TRANS = 'N'. The other three cases can be treated in a similar +C fashion. +C +C We use the following partitioning for the matrices A_s, E_s, B_s +C and U_s +C +C ( A11 A12 ) ( E11 E12 ) +C A_s = ( ), E_s = ( ), +C ( 0 A22 ) ( 0 E22 ) +C +C ( B11 B12 ) ( U11 U12 ) +C B_s = ( ), U_s = ( ). (7) +C ( 0 B22 ) ( 0 U22 ) +C +C The size of the (1,1)-blocks is 1-by-1 (iff A_s(2,1) = 0.0) or +C 2-by-2. +C +C We compute U11 and U12**T in three steps. +C +C Step I: +C +C From (5) and (7) we get the 1-by-1 or 2-by-2 equation +C +C T T T T +C A11 * U11 * U11 * E11 + E11 * U11 * U11 * A11 +C +C T +C = - B11 * B11. +C +C For brevity, details are omitted here. See [2]. The technique +C for computing U11 is similar to those applied to standard +C Lyapunov equations in Hammarling's algorithm ([1], section 6). +C +C Furthermore, the auxiliary matrices M1 and M2 defined as +C follows +C +C -1 -1 +C M1 = U11 * A11 * E11 * U11 +C +C -1 -1 +C M2 = B11 * E11 * U11 +C +C are computed in a numerically reliable way. +C +C Step II: +C +C The generalized Sylvester equation +C +C T T T T +C A22 * U12 + E22 * U12 * M1 = +C +C T T T T T +C - B12 * M2 - A12 * U11 - E12 * U11 * M1 +C +C is solved for U12**T. +C +C Step III: +C +C It can be shown that +C +C T T T T +C A22 * U22 * U22 * E22 + E22 * U22 * U22 * A22 = +C +C T T +C - B22 * B22 - y * y (8) +C +C holds, where y is defined as +C +C T T T T T T +C y = B12 - ( E12 * U11 + E22 * U12 ) * M2 . +C +C If B22_tilde is the square triangular matrix arising from the +C (rectangular) QR-factorization +C +C ( B22_tilde ) ( B22 ) +C Q_B_tilde * ( ) = ( ), +C ( O ) ( y**T ) +C +C where Q_B_tilde is an orthogonal matrix of order N, then +C +C T T T +C - B22 * B22 - y * y = - B22_tilde * B22_tilde. +C +C Replacing the right hand side in (8) by the term +C - B22_tilde**T * B22_tilde leads to a reduced generalized +C Lyapunov equation of lower dimension compared to (5). +C +C The recursive application of the steps I to III yields the +C solution U_s of the equation (5). +C +C It remains to compute the solution matrix U of the original +C problem (1) or (2) from the matrix U_s. To this end we transform +C the solution back (with respect to the transformation that led +C from (1) to (5) (from (2) to (6)) and apply the QR-factorization +C (RQ-factorization). The upper triangular solution matrix U is +C obtained by +C +C Q_U * U = U_s * Q**T (if TRANS = 'N') +C +C or +C +C U * Q_U = Z * U_s (if TRANS = 'T') +C +C where Q_U is an N-by-N orthogonal matrix. Again, the orthogonal +C matrix Q_U need not be accumulated. +C +C REFERENCES +C +C [1] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-323, 1982. +C +C [2] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C NUMERICAL ASPECTS +C +C The number of flops required by the routine is given by the +C following table. Note that we count a single floating point +C arithmetic operation as one flop. +C +C | FACT = 'F' FACT = 'N' +C ---------+-------------------------------------------------- +C M <= N | (13*N**3+6*M*N**2 (211*N**3+6*M*N**2 +C | +6*M**2*N-2*M**3)/3 +6*M**2*N-2*M**3)/3 +C | +C M > N | (11*N**3+12*M*N**2)/3 (209*N**3+12*M*N**2)/3 +C +C FURTHER COMMENTS +C +C The Lyapunov equation may be very ill-conditioned. In particular, +C if DICO = 'D' and the pencil A - lambda * E has a pair of almost +C reciprocal eigenvalues, or DICO = 'C' and the pencil has an almost +C degenerate pair of eigenvalues, then the Lyapunov equation will be +C ill-conditioned. Perturbed values were used to solve the equation. +C A condition estimate can be obtained from the routine SG03AD. +C When setting the error indicator INFO, the routine does not test +C for near instability in the equation but only for exact +C instability. +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C May 1999 (V. Sima). +C March 2002 (A. Varga). +C Feb. 2004 (V. Sima). +C +C KEYWORDS +C +C Lyapunov equation +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION MONE, ONE, TWO, ZERO + PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION SCALE + INTEGER INFO, LDA, LDB, LDE, LDQ, LDWORK, LDZ, M, N + CHARACTER DICO, FACT, TRANS +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), + $ BETA(*), DWORK(*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + DOUBLE PRECISION S1, S2, SAFMIN, WI, WR1, WR2 + INTEGER I, INFO1, MINMN, MINWRK, OPTWRK + LOGICAL ISDISC, ISFACT, ISTRAN +C .. Local Arrays .. + DOUBLE PRECISION E1(2,2) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + LOGICAL LSAME + EXTERNAL DLAMCH, DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEGS, DGEMM, DGEMV, DGEQRF, DGERQF, + $ DLACPY, DLAG2, DLASET, DSCAL, DTRMM, SG03BU, + $ SG03BV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SIGN +C .. Executable Statements .. +C +C Decode input parameters. +C + ISDISC = LSAME( DICO, 'D' ) + ISFACT = LSAME( FACT, 'F' ) + ISTRAN = LSAME( TRANS, 'T' ) +C +C Compute minimal workspace. +C + IF (ISFACT ) THEN + MINWRK = MAX( 1, 2*N, 6*N-6 ) + ELSE + MINWRK = MAX( 1, 4*N, 6*N-6 ) + END IF +C +C Check the scalar input parameters. +C + IF ( .NOT.( ISDISC .OR. LSAME( DICO, 'C' ) ) ) THEN + INFO = -1 + ELSEIF ( .NOT.( ISFACT .OR. LSAME( FACT, 'N' ) ) ) THEN + INFO = -2 + ELSEIF ( .NOT.( ISTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN + INFO = -3 + ELSEIF ( N .LT. 0 ) THEN + INFO = -4 + ELSEIF ( M .LT. 0 ) THEN + INFO = -5 + ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN + INFO = -7 + ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN + INFO = -9 + ELSEIF ( LDQ .LT. MAX( 1, N ) ) THEN + INFO = -11 + ELSEIF ( LDZ .LT. MAX( 1, N ) ) THEN + INFO = -13 + ELSEIF ( ( ISTRAN .AND. ( LDB .LT. MAX( 1, N ) ) ) .OR. + $ ( .NOT.ISTRAN .AND. ( LDB .LT. MAX( 1, M, N ) ) ) ) THEN + INFO = -15 + ELSEIF ( LDWORK .LT. MINWRK ) THEN + INFO = -21 + ELSE + INFO = 0 + END IF + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SG03BD', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + MINMN = MIN( M, N ) + IF ( MINMN .EQ. 0 ) THEN + IF ( N.GT.0 ) + $ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDB ) + DWORK(1) = ONE + RETURN + ENDIF +C + IF ( ISFACT ) THEN +C +C Make sure the upper Hessenberg part of A is quasitriangular. +C + DO 20 I = 1, N-2 + IF ( A(I+1,I).NE.ZERO .AND. A(I+2,I+1).NE.ZERO ) THEN + INFO = 2 + RETURN + END IF + 20 CONTINUE + END IF +C + IF ( .NOT.ISFACT ) THEN +C +C Reduce the pencil A - lambda * E to generalized Schur form. +C +C A := Q**T * A * Z (upper quasitriangular) +C E := Q**T * E * Z (upper triangular) +C +C ( Workspace: >= MAX(1,4*N) ) +C + CALL DGEGS( 'Vectors', 'Vectors', N, A, LDA, E, LDE, ALPHAR, + $ ALPHAI, BETA, Q, LDQ, Z, LDZ, DWORK, LDWORK, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + INFO = 4 + RETURN + END IF + OPTWRK = INT( DWORK(1) ) + ELSE + OPTWRK = MINWRK + END IF +C + IF ( ISFACT ) THEN +C +C If the matrix pencil A - lambda * E has been in generalized +C Schur form on entry, compute its eigenvalues. +C + SAFMIN = DLAMCH( 'Safe minimum' ) + E1(2,1) = ZERO + I = 1 +C WHILE ( I .LE. N ) DO + 30 IF ( I .LE. N ) THEN + IF ( ( I.EQ.N ) .OR. ( A(MIN( I+1, N ),I).EQ.ZERO ) ) THEN + ALPHAR(I) = A(I,I) + ALPHAI(I) = ZERO + BETA(I) = E(I,I) + I = I+1 + ELSE + E1(1,1) = E(I,I) + E1(1,2) = E(I,I+1) + E1(2,2) = E(I+1,I+1) + CALL DLAG2( A(I,I), LDA, E1, 2, SAFMIN, S1, S2, WR1, WR2, + $ WI ) + IF ( WI .EQ. ZERO ) INFO = 3 + ALPHAR(I) = WR1 + ALPHAI(I) = WI + BETA(I) = S1 + ALPHAR(I+1) = WR2 + ALPHAI(I+1) = -WI + BETA(I+1) = S2 + I = I+2 + END IF + GOTO 30 + END IF +C END WHILE 30 + IF ( INFO.NE.0 ) RETURN + END IF +C +C Check on the stability of the matrix pencil A - lambda * E. +C + DO 40 I = 1, N + IF ( ISDISC ) THEN + IF ( DLAPY2( ALPHAR(I), ALPHAI(I) ) .GE. ABS( BETA(I) ) ) + $ THEN + INFO = 6 + RETURN + END IF + ELSE + IF ( ( ALPHAR(I).EQ.ZERO ) .OR. ( BETA(I).EQ.ZERO ) .OR. + $ ( SIGN( ONE,ALPHAR(I) )*SIGN( ONE, BETA(I) ) .GE. ZERO) ) + $ THEN + INFO = 5 + RETURN + END IF + END IF + 40 CONTINUE +C +C Transformation of the right hand side. +C +C B := B * Z or B := Q**T * B +C +C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. +C +C ( Workspace: max(1,N) ) +C + IF ( .NOT.ISTRAN ) THEN + IF ( LDWORK .GE. N*M ) THEN + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N, ONE, B, + $ LDB, Z, LDZ, ZERO, DWORK, M ) + CALL DLACPY( 'All', M, N, DWORK, M, B, LDB ) + ELSE + DO 60 I = 1, M + CALL DCOPY( N, B(I,1), LDB, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, Z, LDZ, DWORK, 1, + $ ZERO, B(I,1), LDB ) + 60 CONTINUE + END IF + IF ( M .LT. N ) + $ CALL DLASET( 'All', N-M, N, ZERO, ZERO, B(M+1,1), LDB ) + ELSE + IF ( LDWORK .GE. N*M ) THEN + CALL DLACPY( 'All', N, M, B, LDB, DWORK, N ) + CALL DGEMM( 'Transpose', 'NoTranspose', N, M, N, ONE, Q, + $ LDQ, DWORK, N, ZERO, B, LDB ) + ELSE + DO 80 I = 1, M + CALL DCOPY( N, B(1,I), 1, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, Q, LDQ, DWORK, 1, + $ ZERO, B(1,I), 1 ) + 80 CONTINUE + END IF + IF ( M .LT. N ) + $ CALL DLASET( 'All', N, N-M, ZERO, ZERO, B(1,M+1), LDB ) + END IF + OPTWRK = MAX( OPTWRK, N*M ) +C +C Overwrite B with the triangular matrix of its QR-factorization +C or its RQ-factorization. +C (The entries on the main diagonal are non-negative.) +C +C ( Workspace: >= max(1,2*N) ) +C + IF ( .NOT.ISTRAN ) THEN + IF ( M .GE. 2 ) THEN + CALL DGEQRF( M, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, + $ INFO1 ) + CALL DLASET( 'Lower', MAX( M, N )-1, MIN( M, N ), ZERO, + $ ZERO, B(2,1), LDB ) + END IF + DO 100 I = 1, MINMN + IF ( B(I,I) .LT. ZERO ) + $ CALL DSCAL( N+1-I, MONE, B(I,I), LDB ) + 100 CONTINUE + ELSE + IF ( M .GE. 2 ) THEN + CALL DGERQF( N, M, B, LDB, DWORK, DWORK(N+1), LDWORK-N, + $ INFO1 ) + IF ( N .GE. M ) THEN + CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, B(N-M+2,1), + $ LDB ) + IF ( N .GT. M ) THEN + DO 120 I = M, 1, -1 + CALL DCOPY( N, B(1,I), 1, B(1,I+N-M), 1 ) + 120 CONTINUE + CALL DLASET( 'All', N, N-M, ZERO, ZERO, B(1,1), LDB ) + END IF + ELSE + IF ( N .GT. 1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, + $ B(2,M-N+1), LDB ) + DO 140 I = 1, N + CALL DCOPY( N, B(1,M-N+I), 1, B(1,I), 1 ) + 140 CONTINUE + CALL DLASET( 'All', N, M-N, ZERO, ZERO, B(1,N+1), LDB ) + END IF + ELSE + IF ( N .NE. 1 ) THEN + CALL DCOPY( N, B(1,1), 1, B(1,N), 1 ) + CALL DLASET( 'All', N, 1, ZERO, ZERO, B(1,1), LDB ) + END IF + END IF + DO 160 I = N - MINMN + 1, N + IF ( B(I,I) .LT. ZERO ) + $ CALL DSCAL( I, MONE, B(1,I), 1 ) + 160 CONTINUE + END IF + OPTWRK = MAX( OPTWRK, INT( DWORK(N+1) ) + N ) +C +C Solve the reduced generalized Lyapunov equation. +C +C ( Workspace: 6*N-6 ) +C + IF ( ISDISC ) THEN + CALL SG03BU( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + IF ( INFO1 .EQ. 1 ) INFO = 1 + IF ( INFO1 .EQ. 2 ) INFO = 3 + IF ( INFO1 .EQ. 3 ) INFO = 6 + IF ( INFO1 .EQ. 4 ) INFO = 7 + IF ( INFO .NE. 1 ) + $ RETURN + END IF + ELSE + CALL SG03BV( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + IF ( INFO1 .EQ. 1 ) INFO = 1 + IF ( INFO1 .GE. 2 ) INFO = 3 + IF ( INFO1 .EQ. 3 ) INFO = 5 + IF ( INFO .NE. 1 ) + $ RETURN + END IF + END IF +C +C Transform the solution matrix back. +C +C U := U * Q**T or U := Z * U +C +C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. +C +C ( Workspace: max(1,N) ) +C + IF ( .NOT.ISTRAN ) THEN + IF ( LDWORK .GE. N*N ) THEN + CALL DLACPY( 'All', N, N, Q, LDQ, DWORK, N ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'NonUnit', N, N, + $ ONE, B, LDB, DWORK, N) + DO 170 I = 1, N + CALL DCOPY( N, DWORK(N*(I-1)+1), 1, B(I,1), LDB ) + 170 CONTINUE + ELSE + DO 180 I = 1, N + CALL DCOPY( N-I+1, B(I,I), LDB, DWORK, 1 ) + CALL DGEMV( 'NoTranspose', N, N-I+1, ONE, Q(1,I), LDQ, + $ DWORK, 1, ZERO, B(I,1), LDB ) + 180 CONTINUE + END IF + ELSE + IF ( LDWORK .GE. N*N ) THEN + CALL DLACPY( 'All', N, N, Z, LDZ, DWORK, N ) + CALL DTRMM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, + $ N, ONE, B, LDB, DWORK, N ) + CALL DLACPY( 'All', N, N, DWORK, N, B, LDB ) + ELSE + DO 200 I = 1, N + CALL DCOPY( I, B(1,I), 1, DWORK, 1 ) + CALL DGEMV( 'NoTranspose', N, I, ONE, Z, LDZ, DWORK, 1, + $ ZERO, B(1,I), 1 ) + 200 CONTINUE + END IF + END IF + OPTWRK = MAX( OPTWRK, N*N ) +C +C Overwrite U with the triangular matrix of its QR-factorization +C or its RQ-factorization. +C (The entries on the main diagonal are non-negative.) +C +C ( Workspace: >= max(1,2*N) ) +C + IF ( .NOT.ISTRAN ) THEN + CALL DGEQRF( N, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, INFO1 ) + IF ( N .GT. 1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB ) + DO 220 I = 1, N + IF ( B(I,I) .LT. ZERO ) + $ CALL DSCAL( N+1-I, MONE, B(I,I), LDB ) + 220 CONTINUE + ELSE + CALL DGERQF( N, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, INFO1 ) + IF ( N .GT. 1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB ) + DO 240 I = 1, N + IF ( B(I,I) .LT. ZERO ) + $ CALL DSCAL( I, MONE, B(1,I), 1 ) + 240 CONTINUE + END IF + OPTWRK = MAX( OPTWRK, INT( DWORK(N+1) ) + N ) +C + DWORK(1) = DBLE( MAX( OPTWRK, MINWRK ) ) + RETURN +C *** Last line of SG03BD *** + END diff --git a/mex/sources/libslicot/SG03BU.f b/mex/sources/libslicot/SG03BU.f new file mode 100644 index 000000000..0e1084f96 --- /dev/null +++ b/mex/sources/libslicot/SG03BU.f @@ -0,0 +1,696 @@ + SUBROUTINE SG03BU( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, + $ DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Cholesky factor U of the matrix X, X = U**T * U or +C X = U * U**T, which is the solution of the generalized d-stable +C discrete-time Lyapunov equation +C +C T T 2 T +C A * X * A - E * X * E = - SCALE * B * B, (1) +C +C or the transposed equation +C +C T T 2 T +C A * X * A - E * X * E = - SCALE * B * B , (2) +C +C respectively, where A, E, B, and U are real N-by-N matrices. The +C Cholesky factor U of the solution is computed without first +C finding X. The pencil A - lambda * E must be in generalized Schur +C form ( A upper quasitriangular, E upper triangular ). Moreover, it +C must be d-stable, i.e. the moduli of its eigenvalues must be less +C than one. B must be an upper triangular matrix with non-negative +C entries on its main diagonal. +C +C The resulting matrix U is upper triangular. The entries on its +C main diagonal are non-negative. SCALE is an output scale factor +C set to avoid overflow in U. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANS CHARACTER*1 +C Specifies whether equation (1) or equation (2) is to be +C solved: +C = 'N': Solve equation (1); +C = 'T': Solve equation (2). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain the quasitriangular matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N upper triangular part of this array +C must contain the matrix E. +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the matrix B. +C On exit, the leading N-by-N upper triangular part of this +C array contains the solution matrix U. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in U. +C 0 < SCALE <= 1. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (6*N-6) +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the generalized Sylvester equation to be solved in +C step II (see METHOD) is (nearly) singular to working +C precision; perturbed values were used to solve the +C equation (but the matrices A and E are unchanged); +C = 2: the generalized Schur form of the pencil +C A - lambda * E contains a 2-by-2 main diagonal block +C whose eigenvalues are not a pair of conjugate +C complex numbers; +C = 3: the pencil A - lambda * E is not d-stable, i.e. +C there are eigenvalues outside the open unit circle; +C = 4: the LAPACK routine DSYEVX utilized to factorize M3 +C failed to converge. This error is unlikely to occur. +C +C METHOD +C +C The method [2] used by the routine is an extension of Hammarling's +C algorithm [1] to generalized Lyapunov equations. +C +C We present the method for solving equation (1). Equation (2) can +C be treated in a similar fashion. For simplicity, assume SCALE = 1. +C +C The matrix A is an upper quasitriangular matrix, i.e. it is a +C block triangular matrix with square blocks on the main diagonal +C and the block order at most 2. We use the following partitioning +C for the matrices A, E, B and the solution matrix U +C +C ( A11 A12 ) ( E11 E12 ) +C A = ( ), E = ( ), +C ( 0 A22 ) ( 0 E22 ) +C +C ( B11 B12 ) ( U11 U12 ) +C B = ( ), U = ( ). (3) +C ( 0 B22 ) ( 0 U22 ) +C +C The size of the (1,1)-blocks is 1-by-1 (iff A(2,1) = 0.0) or +C 2-by-2. +C +C We compute U11 and U12**T in three steps. +C +C Step I: +C +C From (1) and (3) we get the 1-by-1 or 2-by-2 equation +C +C T T T T +C A11 * U11 * U11 * A11 - E11 * U11 * U11 * E11 +C +C T +C = - B11 * B11. +C +C For brevity, details are omitted here. The technique for +C computing U11 is similar to those applied to standard Lyapunov +C equations in Hammarling's algorithm ([1], section 6). +C +C Furthermore, the auxiliary matrices M1 and M2 defined as +C follows +C +C -1 -1 +C M1 = U11 * A11 * E11 * U11 +C +C -1 -1 +C M2 = B11 * E11 * U11 +C +C are computed in a numerically reliable way. +C +C Step II: +C +C We solve for U12**T the generalized Sylvester equation +C +C T T T T +C A22 * U12 * M1 - E22 * U12 +C +C T T T T T +C = - B12 * M2 + E12 * U11 - A12 * U11 * M1. +C +C Step III: +C +C One can show that +C +C T T T T +C A22 * U22 * U22 * A22 - E22 * U22 * U22 * E22 = +C +C T T +C - B22 * B22 - y * y (4) +C +C holds, where y is defined as follows +C +C T T T T +C w = A12 * U11 + A22 * U12 +C +C T +C y = ( B12 w ) * M3EV, +C +C where M3EV is a matrix which fulfils +C +C ( I-M2*M2**T -M2*M1**T ) T +C M3 = ( ) = M3EV * M3EV . +C ( -M1*M2**T I-M1*M1**T ) +C +C M3 is positive semidefinite and its rank is equal to the size +C of U11. Therefore, a matrix M3EV can be found by solving the +C symmetric eigenvalue problem for M3 such that y consists of +C either 1 or 2 rows. +C +C If B22_tilde is the square triangular matrix arising from the +C QR-factorization +C +C ( B22_tilde ) ( B22 ) +C Q * ( ) = ( ), +C ( 0 ) ( y**T ) +C +C then +C +C T T T +C - B22 * B22 - y * y = - B22_tilde * B22_tilde. +C +C Replacing the right hand side in (4) by the term +C - B22_tilde**T * B22_tilde leads to a generalized Lyapunov +C equation of lower dimension compared to (1). +C +C The solution U of the equation (1) can be obtained by recursive +C application of the steps I to III. +C +C REFERENCES +C +C [1] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-323, 1982. +C +C [2] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C NUMERICAL ASPECTS +C +C The routine requires 2*N**3 flops. Note that we count a single +C floating point arithmetic operation as one flop. +C +C FURTHER COMMENTS +C +C The Lyapunov equation may be very ill-conditioned. In particular, +C if the pencil A - lambda * E has a pair of almost reciprocal +C eigenvalues, then the Lyapunov equation will be ill-conditioned. +C Perturbed values were used to solve the equation. +C A condition estimate can be obtained from the routine SG03AD. +C When setting the error indicator INFO, the routine does not test +C for near instability in the equation but only for exact +C instability. +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C +C KEYWORDS +C +C Lyapunov equation +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION HALF, MONE, ONE, TWO, ZERO + PARAMETER ( HALF = 0.5D+0, MONE = -1.0D0, ONE = 1.0D+0, + $ TWO = 2.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER TRANS + DOUBLE PRECISION SCALE + INTEGER INFO, LDA, LDB, LDE, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), E(LDE,*) +C .. Local Scalars .. + DOUBLE PRECISION BIGNUM, C, DELTA1, EPS, S, SCALE1, SMLNUM, UFLT, + $ X, Z + INTEGER I, INFO1, J, KB, KH, KL, LDWS, M, UIIPT, WPT, + $ YPT + LOGICAL NOTRNS +C .. Local Arrays .. + DOUBLE PRECISION M1(2,2), M2(2,2), M3(4,4), M3C(4,4), M3EW(4), + $ RW(32), TM(2,2), UI(2,2) + INTEGER IW(24) +C .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, DLACPY, DLASET, + $ DROT, DROTG, DSCAL, DSYEVX, DSYRK, SG03BW, + $ SG03BX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +C .. Executable Statements .. +C +C Decode input parameter. +C + NOTRNS = LSAME( TRANS, 'N' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN + INFO = -1 + ELSEIF ( N .LT. 0 ) THEN + INFO = -2 + ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN + INFO = -4 + ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN + INFO = -6 + ELSEIF ( LDB .LT. MAX( 1, N ) ) THEN + INFO = -8 + ELSE + INFO = 0 + END IF + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SG03BU', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF ( N .EQ. 0 ) + $ RETURN +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + UFLT = DLAMCH( 'S' ) + SMLNUM = UFLT/EPS + BIGNUM = ONE/SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C +C Set work space pointers and leading dimension of matrices in +C work space. +C + UIIPT = 1 + WPT = 2*N-1 + YPT = 4*N-3 + LDWS = N-1 +C + IF ( NOTRNS ) THEN +C +C Solve equation (1). +C +C Main Loop. Compute block row U(KL:KH,KL:N). KB denotes the +C number of rows in this block row. +C + KH = 0 +C WHILE ( KH .LT. N ) DO + 20 IF ( KH .LT. N ) THEN + KL = KH + 1 + IF ( KL .EQ. N ) THEN + KH = N + KB = 1 + ELSE + IF ( A(KL+1,KL) .EQ. ZERO ) THEN + KH = KL + KB = 1 + ELSE + KH = KL + 1 + KB = 2 + END IF + END IF +C +C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary +C matrices M1 and M2. (For the moment the result +C U(KL:KH,KL:KH) is stored in UI). +C + IF ( KB .EQ. 1 ) THEN + DELTA1 = E(KL,KL)**2 - A(KL,KL)**2 + IF ( DELTA1 .LE. ZERO ) THEN + INFO = 3 + RETURN + END IF + DELTA1 = SQRT( DELTA1 ) + Z = TWO*ABS( B(KL,KL) )*SMLNUM + IF ( Z .GT. DELTA1 ) THEN + SCALE1 = DELTA1/Z + SCALE = SCALE1*SCALE + DO 40 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 40 CONTINUE + END IF + UI(1,1) = B(KL,KL)/DELTA1 + M1(1,1) = A(KL,KL)/E(KL,KL) + M2(1,1) = DELTA1/E(KL,KL) + ELSE +C +C If a pair of complex conjugate eigenvalues occurs, apply +C (complex) Hammarling algorithm for the 2-by-2 problem. +C + CALL SG03BX( 'D', 'N', A(KL,KL), LDA, E(KL,KL), LDE, + $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + INFO = INFO1 + RETURN + END IF + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 60 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 60 CONTINUE + END IF + END IF +C + IF ( KH .LT. N ) THEN +C +C STEP II: Compute U(KL:KH,KH+1:N) by solving a generalized +C Sylvester equation. (For the moment the result +C U(KL:KH,KH+1:N) is stored in the workspace.) +C +C Form right hand side of the Sylvester equation. +C + CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, B(KL,KH+1), + $ LDB, M2, 2, ZERO, DWORK(UIIPT), LDWS ) + CALL DGEMM( 'T', 'T', N-KH, KB, KB, ONE, E(KL,KH+1), + $ LDE, UI, 2, ONE, DWORK(UIIPT), LDWS ) + CALL DGEMM( 'T', 'N', KB, KB, KB, ONE, UI, 2, M1, 2, + $ ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, A(KL,KH+1), + $ LDA, TM, 2, ONE, DWORK(UIIPT), LDWS ) +C +C Solve generalized Sylvester equation. +C + CALL DLASET( 'A', KB, KB, ZERO, MONE, TM, 2 ) + CALL SG03BW( 'N', N-KH, KB, A(KH+1,KH+1), LDA, M1, 2, + $ E(KH+1,KH+1), LDE, TM, 2, DWORK(UIIPT), + $ LDWS, SCALE1, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 80 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 80 CONTINUE + CALL DSCAL( 4, SCALE1, UI(1,1), 1 ) + END IF +C +C STEP III: Form the right hand side matrix +C B(KH+1:N,KH+1:N) of the (smaller) Lyapunov +C equation to be solved during the next pass of +C the main loop. +C +C Compute auxiliary matrices M3 and Y. The factorization +C M3 = M3C * M3C**T is found by solving the symmetric +C eigenvalue problem. +C + CALL DLASET( 'U', 2*KB, 2*KB, ZERO, ONE, M3, 4 ) + CALL DSYRK( 'U', 'N', KB, KB, MONE, M2, 2, ONE, M3, 4 ) + CALL DGEMM( 'N', 'T', KB, KB, KB, MONE, M2, 2, M1, 2, + $ ZERO, M3(1,KB+1), 4 ) + CALL DSYRK( 'U', 'N', KB, KB, MONE, M1, 2, ONE, + $ M3(KB+1,KB+1), 4 ) + CALL DSYEVX( 'V', 'V', 'U', 2*KB, M3, 4, HALF, TWO, 1, 4, + $ TWO*UFLT, M, M3EW, M3C, 4, RW, 32, IW(5), + $ IW, INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + INFO = 4 + RETURN + END IF + CALL DGEMM( 'T', 'N', N-KH, KB, KB, ONE, B(KL,KH+1), LDB, + $ M3C, 4, ZERO, DWORK(YPT), LDWS ) + CALL DGEMM( 'T', 'T', N-KH, KB, KB, ONE, A(KL,KH+1), LDA, + $ UI, 2, ZERO, DWORK(WPT), LDWS ) + DO 100 I = 1, N-KH + CALL DGEMV( 'T', MIN( I+1, N-KH ), KB, ONE, + $ DWORK(UIIPT), LDWS, A(KH+1,KH+I), 1, ONE, + $ DWORK(WPT+I-1), LDWS ) + 100 CONTINUE + CALL DGEMM( 'N', 'N', N-KH, KB, KB, ONE, DWORK(WPT), + $ LDWS, M3C(KB+1,1), 4, ONE, DWORK(YPT), LDWS ) +C +C Overwrite B(KH+1:N,KH+1:N) with the triangular matrix +C from the QR-factorization of the (N-KH+KB)-by-(N-KH) +C matrix +C +C ( B(KH+1:N,KH+1:N) ) +C ( ) +C ( Y**T ) . +C + DO 140 J = 1, KB + DO 120 I = 1, N-KH + X = B(KH+I,KH+I) + Z = DWORK(YPT+I-1+(J-1)*LDWS) + CALL DROTG( X, Z, C, S ) + CALL DROT( N-KH-I+1, B(KH+I,KH+I), LDB, + $ DWORK(YPT+I-1+(J-1)*LDWS), 1, C, S ) + 120 CONTINUE + 140 CONTINUE +C +C Make main diagonal elements of B(KH+1:N,KH+1:N) positive. +C + DO 160 I = KH+1, N + IF ( B(I,I) .LT. ZERO ) + $ CALL DSCAL( N-I+1, MONE, B(I,I), LDB ) + 160 CONTINUE +C +C Overwrite right hand side with the part of the solution +C computed in step II. +C + DO 180 J = KL, KH + CALL DCOPY( N-KH, DWORK(UIIPT+(J-KL)*LDWS), 1, + $ B(J,KH+1), LDB ) + 180 CONTINUE + END IF +C +C Overwrite right hand side with the part of the solution +C computed in step I. +C + CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) +C + GOTO 20 + END IF +C END WHILE 20 +C + ELSE +C +C Solve equation (2). +C +C Main Loop. Compute block column U(1:KH,KL:KH). KB denotes the +C number of columns in this block column. +C + KL = N + 1 +C WHILE ( KL .GT. 1 ) DO + 200 IF ( KL .GT. 1 ) THEN + KH = KL - 1 + IF ( KH .EQ. 1 ) THEN + KL = 1 + KB = 1 + ELSE + IF ( A(KH,KH-1) .EQ. ZERO ) THEN + KL = KH + KB = 1 + ELSE + KL = KH - 1 + KB = 2 + END IF + END IF +C +C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary +C matrices M1 and M2. (For the moment the result +C U(KL:KH,KL:KH) is stored in UI). +C + IF ( KB .EQ. 1 ) THEN + DELTA1 = E(KL,KL)**2 - A(KL,KL)**2 + IF ( DELTA1 .LE. ZERO ) THEN + INFO = 3 + RETURN + END IF + DELTA1 = SQRT( DELTA1 ) + Z = TWO*ABS( B(KL,KL) )*SMLNUM + IF ( Z .GT. DELTA1 ) THEN + SCALE1 = DELTA1/Z + SCALE = SCALE1*SCALE + DO 220 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 220 CONTINUE + END IF + UI(1,1) = B(KL,KL)/DELTA1 + M1(1,1) = A(KL,KL)/E(KL,KL) + M2(1,1) = DELTA1/E(KL,KL) + ELSE +C +C If a pair of complex conjugate eigenvalues occurs, apply +C (complex) Hammarling algorithm for the 2-by-2 problem. +C + CALL SG03BX( 'D', 'T', A(KL,KL), LDA, E(KL,KL), LDE, + $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + INFO = INFO1 + RETURN + END IF + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 240 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 240 CONTINUE + END IF + END IF +C + IF ( KL .GT. 1 ) THEN +C +C STEP II: Compute U(1:KL-1,KL:KH) by solving a generalized +C Sylvester equation. (For the moment the result +C U(1:KL-1,KL:KH) is stored in the workspace.) +C +C Form right hand side of the Sylvester equation. +C + CALL DGEMM( 'N', 'T', KL-1, KB, KB, MONE, B(1,KL), LDB, + $ M2, 2, ZERO, DWORK(UIIPT), LDWS ) + CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, E(1,KL), LDE, + $ UI, 2, ONE, DWORK(UIIPT), LDWS ) + CALL DGEMM( 'N', 'T', KB, KB, KB, ONE, UI, 2, M1, 2, + $ ZERO, TM, 2 ) + CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, A(1,KL), LDA, + $ TM, 2, ONE, DWORK(UIIPT), LDWS ) +C +C Solve generalized Sylvester equation. +C + CALL DLASET( 'A', KB, KB, ZERO, MONE, TM, 2 ) + CALL SG03BW( 'T', KL-1, KB, A, LDA, M1, 2, E, LDE, TM, 2, + $ DWORK(UIIPT), LDWS, SCALE1, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 260 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 260 CONTINUE + CALL DSCAL( 4, SCALE1, UI(1,1), 1 ) + END IF +C +C STEP III: Form the right hand side matrix +C B(1:KL-1,1:KL-1) of the (smaller) Lyapunov +C equation to be solved during the next pass of +C the main loop. +C +C Compute auxiliary matrices M3 and Y. The factorization +C M3 = M3C * M3C**T is found by solving the symmetric +C eigenvalue problem. +C + CALL DLASET( 'U', 2*KB, 2*KB, ZERO, ONE, M3, 4 ) + CALL DSYRK( 'U', 'T', KB, KB, MONE, M2, 2, ONE, M3, 4 ) + CALL DGEMM( 'T', 'N', KB, KB, KB, MONE, M2, 2, M1, 2, + $ ZERO, M3(1,KB+1), 4 ) + CALL DSYRK( 'U', 'T', KB, KB, MONE, M1, 2, ONE, + $ M3(KB+1,KB+1), 4 ) + CALL DSYEVX( 'V', 'V', 'U', 2*KB, M3, 4, HALF, TWO, 1, 4, + $ TWO*UFLT, M, M3EW, M3C, 4, RW, 32, IW(5), + $ IW, INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + INFO = 4 + RETURN + END IF + CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, B(1,KL), LDB, + $ M3C, 4, ZERO, DWORK(YPT), LDWS ) + CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, A(1,KL), LDA, + $ UI, 2, ZERO, DWORK(WPT), LDWS ) + DO 280 I = 1, KL-1 + CALL DGEMV( 'T', MIN( KL-I+1, KL-1 ), KB, ONE, + $ DWORK(MAX( UIIPT, UIIPT+I-2 )), LDWS, + $ A(I,MAX( I-1, 1 )), LDA, ONE, + $ DWORK(WPT+I-1), LDWS ) + 280 CONTINUE + CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, DWORK(WPT), + $ LDWS, M3C(KB+1,1), 4, ONE, DWORK(YPT), LDWS ) +C +C Overwrite B(1:KL-1,1:KL-1) with the triangular matrix +C from the RQ-factorization of the (KL-1)-by-KH matrix +C +C ( ) +C ( B(1:KL-1,1:KL-1) Y ) +C ( ). +C + DO 320 J = 1, KB + DO 300 I = KL-1, 1, -1 + X = B(I,I) + Z = DWORK(YPT+I-1+(J-1)*LDWS) + CALL DROTG( X, Z, C, S ) + CALL DROT( I, B(1,I), 1, DWORK(YPT+(J-1)*LDWS), 1, + $ C, S ) + 300 CONTINUE + 320 CONTINUE +C +C Make main diagonal elements of B(1:KL-1,1:KL-1) positive. +C + DO 340 I = 1, KL-1 + IF ( B(I,I) .LT. ZERO ) + $ CALL DSCAL( I, MONE, B(1,I), 1 ) + 340 CONTINUE +C +C Overwrite right hand side with the part of the solution +C computed in step II. +C + CALL DLACPY( 'A', KL-1, KB, DWORK(UIIPT), LDWS, B(1,KL), + $ LDB ) +C + END IF +C +C Overwrite right hand side with the part of the solution +C computed in step I. +C + CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) +C + GOTO 200 + END IF +C END WHILE 200 +C + END IF +C + RETURN +C *** Last line of SG03BU *** + END diff --git a/mex/sources/libslicot/SG03BV.f b/mex/sources/libslicot/SG03BV.f new file mode 100644 index 000000000..edce6f0dc --- /dev/null +++ b/mex/sources/libslicot/SG03BV.f @@ -0,0 +1,645 @@ + SUBROUTINE SG03BV( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, + $ DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Cholesky factor U of the matrix X, X = U**T * U or +C X = U * U**T, which is the solution of the generalized c-stable +C continuous-time Lyapunov equation +C +C T T 2 T +C A * X * E + E * X * A = - SCALE * B * B, (1) +C +C or the transposed equation +C +C T T 2 T +C A * X * E + E * X * A = - SCALE * B * B , (2) +C +C respectively, where A, E, B, and U are real N-by-N matrices. The +C Cholesky factor U of the solution is computed without first +C finding X. The pencil A - lambda * E must be in generalized Schur +C form ( A upper quasitriangular, E upper triangular ). Moreover, it +C must be c-stable, i.e. its eigenvalues must have negative real +C parts. B must be an upper triangular matrix with non-negative +C entries on its main diagonal. +C +C The resulting matrix U is upper triangular. The entries on its +C main diagonal are non-negative. SCALE is an output scale factor +C set to avoid overflow in U. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANS CHARACTER*1 +C Specifies whether equation (1) or equation (2) is to be +C solved: +C = 'N': Solve equation (1); +C = 'T': Solve equation (2). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain the quasitriangular matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N upper triangular part of this array +C must contain the matrix E. +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the matrix B. +C On exit, the leading N-by-N upper triangular part of this +C array contains the solution matrix U. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in U. +C 0 < SCALE <= 1. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (6*N-6) +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the generalized Sylvester equation to be solved in +C step II (see METHOD) is (nearly) singular to working +C precision; perturbed values were used to solve the +C equation (but the matrices A and E are unchanged); +C = 2: the generalized Schur form of the pencil +C A - lambda * E contains a 2-by-2 main diagonal block +C whose eigenvalues are not a pair of conjugate +C complex numbers; +C = 3: the pencil A - lambda * E is not stable, i.e. there +C is an eigenvalue without a negative real part. +C +C METHOD +C +C The method [2] used by the routine is an extension of Hammarling's +C algorithm [1] to generalized Lyapunov equations. +C +C We present the method for solving equation (1). Equation (2) can +C be treated in a similar fashion. For simplicity, assume SCALE = 1. +C +C The matrix A is an upper quasitriangular matrix, i.e. it is a +C block triangular matrix with square blocks on the main diagonal +C and the block order at most 2. We use the following partitioning +C for the matrices A, E, B and the solution matrix U +C +C ( A11 A12 ) ( E11 E12 ) +C A = ( ), E = ( ), +C ( 0 A22 ) ( 0 E22 ) +C +C ( B11 B12 ) ( U11 U12 ) +C B = ( ), U = ( ). (3) +C ( 0 B22 ) ( 0 U22 ) +C +C The size of the (1,1)-blocks is 1-by-1 (iff A(2,1) = 0.0) or +C 2-by-2. +C +C We compute U11 and U12**T in three steps. +C +C Step I: +C +C From (1) and (3) we get the 1-by-1 or 2-by-2 equation +C +C T T T T +C A11 * U11 * U11 * E11 + E11 * U11 * U11 * A11 +C +C T +C = - B11 * B11. +C +C For brevity, details are omitted here. The technique for +C computing U11 is similar to those applied to standard Lyapunov +C equations in Hammarling's algorithm ([1], section 6). +C +C Furthermore, the auxiliary matrices M1 and M2 defined as +C follows +C +C -1 -1 +C M1 = U11 * A11 * E11 * U11 +C +C -1 -1 +C M2 = B11 * E11 * U11 +C +C are computed in a numerically reliable way. +C +C Step II: +C +C We solve for U12**T the generalized Sylvester equation +C +C T T T T +C A22 * U12 + E22 * U12 * M1 +C +C T T T T T +C = - B12 * M2 - A12 * U11 - E12 * U11 * M1. +C +C Step III: +C +C One can show that +C +C T T T T +C A22 * U22 * U22 * E22 + E22 * U22 * U22 * A22 = +C +C T T +C - B22 * B22 - y * y (4) +C +C holds, where y is defined as follows +C +C T T T T +C w = E12 * U11 + E22 * U12 +C T T +C y = B12 - w * M2 . +C +C If B22_tilde is the square triangular matrix arising from the +C QR-factorization +C +C ( B22_tilde ) ( B22 ) +C Q * ( ) = ( ), +C ( 0 ) ( y**T ) +C +C then +C +C T T T +C - B22 * B22 - y * y = - B22_tilde * B22_tilde. +C +C Replacing the right hand side in (4) by the term +C - B22_tilde**T * B22_tilde leads to a generalized Lyapunov +C equation of lower dimension compared to (1). +C +C The solution U of the equation (1) can be obtained by recursive +C application of the steps I to III. +C +C REFERENCES +C +C [1] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-323, 1982. +C +C [2] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C NUMERICAL ASPECTS +C +C The routine requires 2*N**3 flops. Note that we count a single +C floating point arithmetic operation as one flop. +C +C FURTHER COMMENTS +C +C The Lyapunov equation may be very ill-conditioned. In particular, +C if the pencil A - lambda * E has a pair of almost degenerate +C eigenvalues, then the Lyapunov equation will be ill-conditioned. +C Perturbed values were used to solve the equation. +C A condition estimate can be obtained from the routine SG03AD. +C When setting the error indicator INFO, the routine does not test +C for near instability in the equation but only for exact +C instability. +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C +C KEYWORDS +C +C Lyapunov equation +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION MONE, ONE, TWO, ZERO + PARAMETER ( MONE = -1.0D0, ONE = 1.0D+0, TWO = 2.0D+0, + $ ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER TRANS + DOUBLE PRECISION SCALE + INTEGER INFO, LDA, LDB, LDE, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), E(LDE,*) +C .. Local Scalars .. + DOUBLE PRECISION BIGNUM, C, DELTA1, EPS, S, SCALE1, SMLNUM, X, Z + INTEGER I, INFO1, J, KB, KH, KL, LDWS, UIIPT, WPT, YPT + LOGICAL NOTRNS +C .. Local Arrays .. + DOUBLE PRECISION M1(2,2), M2(2,2), TM(2,2), UI(2,2) +C .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLABAD, DLACPY, DLASET, DROT, + $ DROTG, DSCAL, DTRMM, SG03BW, SG03BX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +C .. Executable Statements .. +C +C Decode input parameter. +C + NOTRNS = LSAME( TRANS, 'N' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN + INFO = -1 + ELSEIF ( N .LT. 0 ) THEN + INFO = -2 + ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN + INFO = -4 + ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN + INFO = -6 + ELSEIF ( LDB .LT. MAX( 1, N ) ) THEN + INFO = -8 + ELSE + INFO = 0 + END IF + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SG03BV', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF ( N .EQ. 0 ) + $ RETURN +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' )/EPS + BIGNUM = ONE/SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C +C Set work space pointers and leading dimension of matrices in +C work space. +C + UIIPT = 1 + WPT = 2*N-1 + YPT = 4*N-3 + LDWS = N-1 +C + IF ( NOTRNS ) THEN +C +C Solve equation (1). +C +C Main Loop. Compute block row U(KL:KH,KL:N). KB denotes the +C number of rows in this block row. +C + KH = 0 +C WHILE ( KH .LT. N ) DO + 20 IF ( KH .LT. N ) THEN + KL = KH + 1 + IF ( KL .EQ. N ) THEN + KH = N + KB = 1 + ELSE + IF ( A(KL+1,KL) .EQ. ZERO ) THEN + KH = KL + KB = 1 + ELSE + KH = KL + 1 + KB = 2 + END IF + END IF +C +C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary +C matrices M1 and M2. (For the moment the result +C U(KL:KH,KL:KH) is stored in UI). +C + IF ( KB .EQ. 1 ) THEN + DELTA1 = -TWO*A(KL,KL)*E(KL,KL) + IF ( DELTA1 .LE. ZERO ) THEN + INFO = 3 + RETURN + END IF + DELTA1 = SQRT( DELTA1 ) + Z = TWO*ABS( B(KL,KL) )*SMLNUM + IF ( Z .GT. DELTA1 ) THEN + SCALE1 = DELTA1/Z + SCALE = SCALE1*SCALE + DO 40 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 40 CONTINUE + END IF + UI(1,1) = B(KL,KL)/DELTA1 + M1(1,1) = A(KL,KL)/E(KL,KL) + M2(1,1) = DELTA1/E(KL,KL) + ELSE +C +C If a pair of complex conjugate eigenvalues occurs, apply +C (complex) Hammarling algorithm for the 2-by-2 problem. +C + CALL SG03BX( 'C', 'N', A(KL,KL), LDA, E(KL,KL), LDE, + $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + INFO = INFO1 + RETURN + END IF + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 60 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 60 CONTINUE + END IF + END IF +C + IF ( KH .LT. N ) THEN +C +C STEP II: Compute U(KL:KH,KH+1:N) by solving a generalized +C Sylvester equation. (For the moment the result +C U(KL:KH,KH+1:N) is stored in the workspace.) +C +C Form right hand side of the Sylvester equation. +C + CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, B(KL,KH+1), + $ LDB, M2, 2, ZERO, DWORK(UIIPT), LDWS ) + CALL DGEMM( 'T', 'T', N-KH, KB, KB, MONE, A(KL,KH+1), + $ LDA, UI, 2, ONE, DWORK(UIIPT), LDWS ) + CALL DGEMM( 'T', 'N', KB, KB, KB, ONE, UI, 2, M1, 2, + $ ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, E(KL,KH+1), + $ LDE, TM, 2, ONE, DWORK(UIIPT), LDWS ) +C +C Solve generalized Sylvester equation. +C + CALL DLASET( 'A', KB, KB, ZERO, ONE, TM, 2 ) + CALL SG03BW( 'N', N-KH, KB, A(KH+1,KH+1), LDA, TM, 2, + $ E(KH+1,KH+1), LDE, M1, 2, DWORK(UIIPT), + $ LDWS, SCALE1, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 80 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 80 CONTINUE + CALL DSCAL( 4, SCALE1, UI(1,1), 1 ) + END IF +C +C STEP III: Form the right hand side matrix +C B(KH+1:N,KH+1:N) of the (smaller) Lyapunov +C equation to be solved during the next pass of +C the main loop. +C +C Compute auxiliary vectors (or matrices) W and Y. +C + CALL DLACPY( 'A', N-KH, KB, DWORK(UIIPT), LDWS, + $ DWORK(WPT), LDWS ) + CALL DTRMM( 'L', 'U', 'T', 'N', N-KH, KB, ONE, + $ E(KH+1,KH+1), LDE, DWORK(WPT), LDWS ) + CALL DGEMM( 'T', 'T', N-KH, KB, KB, ONE, E(KL,KH+1), + $ LDE, UI, 2, ONE, DWORK(WPT), LDWS ) + DO 100 I = KL, KH + CALL DCOPY( N-KH, B(I,KH+1), LDB, + $ DWORK(YPT+LDWS*(I-KL)), 1 ) + 100 CONTINUE + CALL DGEMM( 'N', 'T', N-KH, KB, KB, MONE, DWORK(WPT), + $ LDWS, M2, 2, ONE, DWORK(YPT), LDWS ) +C +C Overwrite B(KH+1:N,KH+1:N) with the triangular matrix +C from the QR-factorization of the (N-KH+KB)-by-(N-KH) +C matrix +C +C ( B(KH+1:N,KH+1:N) ) +C ( ) +C ( Y**T ) . +C + DO 140 J = 1, KB + DO 120 I = 1, N-KH + X = B(KH+I,KH+I) + Z = DWORK(YPT+I-1+(J-1)*LDWS) + CALL DROTG( X, Z, C, S ) + CALL DROT( N-KH-I+1, B(KH+I,KH+I), LDB, + $ DWORK(YPT+I-1+(J-1)*LDWS), 1, C, S ) + 120 CONTINUE + 140 CONTINUE +C +C Make main diagonal elements of B(KH+1:N,KH+1:N) positive. +C + DO 160 I = KH+1, N + IF ( B(I,I) .LT. ZERO ) + $ CALL DSCAL( N-I+1, MONE, B(I,I), LDB ) + 160 CONTINUE +C +C Overwrite right hand side with the part of the solution +C computed in step II. +C + DO 180 J = KL, KH + CALL DCOPY( N-KH, DWORK(UIIPT+(J-KL)*LDWS), 1, + $ B(J,KH+1), LDB ) + 180 CONTINUE + END IF +C +C Overwrite right hand side with the part of the solution +C computed in step I. +C + CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) +C + GOTO 20 + END IF +C END WHILE 20 +C + ELSE +C +C Solve equation (2). +C +C Main Loop. Compute block column U(1:KH,KL:KH). KB denotes the +C number of columns in this block column. +C + KL = N + 1 +C WHILE ( KL .GT. 1 ) DO + 200 IF ( KL .GT. 1 ) THEN + KH = KL - 1 + IF ( KH .EQ. 1 ) THEN + KL = 1 + KB = 1 + ELSE + IF ( A(KH,KH-1) .EQ. ZERO ) THEN + KL = KH + KB = 1 + ELSE + KL = KH - 1 + KB = 2 + END IF + END IF +C +C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary +C matrices M1 and M2. (For the moment the result +C U(KL:KH,KL:KH) is stored in UI). +C + IF ( KB .EQ. 1 ) THEN + DELTA1 = -TWO*A(KL,KL)*E(KL,KL) + IF ( DELTA1 .LE. ZERO ) THEN + INFO = 3 + RETURN + END IF + DELTA1 = SQRT( DELTA1 ) + Z = TWO*ABS( B(KL,KL) )*SMLNUM + IF ( Z .GT. DELTA1 ) THEN + SCALE1 = DELTA1/Z + SCALE = SCALE1*SCALE + DO 220 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 220 CONTINUE + END IF + UI(1,1) = B(KL,KL)/DELTA1 + M1(1,1) = A(KL,KL)/E(KL,KL) + M2(1,1) = DELTA1/E(KL,KL) + ELSE +C +C If a pair of complex conjugate eigenvalues occurs, apply +C (complex) Hammarling algorithm for the 2-by-2 problem. +C + CALL SG03BX( 'C', 'T', A(KL,KL), LDA, E(KL,KL), LDE, + $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + INFO = INFO1 + RETURN + END IF + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 240 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 240 CONTINUE + END IF + END IF +C + IF ( KL .GT. 1 ) THEN +C +C STEP II: Compute U(1:KL-1,KL:KH) by solving a generalized +C Sylvester equation. (For the moment the result +C U(1:KL-1,KL:KH) is stored in the workspace.) +C +C Form right hand side of the Sylvester equation. +C + CALL DGEMM( 'N', 'T', KL-1, KB, KB, MONE, B(1,KL), LDB, + $ M2, 2, ZERO, DWORK(UIIPT), LDWS ) + CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, A(1,KL), LDA, + $ UI, 2, ONE, DWORK(UIIPT), LDWS ) + CALL DGEMM( 'N', 'T', KB, KB, KB, ONE, UI, 2, M1, 2, + $ ZERO, TM, 2 ) + CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, E(1,KL), LDE, + $ TM, 2, ONE, DWORK(UIIPT), LDWS ) +C +C Solve generalized Sylvester equation. +C + CALL DLASET( 'A', KB, KB, ZERO, ONE, TM, 2 ) + CALL SG03BW( 'T', KL-1, KB, A, LDA, TM, 2, E, LDE, M1, 2, + $ DWORK(UIIPT), LDWS, SCALE1, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 260 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 260 CONTINUE + CALL DSCAL( 4, SCALE1, UI(1,1), 1 ) + END IF +C +C STEP III: Form the right hand side matrix +C B(1:KL-1,1:KL-1) of the (smaller) Lyapunov +C equation to be solved during the next pass of +C the main loop. +C +C Compute auxiliary vectors (or matrices) W and Y. +C + CALL DLACPY( 'A', KL-1, KB, DWORK(UIIPT), LDWS, + $ DWORK(WPT), LDWS ) + CALL DTRMM( 'L', 'U', 'N', 'N', KL-1, KB, ONE, E(1,1), + $ LDE, DWORK(WPT), LDWS ) + CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, E(1,KL), LDE, + $ UI, 2, ONE, DWORK(WPT), LDWS ) + CALL DLACPY( 'A', KL-1, KB, B(1, KL), LDB, DWORK(YPT), + $ LDWS ) + CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, DWORK(WPT), + $ LDWS, M2, 2, ONE, DWORK(YPT), LDWS ) +C +C Overwrite B(1:KL-1,1:KL-1) with the triangular matrix +C from the RQ-factorization of the (KL-1)-by-KH matrix +C +C ( ) +C ( B(1:KL-1,1:KL-1) Y ) +C ( ). +C + DO 300 J = 1, KB + DO 280 I = KL-1, 1, -1 + X = B(I,I) + Z = DWORK(YPT+I-1+(J-1)*LDWS) + CALL DROTG( X, Z, C, S ) + CALL DROT( I, B(1,I), 1, DWORK(YPT+(J-1)*LDWS), 1, + $ C, S ) + 280 CONTINUE + 300 CONTINUE +C +C Make main diagonal elements of B(1:KL-1,1:KL-1) positive. +C + DO 320 I = 1, KL-1 + IF ( B(I,I) .LT. ZERO ) + $ CALL DSCAL( I, MONE, B(1,I), 1 ) + 320 CONTINUE +C +C Overwrite right hand side with the part of the solution +C computed in step II. +C + CALL DLACPY( 'A', KL-1, KB, DWORK(UIIPT), LDWS, B(1,KL), + $ LDB ) +C + END IF +C +C Overwrite right hand side with the part of the solution +C computed in step I. +C + CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) +C + GOTO 200 + END IF +C END WHILE 200 +C + END IF +C + RETURN +C *** Last line of SG03BV *** + END diff --git a/mex/sources/libslicot/SG03BW.f b/mex/sources/libslicot/SG03BW.f new file mode 100644 index 000000000..aed45369f --- /dev/null +++ b/mex/sources/libslicot/SG03BW.f @@ -0,0 +1,459 @@ + SUBROUTINE SG03BW( TRANS, M, N, A, LDA, C, LDC, E, LDE, D, LDD, X, + $ LDX, SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X the generalized Sylvester equation +C +C T T +C A * X * C + E * X * D = SCALE * Y, (1) +C +C or the transposed equation +C +C T T +C A * X * C + E * X * D = SCALE * Y, (2) +C +C where A and E are real M-by-M matrices, C and D are real N-by-N +C matrices, X and Y are real M-by-N matrices. N is either 1 or 2. +C The pencil A - lambda * E must be in generalized real Schur form +C (A upper quasitriangular, E upper triangular). SCALE is an output +C scale factor, set to avoid overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANS CHARACTER*1 +C Specifies whether the transposed equation is to be solved +C or not: +C = 'N': Solve equation (1); +C = 'T': Solve equation (2). +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrices A and E. M >= 0. +C +C N (input) INTEGER +C The order of the matrices C and D. N = 1 or N = 2. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain the +C upper quasitriangular matrix A. The elements below the +C upper Hessenberg part are not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,M). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading N-by-N part of this array must contain the +C matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,M) +C The leading M-by-M part of this array must contain the +C upper triangular matrix E. The elements below the main +C diagonal are not referenced. +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,M). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,N) +C The leading N-by-N part of this array must contain the +C matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= MAX(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, the leading M-by-N part of this array must +C contain the right hand side matrix Y. +C On exit, the leading M-by-N part of this array contains +C the solution matrix X. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= MAX(1,M). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in X. +C 0 < SCALE <= 1. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the generalized Sylvester equation is (nearly) +C singular to working precision; perturbed values +C were used to solve the equation (but the matrices +C A, C, D, and E are unchanged). +C +C METHOD +C +C The method used by the routine is based on a generalization of the +C algorithm due to Bartels and Stewart [1]. See also [2] and [3] for +C details. +C +C REFERENCES +C +C [1] Bartels, R.H., Stewart, G.W. +C Solution of the equation A X + X B = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Gardiner, J.D., Laub, A.J., Amato, J.J., Moler, C.B. +C Solution of the Sylvester Matrix Equation +C A X B**T + C X D**T = E. +C A.C.M. Trans. Math. Soft., vol. 18, no. 2, pp. 223-231, 1992. +C +C [3] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C NUMERICAL ASPECTS +C +C The routine requires about 2 * N * M**2 flops. Note that we count +C a single floating point arithmetic operation as one flop. +C +C The algorithm is backward stable if the eigenvalues of the pencil +C A - lambda * E are real. Otherwise, linear systems of order at +C most 4 are involved into the computation. These systems are solved +C by Gauss elimination with complete pivoting. The loss of stability +C of the Gauss elimination with complete pivoting is rarely +C encountered in practice. +C +C FURTHER COMMENTS +C +C When near singularity is detected, perturbed values are used +C to solve the equation (but the given matrices are unchanged). +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C +C KEYWORDS +C +C Lyapunov equation +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION MONE, ONE, ZERO + PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER TRANS + DOUBLE PRECISION SCALE + INTEGER INFO, LDA, LDC, LDD, LDE, LDX, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), C(LDC,*), D(LDD,*), E(LDE,*), X(LDX,*) +C .. Local Scalars .. + DOUBLE PRECISION SCALE1 + INTEGER DIMMAT, I, INFO1, J, MA, MAI, MAJ, MB, ME + LOGICAL NOTRNS +C .. Local Arrays .. + DOUBLE PRECISION MAT(4,4), RHS(4), TM(2,2) + INTEGER PIV1(4), PIV2(4) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DSCAL, MB02UU, MB02UV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C Decode input parameters. +C + NOTRNS = LSAME( TRANS, 'N' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN + INFO = -1 + ELSEIF ( M .LT. 0 ) THEN + INFO = -2 + ELSEIF ( N .NE. 1 .AND. N .NE. 2 ) THEN + INFO = -3 + ELSEIF ( LDA .LT. MAX( 1, M ) ) THEN + INFO = -5 + ELSEIF ( LDC .LT. MAX( 1, N ) ) THEN + INFO = -7 + ELSEIF ( LDE .LT. MAX( 1, M ) ) THEN + INFO = -9 + ELSEIF ( LDD .LT. MAX( 1, N ) ) THEN + INFO = -11 + ELSEIF ( LDX .LT. MAX( 1, M ) ) THEN + INFO = -13 + ELSE + INFO = 0 + END IF + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SG03BW', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF ( M .EQ. 0 ) + $ RETURN +C + IF ( NOTRNS ) THEN +C +C Solve equation (1). +C +C Compute block row X(MA:ME,:). MB denotes the number of rows in +C this block row. +C + ME = 0 +C WHILE ( ME .NE. M ) DO + 20 IF ( ME .NE. M ) THEN + MA = ME + 1 + IF ( MA .EQ. M ) THEN + ME = M + MB = 1 + ELSE + IF ( A(MA+1,MA) .EQ. ZERO ) THEN + ME = MA + MB = 1 + ELSE + ME = MA + 1 + MB = 2 + END IF + END IF +C +C Assemble Kronecker product system of linear equations with +C matrix +C +C MAT = kron(C',A(MA:ME,MA:ME)') + kron(D',E(MA:ME,MA:ME)') +C +C and right hand side +C +C RHS = vec(X(MA:ME,:)). +C + IF ( N .EQ. 1 ) THEN + DIMMAT = MB + DO 60 I = 1, MB + MAI = MA + I - 1 + DO 40 J = 1, MB + MAJ = MA + J - 1 + MAT(I,J) = C(1,1)*A(MAJ,MAI) + IF ( MAJ .LE. MAI ) + $ MAT(I,J) = MAT(I,J) + D(1,1)*E(MAJ,MAI) + 40 CONTINUE + RHS(I) = X(MAI,1) + 60 CONTINUE + ELSE + DIMMAT = 2*MB + DO 100 I = 1, MB + MAI = MA + I - 1 + DO 80 J = 1, MB + MAJ = MA + J - 1 + MAT(I,J) = C(1,1)*A(MAJ,MAI) + MAT(MB+I,J) = C(1,2)*A(MAJ,MAI) + MAT(I,MB+J) = C(2,1)*A(MAJ,MAI) + MAT(MB+I,MB+J) = C(2,2)*A(MAJ,MAI) + IF ( MAJ .LE. MAI ) THEN + MAT(I,J) = MAT(I,J) + D(1,1)*E(MAJ,MAI) + MAT(MB+I,J) = MAT(MB+I,J) + D(1,2)*E(MAJ,MAI) + MAT(I,MB+J) = MAT(I,MB+J) + D(2,1)*E(MAJ,MAI) + MAT(MB+I,MB+J) = MAT(MB+I,MB+J) + + $ D(2,2)*E(MAJ,MAI) + END IF + 80 CONTINUE + RHS(I) = X(MAI,1) + RHS(MB+I) = X(MAI,2) + 100 CONTINUE + END IF +C +C Solve the system of linear equations. +C + CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 120 I = 1, N + CALL DSCAL( M, SCALE1, X(1,I), 1 ) + 120 CONTINUE + END IF +C + IF ( N .EQ. 1 ) THEN + DO 140 I = 1, MB + MAI = MA + I - 1 + X(MAI,1) = RHS(I) + 140 CONTINUE + ELSE + DO 160 I = 1, MB + MAI = MA + I - 1 + X(MAI,1) = RHS(I) + X(MAI,2) = RHS(MB+I) + 160 CONTINUE + END IF +C +C Update right hand sides. +C +C X(ME+1:M,:) = X(ME+1:M,:) - A(MA:ME,ME+1:M)'*X(MA:ME,:)*C +C +C X(ME+1:M,:) = X(ME+1:M,:) - E(MA:ME,ME+1:M)'*X(MA:ME,:)*D +C + IF ( ME .LT. M ) THEN + CALL DGEMM( 'N', 'N', MB, N, N, ONE, X(MA,1), LDX, C, + $ LDC, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', M-ME, N, MB, MONE, A(MA,ME+1), + $ LDA, TM, 2, ONE, X(ME+1,1), LDX ) + CALL DGEMM( 'N', 'N', MB, N, N, ONE, X(MA,1), LDX, D, + $ LDD, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', M-ME, N, MB, MONE, E(MA,ME+1), LDE, + $ TM, 2, ONE, X(ME+1,1), LDX ) + END IF +C + GOTO 20 + END IF +C END WHILE 20 +C + ELSE +C +C Solve equation (2). +C +C Compute block row X(MA:ME,:). MB denotes the number of rows in +C this block row. +C + MA = M + 1 +C WHILE ( MA .NE. 1 ) DO + 180 IF ( MA .NE. 1 ) THEN + ME = MA - 1 + IF ( ME .EQ. 1 ) THEN + MA = 1 + MB = 1 + ELSE + IF ( A(ME,ME-1) .EQ. ZERO ) THEN + MA = ME + MB = 1 + ELSE + MA = ME - 1 + MB = 2 + END IF + END IF +C +C Assemble Kronecker product system of linear equations with +C matrix +C +C MAT = kron(C,A(MA:ME,MA:ME)) + kron(D,E(MA:ME,MA:ME)) +C +C and right hand side +C +C RHS = vec(X(MA:ME,:)). +C + IF ( N .EQ. 1 ) THEN + DIMMAT = MB + DO 220 I = 1, MB + MAI = MA + I - 1 + DO 200 J = 1, MB + MAJ = MA + J - 1 + MAT(I,J) = C(1,1)*A(MAI,MAJ) + IF ( MAJ .GE. MAI ) + $ MAT(I,J) = MAT(I,J) + D(1,1)*E(MAI,MAJ) + 200 CONTINUE + RHS(I) = X(MAI,1) + 220 CONTINUE + ELSE + DIMMAT = 2*MB + DO 260 I = 1, MB + MAI = MA + I - 1 + DO 240 J = 1, MB + MAJ = MA + J - 1 + MAT(I,J) = C(1,1)*A(MAI,MAJ) + MAT(MB+I,J) = C(2,1)*A(MAI,MAJ) + MAT(I,MB+J) = C(1,2)*A(MAI,MAJ) + MAT(MB+I,MB+J) = C(2,2)*A(MAI,MAJ) + IF ( MAJ .GE. MAI ) THEN + MAT(I,J) = MAT(I,J) + D(1,1)*E(MAI,MAJ) + MAT(MB+I,J) = MAT(MB+I,J) + D(2,1)*E(MAI,MAJ) + MAT(I,MB+J) = MAT(I,MB+J) + D(1,2)*E(MAI,MAJ) + MAT(MB+I,MB+J) = MAT(MB+I,MB+J) + + $ D(2,2)*E(MAI,MAJ) + END IF + 240 CONTINUE + RHS(I) = X(MAI,1) + RHS(MB+I) = X(MAI,2) + 260 CONTINUE + END IF +C +C Solve the system of linear equations. +C + CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 280 I = 1, N + CALL DSCAL( M, SCALE1, X(1,I), 1 ) + 280 CONTINUE + END IF +C + IF ( N .EQ. 1 ) THEN + DO 300 I = 1, MB + MAI = MA + I - 1 + X(MAI,1) = RHS(I) + 300 CONTINUE + ELSE + DO 320 I = 1, MB + MAI = MA + I - 1 + X(MAI,1) = RHS(I) + X(MAI,2) = RHS(MB+I) + 320 CONTINUE + END IF +C +C Update right hand sides. +C +C X(1:MA-1,:) = X(1:MA-1,:) - A(1:MA-1,MA:ME)*X(MA:ME,:)*C' +C +C X(1:MA-1,:) = X(1:MA-1,:) - E(1:MA-1,MA:ME)*X(MA:ME,:)*D' +C + IF ( MA .GT. 1 ) THEN + CALL DGEMM( 'N', 'T', MB, N, N, ONE, X(MA,1), LDX, C, + $ LDC, ZERO, TM, 2 ) + CALL DGEMM( 'N', 'N', MA-1, N, MB, MONE, A(1,MA), LDA, + $ TM, 2, ONE, X, LDX ) + CALL DGEMM( 'N', 'T', MB, N, N, ONE, X(MA,1), LDX, D, + $ LDD, ZERO, TM, 2 ) + CALL DGEMM( 'N', 'N', MA-1, N, MB, MONE, E(1,MA), LDE, + $ TM, 2, ONE, X, LDX ) + END IF +C + GOTO 180 + END IF +C END WHILE 180 +C + END IF +C + RETURN +C *** Last line of SG03BW *** + END diff --git a/mex/sources/libslicot/SG03BX.f b/mex/sources/libslicot/SG03BX.f new file mode 100644 index 000000000..651716cd9 --- /dev/null +++ b/mex/sources/libslicot/SG03BX.f @@ -0,0 +1,764 @@ + SUBROUTINE SG03BX( DICO, TRANS, A, LDA, E, LDE, B, LDB, U, LDU, + $ SCALE, M1, LDM1, M2, LDM2, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X = op(U)**T * op(U) either the generalized c-stable +C continuous-time Lyapunov equation +C +C T T +C op(A) * X * op(E) + op(E) * X * op(A) +C +C 2 T +C = - SCALE * op(B) * op(B), (1) +C +C or the generalized d-stable discrete-time Lyapunov equation +C +C T T +C op(A) * X * op(A) - op(E) * X * op(E) +C +C 2 T +C = - SCALE * op(B) * op(B), (2) +C +C where op(K) is either K or K**T for K = A, B, E, U. The Cholesky +C factor U of the solution is computed without first finding X. +C +C Furthermore, the auxiliary matrices +C +C -1 -1 +C M1 := op(U) * op(A) * op(E) * op(U) +C +C -1 -1 +C M2 := op(B) * op(E) * op(U) +C +C are computed in a numerically reliable way. +C +C The matrices A, B, E, M1, M2, and U are real 2-by-2 matrices. The +C pencil A - lambda * E must have a pair of complex conjugate +C eigenvalues. The eigenvalues must be in the open right half plane +C (in the continuous-time case) or inside the unit circle (in the +C discrete-time case). +C +C The resulting matrix U is upper triangular. The entries on its +C main diagonal are non-negative. SCALE is an output scale factor +C set to avoid overflow in U. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies whether the continuous-time or the discrete-time +C equation is to be solved: +C = 'C': Solve continuous-time equation (1); +C = 'D': Solve discrete-time equation (2). +C +C TRANS CHARACTER*1 +C Specifies whether the transposed equation is to be solved +C or not: +C = 'N': op(K) = K, K = A, B, E, U; +C = 'T': op(K) = K**T, K = A, B, E, U. +C +C Input/Output Parameters +C +C A (input) DOUBLE PRECISION array, dimension (LDA,2) +C The leading 2-by-2 part of this array must contain the +C matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= 2. +C +C E (input) DOUBLE PRECISION array, dimension (LDE,2) +C The leading 2-by-2 upper triangular part of this array +C must contain the matrix E. +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= 2. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,2) +C The leading 2-by-2 upper triangular part of this array +C must contain the matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= 2. +C +C U (output) DOUBLE PRECISION array, dimension (LDU,2) +C The leading 2-by-2 part of this array contains the upper +C triangular matrix U. +C +C LDU INTEGER +C The leading dimension of the array U. LDU >= 2. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in U. +C 0 < SCALE <= 1. +C +C M1 (output) DOUBLE PRECISION array, dimension (LDM1,2) +C The leading 2-by-2 part of this array contains the +C matrix M1. +C +C LDM1 INTEGER +C The leading dimension of the array M1. LDM1 >= 2. +C +C M2 (output) DOUBLE PRECISION array, dimension (LDM2,2) +C The leading 2-by-2 part of this array contains the +C matrix M2. +C +C LDM2 INTEGER +C The leading dimension of the array M2. LDM2 >= 2. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 2: the eigenvalues of the pencil A - lambda * E are not +C a pair of complex conjugate numbers; +C = 3: the eigenvalues of the pencil A - lambda * E are +C not in the open right half plane (in the continuous- +C time case) or inside the unit circle (in the +C discrete-time case). +C +C METHOD +C +C The method used by the routine is based on a generalization of the +C method due to Hammarling ([1], section 6) for Lyapunov equations +C of order 2. A more detailed description is given in [2]. +C +C REFERENCES +C +C [1] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-323, 1982. +C +C [2] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C FURTHER COMMENTS +C +C If the solution matrix U is singular, the matrices M1 and M2 are +C properly set (see [1], equation (6.21)). +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C Dec. 1998 (V. Sima). +C July 2003 (V. Sima; suggested by Klaus Schnepper). +C Oct. 2003 (A. Varga). +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION MONE, ONE, TWO, ZERO + PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ ZERO = 0.0D+0) +C .. Scalar Arguments .. + CHARACTER DICO, TRANS + DOUBLE PRECISION SCALE + INTEGER INFO, LDA, LDB, LDE, LDM1, LDM2, LDU +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), E(LDE,*), M1(LDM1,*), + $ M2(LDM2,*), U(LDU,*) +C .. Local Scalars .. + DOUBLE PRECISION ALPHA, B11, B12I, B12R, B22, BETAI, BETAR, + $ BIGNUM, CI, CR, EPS, L, LAMI, LAMR, SCALE1, + $ SCALE2, SI, SMLNUM, SR, T, V, W, XR, XI, YR, YI + LOGICAL ISCONT, ISTRNS +C .. Local Arrays .. + DOUBLE PRECISION AA(2,2), AI(2,2), AR(2,2), BB(2,2), BI(2,2), + $ BR(2,2), EE(2,2), EI(2,2), ER(2,2), M1I(2,2), + $ M1R(2,2), M2I(2,2), M2R(2,2), QBI(2,2), + $ QBR(2,2), QI(2,2), QR(2,2), QUI(2,2), QUR(2,2), + $ TI(2,2), TR(2,2), UI(2,2), UR(2,2), ZI(2,2), + $ ZR(2,2) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + LOGICAL LSAME + EXTERNAL DLAMCH, DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, DLADIV, DLAG2, + $ SG03BY +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +C +C Decode input parameters. +C + ISTRNS = LSAME( TRANS, 'T' ) + ISCONT = LSAME( DICO, 'C' ) +C +C Do not check input parameters for errors. +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' )/EPS + BIGNUM = ONE/SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C + INFO = 0 + SCALE = ONE +C +C Make copies of A, E, and B. +C + AA(1,1) = A(1,1) + AA(2,1) = A(2,1) + AA(1,2) = A(1,2) + AA(2,2) = A(2,2) + EE(1,1) = E(1,1) + EE(2,1) = ZERO + EE(1,2) = E(1,2) + EE(2,2) = E(2,2) + BB(1,1) = B(1,1) + BB(2,1) = ZERO + BB(1,2) = B(1,2) + BB(2,2) = B(2,2) +C +C If the transposed equation (op(K)=K**T, K=A,B,E,U) is to be +C solved, transpose the matrices A, E, B with respect to the +C anti-diagonal. This results in a non-transposed equation. +C + IF ( ISTRNS ) THEN + V = AA(1,1) + AA(1,1) = AA(2,2) + AA(2,2) = V + V = EE(1,1) + EE(1,1) = EE(2,2) + EE(2,2) = V + V = BB(1,1) + BB(1,1) = BB(2,2) + BB(2,2) = V + END IF +C +C Perform QZ-step to transform the pencil A - lambda * E to +C generalized Schur form. The main diagonal of the Schur factor of E +C is real and positive. +C +C Compute eigenvalues (LAMR + LAMI * I, LAMR - LAMI * I). +C + T = MAX( EPS*MAX( ABS( EE(1,1) ), ABS( EE(1,2) ), + $ ABS( EE(2,2) ) ), SMLNUM ) + IF ( MIN( ABS( EE(1,1) ), ABS( EE(2,2) ) ) .LT. T ) THEN + INFO = 3 + RETURN + END IF + CALL DLAG2( AA, 2, EE, 2, SMLNUM*EPS, SCALE1, SCALE2, LAMR, + $ W, LAMI ) + IF (LAMI .LE. ZERO) THEN + INFO = 2 + RETURN + END IF +C +C Compute right orthogonal transformation matrix Q. +C + CALL SG03BY( SCALE1*AA(1,1) - EE(1,1)*LAMR, -EE(1,1)*LAMI, + $ SCALE1*AA(2,1), ZERO, CR, CI, SR, SI, L ) + QR(1,1) = CR + QR(1,2) = SR + QR(2,1) = -SR + QR(2,2) = CR + QI(1,1) = -CI + QI(1,2) = -SI + QI(2,1) = -SI + QI(2,2) = CI +C +C A := Q * A +C + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QR, 2, AA, 2, ZERO, AR, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QI, 2, AA, 2, ZERO, AI, 2 ) +C +C E := Q * E +C + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QR, 2, EE, 2, ZERO, ER, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QI, 2, EE, 2, ZERO, EI, 2 ) +C +C Compute left orthogonal transformation matrix Z. +C + CALL SG03BY( ER(2,2), EI(2,2), ER(2,1), EI(2,1), CR, CI, SR, SI, + $ L ) + ZR(1,1) = CR + ZR(1,2) = SR + ZR(2,1) = -SR + ZR(2,2) = CR + ZI(1,1) = CI + ZI(1,2) = -SI + ZI(2,1) = -SI + ZI(2,2) = -CI +C +C E := E * Z +C + CALL DGEMV( 'T', 2, 2, ONE, ZR, 2, ER, 2, ZERO, TR, 2 ) + CALL DGEMV( 'T', 2, 2, MONE, ZI, 2, EI, 2, ONE, TR, 2 ) + CALL DGEMV( 'T', 2, 2, ONE, ZI, 2, ER, 2, ZERO, TI, 2 ) + CALL DGEMV( 'T', 2, 2, ONE, ZR, 2, EI, 2, ONE, TI, 2 ) + CALL DCOPY( 2, TR, 2, ER, 2 ) + CALL DCOPY( 2, TI, 2, EI, 2 ) + ER(2,1) = ZERO + ER(2,2) = L + EI(2,1) = ZERO + EI(2,2) = ZERO +C +C Make main diagonal entries of E real and positive. +C (Note: Z and E are altered.) +C + V = DLAPY2( ER(1,1), EI(1,1) ) + CALL DLADIV( V, ZERO, ER(1,1), EI(1,1), XR, XI ) + ER(1,1) = V + EI(1,1) = ZERO + YR = ZR(1,1) + YI = ZI(1,1) + ZR(1,1) = XR*YR - XI*YI + ZI(1,1) = XR*YI + XI*YR + YR = ZR(2,1) + YI = ZI(2,1) + ZR(2,1) = XR*YR - XI*YI + ZI(2,1) = XR*YI + XI*YR +C +C A := A * Z +C + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, AR, 2, ZR, 2, ZERO, TR, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, MONE, AI, 2, ZI, 2, ONE, TR, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, AR, 2, ZI, 2, ZERO, TI, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, AI, 2, ZR, 2, ONE, TI, 2 ) + CALL DCOPY( 4, TR, 1, AR, 1 ) + CALL DCOPY( 4, TI, 1, AI, 1 ) +C +C End of QZ-step. +C +C B := B * Z +C + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, BB, 2, ZR, 2, ZERO, BR, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, BB, 2, ZI, 2, ZERO, BI, 2 ) +C +C Overwrite B with the upper triangular matrix of its +C QR-factorization. The elements on the main diagonal are real +C and non-negative. +C + CALL SG03BY( BR(1,1), BI(1,1), BR(2,1), BI(2,1), CR, CI, SR, SI, + $ L ) + QBR(1,1) = CR + QBR(1,2) = SR + QBR(2,1) = -SR + QBR(2,2) = CR + QBI(1,1) = -CI + QBI(1,2) = -SI + QBI(2,1) = -SI + QBI(2,2) = CI + CALL DGEMV( 'N', 2, 2, ONE, QBR, 2, BR(1,2), 1, ZERO, TR, 1 ) + CALL DGEMV( 'N', 2, 2, MONE, QBI, 2, BI(1,2), 1, ONE, TR, 1 ) + CALL DGEMV( 'N', 2, 2, ONE, QBI, 2, BR(1,2), 1, ZERO, TI, 1 ) + CALL DGEMV( 'N', 2, 2, ONE, QBR, 2, BI(1,2), 1, ONE, TI, 1 ) + CALL DCOPY( 2, TR, 1, BR(1,2), 1 ) + CALL DCOPY( 2, TI, 1, BI(1,2), 1 ) + BR(1,1) = L + BR(2,1) = ZERO + BI(1,1) = ZERO + BI(2,1) = ZERO + V = DLAPY2( BR(2,2), BI(2,2) ) + IF ( V .GE. MAX( EPS*MAX( BR(1,1), DLAPY2( BR(1,2), BI(1,2) ) ), + $ SMLNUM ) ) THEN + CALL DLADIV( V, ZERO, BR(2,2), BI(2,2), XR, XI ) + BR(2,2) = V + YR = QBR(2,1) + YI = QBI(2,1) + QBR(2,1) = XR*YR - XI*YI + QBI(2,1) = XR*YI + XI*YR + YR = QBR(2,2) + YI = QBI(2,2) + QBR(2,2) = XR*YR - XI*YI + QBI(2,2) = XR*YI + XI*YR + ELSE + BR(2,2) = ZERO + END IF + BI(2,2) = ZERO +C +C Compute the Cholesky factor of the solution of the reduced +C equation. The solution may be scaled to avoid overflow. +C + IF ( ISCONT ) THEN +C +C Continuous-time equation. +C +C Step I: Compute U(1,1). Set U(2,1) = 0. +C + V = -TWO*( AR(1,1)*ER(1,1) + AI(1,1)*EI(1,1) ) + IF ( V .LE. ZERO ) THEN + INFO = 3 + RETURN + END IF + V = SQRT( V ) + T = TWO*ABS( BR(1,1) )*SMLNUM + IF ( T .GT. V ) THEN + SCALE1 = V/T + SCALE = SCALE1*SCALE + BR(1,1) = SCALE1*BR(1,1) + BR(1,2) = SCALE1*BR(1,2) + BI(1,2) = SCALE1*BI(1,2) + BR(2,2) = SCALE1*BR(2,2) + END IF + UR(1,1) = BR(1,1)/V + UI(1,1) = ZERO + UR(2,1) = ZERO + UI(2,1) = ZERO +C +C Step II: Compute U(1,2). +C + T = MAX( EPS*MAX( BR(2,2), DLAPY2( BR(1,2), BI(1,2) ) ), + $ SMLNUM ) + IF ( ABS( BR(1,1) ) .LT. T ) THEN + UR(1,2) = ZERO + UI(1,2) = ZERO + ELSE + XR = AR(1,1)*ER(1,2) + AI(1,1)*EI(1,2) + XI = AI(1,1)*ER(1,2) - AR(1,1)*EI(1,2) + XR = XR + AR(1,2)*ER(1,1) + AI(1,2)*EI(1,1) + XI = XI - AI(1,2)*ER(1,1) + AR(1,2)*EI(1,1) + XR = -BR(1,2)*V - XR*UR(1,1) + XI = BI(1,2)*V - XI*UR(1,1) + YR = AR(2,2)*ER(1,1) + AI(2,2)*EI(1,1) + YI = -AI(2,2)*ER(1,1) + AR(2,2)*EI(1,1) + YR = YR + ER(2,2)*AR(1,1) + EI(2,2)*AI(1,1) + YI = YI - EI(2,2)*AR(1,1) + ER(2,2)*AI(1,1) + T = TWO*DLAPY2( XR, XI )*SMLNUM + IF ( T .GT. DLAPY2( YR, YI ) ) THEN + SCALE1 = DLAPY2( YR, YI )/T + SCALE = SCALE1*SCALE + BR(1,1) = SCALE1*BR(1,1) + BR(1,2) = SCALE1*BR(1,2) + BI(1,2) = SCALE1*BI(1,2) + BR(2,2) = SCALE1*BR(2,2) + UR(1,1) = SCALE1*UR(1,1) + XR = SCALE1*XR + XI = SCALE1*XI + END IF + CALL DLADIV( XR, XI, YR, YI, UR(1,2), UI(1,2) ) + UI(1,2) = -UI(1,2) + END IF +C +C Step III: Compute U(2,2). +C + XR = ( ER(1,2)*UR(1,1) + ER(2,2)*UR(1,2) - EI(2,2)*UI(1,2) )*V + XI = (-EI(1,2)*UR(1,1) - ER(2,2)*UI(1,2) - EI(2,2)*UR(1,2) )*V + T = TWO*DLAPY2( XR, XI )*SMLNUM + IF ( T .GT. DLAPY2( ER(1,1), EI(1,1) ) ) THEN + SCALE1 = DLAPY2( ER(1,1), EI(1,1) )/T + SCALE = SCALE1*SCALE + UR(1,1) = SCALE1*UR(1,1) + UR(1,2) = SCALE1*UR(1,2) + UI(1,2) = SCALE1*UI(1,2) + BR(1,1) = SCALE1*BR(1,1) + BR(1,2) = SCALE1*BR(1,2) + BI(1,2) = SCALE1*BI(1,2) + BR(2,2) = SCALE1*BR(2,2) + XR = SCALE1*XR + XI = SCALE1*XI + END IF + CALL DLADIV( XR, XI, ER(1,1), -EI(1,1), YR, YI ) + YR = BR(1,2) - YR + YI = -BI(1,2) - YI + V = -TWO*( AR(2,2)*ER(2,2) + AI(2,2)*EI(2,2) ) + IF ( V .LE. ZERO ) THEN + INFO = 3 + RETURN + END IF + V = SQRT( V ) + W = DLAPY2( DLAPY2( BR(2,2), BI(2,2) ), DLAPY2( YR, YI ) ) + T = TWO*W*SMLNUM + IF ( T .GT. V ) THEN + SCALE1 = V/T + SCALE = SCALE1*SCALE + UR(1,1) = SCALE1*UR(1,1) + UR(1,2) = SCALE1*UR(1,2) + UI(1,2) = SCALE1*UI(1,2) + BR(1,1) = SCALE1*BR(1,1) + BR(1,2) = SCALE1*BR(1,2) + BI(1,2) = SCALE1*BI(1,2) + BR(2,2) = SCALE1*BR(2,2) + W = SCALE1*W + END IF + UR(2,2) = W/V + UI(2,2) = ZERO +C +C Compute matrices M1 and M2 for the reduced equation. +C + M1R(2,1) = ZERO + M1I(2,1) = ZERO + M2R(2,1) = ZERO + M2I(2,1) = ZERO + CALL DLADIV( AR(1,1), AI(1,1), ER(1,1), EI(1,1), BETAR, BETAI ) + M1R(1,1) = BETAR + M1I(1,1) = BETAI + M1R(2,2) = BETAR + M1I(2,2) = -BETAI + ALPHA = SQRT( -TWO*BETAR ) + M2R(1,1) = ALPHA + M2I(1,1) = ZERO + V = ER(1,1)*ER(2,2) + XR = ( -BR(1,1)*ER(1,2) + ER(1,1)*BR(1,2) )/V + XI = ( -BR(1,1)*EI(1,2) + ER(1,1)*BI(1,2) )/V + YR = XR - ALPHA*UR(1,2) + YI = -XI + ALPHA*UI(1,2) + IF ( ( YR.NE.ZERO ) .OR. ( YI.NE.ZERO ) ) THEN + M2R(1,2) = YR/UR(2,2) + M2I(1,2) = -YI/UR(2,2) + M2R(2,2) = BR(2,2)/( ER(2,2)*UR(2,2) ) + M2I(2,2) = ZERO + M1R(1,2) = -ALPHA*M2R(1,2) + M1I(1,2) = -ALPHA*M2I(1,2) + ELSE + M2R(1,2) = ZERO + M2I(1,2) = ZERO + M2R(2,2) = ALPHA + M2I(2,2) = ZERO + M1R(1,2) = ZERO + M1I(1,2) = ZERO + END IF + ELSE +C +C Discrete-time equation. +C +C Step I: Compute U(1,1). Set U(2,1) = 0. +C + V = ER(1,1)**2 + EI(1,1)**2 - AR(1,1)**2 - AI(1,1)**2 + IF ( V .LE. ZERO ) THEN + INFO = 3 + RETURN + END IF + V = SQRT( V ) + T = TWO*ABS( BR(1,1) )*SMLNUM + IF ( T .GT. V ) THEN + SCALE1 = V/T + SCALE = SCALE1*SCALE + BR(1,1) = SCALE1*BR(1,1) + BR(1,2) = SCALE1*BR(1,2) + BI(1,2) = SCALE1*BI(1,2) + BR(2,2) = SCALE1*BR(2,2) + END IF + UR(1,1) = BR(1,1)/V + UI(1,1) = ZERO + UR(2,1) = ZERO + UI(2,1) = ZERO +C +C Step II: Compute U(1,2). +C + T = MAX( EPS*MAX( BR(2,2), DLAPY2( BR(1,2), BI(1,2) ) ), + $ SMLNUM ) + IF ( ABS( BR(1,1) ) .LT. T ) THEN + UR(1,2) = ZERO + UI(1,2) = ZERO + ELSE + XR = AR(1,1)*AR(1,2) + AI(1,1)*AI(1,2) + XI = AI(1,1)*AR(1,2) - AR(1,1)*AI(1,2) + XR = XR - ER(1,2)*ER(1,1) - EI(1,2)*EI(1,1) + XI = XI + EI(1,2)*ER(1,1) - ER(1,2)*EI(1,1) + XR = -BR(1,2)*V - XR*UR(1,1) + XI = BI(1,2)*V - XI*UR(1,1) + YR = AR(2,2)*AR(1,1) + AI(2,2)*AI(1,1) + YI = -AI(2,2)*AR(1,1) + AR(2,2)*AI(1,1) + YR = YR - ER(2,2)*ER(1,1) - EI(2,2)*EI(1,1) + YI = YI + EI(2,2)*ER(1,1) - ER(2,2)*EI(1,1) + T = TWO*DLAPY2( XR, XI )*SMLNUM + IF ( T .GT. DLAPY2( YR, YI ) ) THEN + SCALE1 = DLAPY2( YR, YI )/T + SCALE = SCALE1*SCALE + BR(1,1) = SCALE1*BR(1,1) + BR(1,2) = SCALE1*BR(1,2) + BI(1,2) = SCALE1*BI(1,2) + BR(2,2) = SCALE1*BR(2,2) + UR(1,1) = SCALE1*UR(1,1) + XR = SCALE1*XR + XI = SCALE1*XI + END IF + CALL DLADIV( XR, XI, YR, YI, UR(1,2), UI(1,2) ) + UI(1,2) = -UI(1,2) + END IF +C +C Step III: Compute U(2,2). +C + XR = ER(1,2)*UR(1,1) + ER(2,2)*UR(1,2) - EI(2,2)*UI(1,2) + XI = -EI(1,2)*UR(1,1) - ER(2,2)*UI(1,2) - EI(2,2)*UR(1,2) + YR = AR(1,2)*UR(1,1) + AR(2,2)*UR(1,2) - AI(2,2)*UI(1,2) + YI = -AI(1,2)*UR(1,1) - AR(2,2)*UI(1,2) - AI(2,2)*UR(1,2) + V = ER(2,2)**2 + EI(2,2)**2 - AR(2,2)**2 - AI(2,2)**2 + IF ( V .LE. ZERO ) THEN + INFO = 3 + RETURN + END IF + V = SQRT( V ) + T = MAX( ABS( BR(2,2) ), ABS( BR(1,2) ), ABS( BI(1,2) ), + $ ABS( XR ), ABS( XI ), ABS( YR ), ABS( YI) ) + IF ( T .LE. SMLNUM ) T = ONE + W = ( BR(2,2)/T )**2 + ( BR(1,2)/T )**2 + ( BI(1,2)/T )**2 - + $ ( XR/T )**2 - ( XI/T )**2 + ( YR/T )**2 + ( YI/T )**2 + IF ( W .LT. ZERO ) THEN + INFO = 3 + RETURN + END IF + W = T*SQRT( W ) + T = TWO*W*SMLNUM + IF ( T .GT. V ) THEN + SCALE1 = V/T + SCALE = SCALE1*SCALE + UR(1,1) = SCALE1*UR(1,1) + UR(1,2) = SCALE1*UR(1,2) + UI(1,2) = SCALE1*UI(1,2) + BR(1,1) = SCALE1*BR(1,1) + BR(1,2) = SCALE1*BR(1,2) + BI(1,2) = SCALE1*BI(1,2) + BR(2,2) = SCALE1*BR(2,2) + W = SCALE1*W + END IF + UR(2,2) = W/V + UI(2,2) = ZERO +C +C Compute matrices M1 and M2 for the reduced equation. +C + B11 = BR(1,1)/ER(1,1) + T = ER(1,1)*ER(2,2) + B12R = ( ER(1,1)*BR(1,2) - BR(1,1)*ER(1,2) )/T + B12I = ( ER(1,1)*BI(1,2) - BR(1,1)*EI(1,2) )/T + B22 = BR(2,2)/ER(2,2) + M1R(2,1) = ZERO + M1I(2,1) = ZERO + M2R(2,1) = ZERO + M2I(2,1) = ZERO + CALL DLADIV( AR(1,1), AI(1,1), ER(1,1), EI(1,1), BETAR, BETAI ) + M1R(1,1) = BETAR + M1I(1,1) = BETAI + M1R(2,2) = BETAR + M1I(2,2) = -BETAI + V = DLAPY2( BETAR, BETAI ) + ALPHA = SQRT( ( ONE - V )*( ONE + V ) ) + M2R(1,1) = ALPHA + M2I(1,1) = ZERO + XR = ( AI(1,1)*EI(1,2) - AR(1,1)*ER(1,2) )/T + AR(1,2)/ER(2,2) + XI = ( AR(1,1)*EI(1,2) + AI(1,1)*ER(1,2) )/T - AI(1,2)/ER(2,2) + XR = -TWO*BETAI*B12I - B11*XR + XI = -TWO*BETAI*B12R - B11*XI + V = ONE + ( BETAI - BETAR )*( BETAI + BETAR ) + W = -TWO*BETAI*BETAR + CALL DLADIV( XR, XI, V, W, YR, YI ) + IF ( ( YR.NE.ZERO ) .OR. ( YI.NE.ZERO ) ) THEN + M2R(1,2) = ( YR*BETAR - YI*BETAI )/UR(2,2) + M2I(1,2) = -( YI*BETAR + YR*BETAI )/UR(2,2) + M2R(2,2) = B22/UR(2,2) + M2I(2,2) = ZERO + M1R(1,2) = -ALPHA*YR/UR(2,2) + M1I(1,2) = ALPHA*YI/UR(2,2) + ELSE + M2R(1,2) = ZERO + M2I(1,2) = ZERO + M2R(2,2) = ALPHA + M2I(2,2) = ZERO + M1R(1,2) = ZERO + M1I(1,2) = ZERO + END IF + END IF +C +C Transform U back: U := U * Q. +C (Note: Z is used as workspace.) +C + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, UR, 2, QR, 2, ZERO, ZR, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, MONE, UI, 2, QI, 2, ONE, ZR, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, UR, 2, QI, 2, ZERO, ZI, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, UI, 2, QR, 2, ONE, ZI, 2 ) +C +C Overwrite U with the upper triangular matrix of its +C QR-factorization. The elements on the main diagonal are real +C and non-negative. +C + CALL SG03BY( ZR(1,1), ZI(1,1), ZR(2,1), ZI(2,1), CR, CI, SR, SI, + $ L ) + QUR(1,1) = CR + QUR(1,2) = SR + QUR(2,1) = -SR + QUR(2,2) = CR + QUI(1,1) = -CI + QUI(1,2) = -SI + QUI(2,1) = -SI + QUI(2,2) = CI + CALL DGEMV( 'N', 2, 2, ONE, QUR, 2, ZR(1,2), 1, ZERO, U(1,2), 1) + CALL DGEMV( 'N', 2, 2, MONE, QUI, 2, ZI(1,2), 1, ONE, U(1,2), 1) + CALL DGEMV( 'N', 2, 2, ONE, QUI, 2, ZR(1,2), 1, ZERO, UI(1,2), 1) + CALL DGEMV( 'N', 2, 2, ONE, QUR, 2, ZI(1,2), 1, ONE, UI(1,2), 1) + U(1,1) = L + U(2,1) = ZERO + V = DLAPY2( U(2,2), UI(2,2) ) + IF ( V .NE. ZERO ) THEN + CALL DLADIV( V, ZERO, U(2,2), UI(2,2), XR, XI ) + YR = QUR(2,1) + YI = QUI(2,1) + QUR(2,1) = XR*YR - XI*YI + QUI(2,1) = XR*YI + XI*YR + YR = QUR(2,2) + YI = QUI(2,2) + QUR(2,2) = XR*YR - XI*YI + QUI(2,2) = XR*YI + XI*YR + END IF + U(2,2) = V +C +C Transform the matrices M1 and M2 back. +C +C M1 := QU * M1 * QU**H +C M2 := QB**H * M2 * QU**H +C + CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M1R, 2, QUR, 2, ZERO, TR, 2 ) + CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M1I, 2, QUI, 2, ONE, TR, 2 ) + CALL DGEMM( 'N', 'T', 2, 2, 2, MONE, M1R, 2, QUI, 2, ZERO, TI, 2 ) + CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M1I, 2, QUR, 2, ONE, TI, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QUR, 2, TR, 2, ZERO, M1, + $ LDM1 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, MONE, QUI, 2, TI, 2, ONE, M1, + $ LDM1 ) +C + CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M2R, 2, QUR, 2, ZERO, TR, 2 ) + CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M2I, 2, QUI, 2, ONE, TR, 2 ) + CALL DGEMM( 'N', 'T', 2, 2, 2, MONE, M2R, 2, QUI, 2, ZERO, TI, 2 ) + CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M2I, 2, QUR, 2, ONE, TI, 2 ) + CALL DGEMM( 'T', 'N', 2, 2, 2, ONE, QBR, 2, TR, 2, ZERO, M2, + $ LDM2 ) + CALL DGEMM( 'T', 'N', 2, 2, 2, ONE, QBI, 2, TI, 2, ONE, M2, + $ LDM2 ) +C +C If the transposed equation (op(K)=K**T, K=A,B,E,U) is to be +C solved, transpose the matrix U with respect to the +C anti-diagonal and the matrices M1, M2 with respect to the diagonal +C and the anti-diagonal. +C + IF ( ISTRNS ) THEN + V = U(1,1) + U(1,1) = U(2,2) + U(2,2) = V + V = M1(1,1) + M1(1,1) = M1(2,2) + M1(2,2) = V + V = M2(1,1) + M2(1,1) = M2(2,2) + M2(2,2) = V + END IF +C + RETURN +C *** Last line of SG03BX *** + END diff --git a/mex/sources/libslicot/SG03BY.f b/mex/sources/libslicot/SG03BY.f new file mode 100644 index 000000000..356fe0423 --- /dev/null +++ b/mex/sources/libslicot/SG03BY.f @@ -0,0 +1,93 @@ + SUBROUTINE SG03BY( XR, XI, YR, YI, CR, CI, SR, SI, Z ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the parameters for the complex Givens rotation +C +C ( CR-CI*I SR-SI*I ) ( XR+XI*I ) ( Z ) +C ( ) * ( ) = ( ), +C ( -SR-SI*I CR+CI*I ) ( YR+YI*I ) ( 0 ) +C +C where CR, CI, SR, SI, XR, XI, YR, YI are real numbers and I is the +C imaginary unit, I = SQRT(-1). Z is a non-negative real number. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C XR, XI, (input) DOUBLE PRECISION +C YR, YI (input) DOUBLE PRECISION +C The given real scalars XR, XI, YR, YI. +C +C CR, CI, (output) DOUBLE PRECISION +C SR, SI, (output) DOUBLE PRECISION +C Z (output) DOUBLE PRECISION +C The computed real scalars CR, CI, SR, SI, Z, defining the +C complex Givens rotation and Z. +C +C NUMERICAL ASPECTS +C +C The subroutine avoids unnecessary overflow. +C +C FURTHER COMMENTS +C +C In the interest of speed, this routine does not check the input +C for errors. +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION CI, CR, SI, SR, XI, XR, YI, YR, Z +C .. Intrinsic Functions .. + DOUBLE PRECISION ABS, MAX, SQRT +C .. Executable Statements .. +C + Z = MAX( ABS( XR ), ABS( XI ), ABS( YR ), ABS( YI ) ) +C + IF ( Z .EQ. ZERO ) THEN + CR = ONE + CI = ZERO + SR = ZERO + SI = ZERO + ELSE + Z = Z*SQRT( ( XR/Z )**2 + ( XI/Z )**2 + + $ ( YR/Z )**2 + ( YI/Z )**2 ) + CR = XR/Z + CI = XI/Z + SR = YR/Z + SI = YI/Z + END IF +C + RETURN +C +C *** Last line of SG03BY *** + END diff --git a/mex/sources/libslicot/TB01ID.f b/mex/sources/libslicot/TB01ID.f new file mode 100644 index 000000000..9dbedb634 --- /dev/null +++ b/mex/sources/libslicot/TB01ID.f @@ -0,0 +1,402 @@ + SUBROUTINE TB01ID( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the 1-norm of a system matrix +C +C S = ( A B ) +C ( C 0 ) +C +C corresponding to the triple (A,B,C), by balancing. This involves +C a diagonal similarity transformation inv(D)*A*D applied +C iteratively to A to make the rows and columns of +C -1 +C diag(D,I) * S * diag(D,I) +C +C as close in norm as possible. +C +C The balancing can be performed optionally on the following +C particular system matrices +C +C S = A, S = ( A B ) or S = ( A ) +C ( C ) +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Indicates which matrices are involved in balancing, as +C follows: +C = 'A': All matrices are involved in balancing; +C = 'B': B and A matrices are involved in balancing; +C = 'C': C and A matrices are involved in balancing; +C = 'N': B and C matrices are not involved in balancing. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A, the number of rows of matrix B +C and the number of columns of matrix C. +C N represents the dimension of the state vector. N >= 0. +C +C M (input) INTEGER. +C The number of columns of matrix B. +C M represents the dimension of input vector. M >= 0. +C +C P (input) INTEGER. +C The number of rows of matrix C. +C P represents the dimension of output vector. P >= 0. +C +C MAXRED (input/output) DOUBLE PRECISION +C On entry, the maximum allowed reduction in the 1-norm of +C S (in an iteration) if zero rows or columns are +C encountered. +C If MAXRED > 0.0, MAXRED must be larger than one (to enable +C the norm reduction). +C If MAXRED <= 0.0, then the value 10.0 for MAXRED is +C used. +C On exit, if the 1-norm of the given matrix S is non-zero, +C the ratio between the 1-norm of the given matrix and the +C 1-norm of the balanced matrix. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the system state matrix A. +C On exit, the leading N-by-N part of this array contains +C the balanced matrix inv(D)*A*D. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, if M > 0, the leading N-by-M part of this array +C must contain the system input matrix B. +C On exit, if M > 0, the leading N-by-M part of this array +C contains the balanced matrix inv(D)*B. +C The array B is not referenced if M = 0. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,N) if M > 0. +C LDB >= 1 if M = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, if P > 0, the leading P-by-N part of this array +C must contain the system output matrix C. +C On exit, if P > 0, the leading P-by-N part of this array +C contains the balanced matrix C*D. +C The array C is not referenced if P = 0. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,P). +C +C SCALE (output) DOUBLE PRECISION array, dimension (N) +C The scaling factors applied to S. If D(j) is the scaling +C factor applied to row and column j, then SCALE(j) = D(j), +C for j = 1,...,N. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Balancing consists of applying a diagonal similarity +C transformation +C -1 +C diag(D,I) * S * diag(D,I) +C +C to make the 1-norms of each row of the first N rows of S and its +C corresponding column nearly equal. +C +C Information about the diagonal matrix D is returned in the vector +C SCALE. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. +C This subroutine is based on LAPACK routine DGEBAL, and routine +C BALABC (A. Varga, German Aerospace Research Establishment, DLR). +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Balancing, eigenvalue, matrix algebra, matrix operations, +C similarity transformation. +C +C ********************************************************************* +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION SCLFAC + PARAMETER ( SCLFAC = 1.0D+1 ) + DOUBLE PRECISION FACTOR, MAXR + PARAMETER ( FACTOR = 0.95D+0, MAXR = 10.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, LDA, LDB, LDC, M, N, P + DOUBLE PRECISION MAXRED +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ SCALE( * ) +C .. +C .. Local Scalars .. + LOGICAL NOCONV, WITHB, WITHC + INTEGER I, ICA, IRA, J + DOUBLE PRECISION CA, CO, F, G, MAXNRM, RA, RO, S, SFMAX1, + $ SFMAX2, SFMIN1, SFMIN2, SNORM, SRED +C .. +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DASUM, DLAMCH + EXTERNAL DASUM, DLAMCH, IDAMAX, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DSCAL, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the scalar input arguments. +C + INFO = 0 + WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) + WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) +C + IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) + $ THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( MAXRED.GT.ZERO .AND. MAXRED.LT.ONE ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( ( M.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. + $ ( M.EQ.0 .AND. LDB.LT.1 ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TB01ID', -INFO ) + RETURN + END IF +C + IF( N.EQ.0 ) + $ RETURN +C +C Compute the 1-norm of the required part of matrix S and exit if +C it is zero. +C + SNORM = ZERO +C + DO 10 J = 1, N + SCALE( J ) = ONE + CO = DASUM( N, A( 1, J ), 1 ) + IF( WITHC .AND. P.GT.0 ) + $ CO = CO + DASUM( P, C( 1, J ), 1 ) + SNORM = MAX( SNORM, CO ) + 10 CONTINUE +C + IF( WITHB ) THEN +C + DO 20 J = 1, M + SNORM = MAX( SNORM, DASUM( N, B( 1, J ), 1 ) ) + 20 CONTINUE +C + END IF +C + IF( SNORM.EQ.ZERO ) + $ RETURN +C +C Set some machine parameters and the maximum reduction in the +C 1-norm of S if zero rows or columns are encountered. +C + SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) + SFMAX1 = ONE / SFMIN1 + SFMIN2 = SFMIN1*SCLFAC + SFMAX2 = ONE / SFMIN2 +C + SRED = MAXRED + IF( SRED.LE.ZERO ) SRED = MAXR +C + MAXNRM = MAX( SNORM/SRED, SFMIN1 ) +C +C Balance the matrix. +C +C Iterative loop for norm reduction. +C + 30 CONTINUE + NOCONV = .FALSE. +C + DO 90 I = 1, N + CO = ZERO + RO = ZERO +C + DO 40 J = 1, N + IF( J.EQ.I ) + $ GO TO 40 + CO = CO + ABS( A( J, I ) ) + RO = RO + ABS( A( I, J ) ) + 40 CONTINUE +C + ICA = IDAMAX( N, A( 1, I ), 1 ) + CA = ABS( A( ICA, I ) ) + IRA = IDAMAX( N, A( I, 1 ), LDA ) + RA = ABS( A( I, IRA ) ) +C + IF( WITHC .AND. P.GT.0 ) THEN + CO = CO + DASUM( P, C( 1, I ), 1 ) + ICA = IDAMAX( P, C( 1, I ), 1 ) + CA = MAX( CA, ABS( C( ICA, I ) ) ) + END IF +C + IF( WITHB .AND. M.GT.0 ) THEN + RO = RO + DASUM( M, B( I, 1 ), LDB ) + IRA = IDAMAX( M, B( I, 1 ), LDB ) + RA = MAX( RA, ABS( B( I, IRA ) ) ) + END IF +C +C Special case of zero CO and/or RO. +C + IF( CO.EQ.ZERO .AND. RO.EQ.ZERO ) + $ GO TO 90 + IF( CO.EQ.ZERO ) THEN + IF( RO.LE.MAXNRM ) + $ GO TO 90 + CO = MAXNRM + END IF + IF( RO.EQ.ZERO ) THEN + IF( CO.LE.MAXNRM ) + $ GO TO 90 + RO = MAXNRM + END IF +C +C Guard against zero CO or RO due to underflow. +C + G = RO / SCLFAC + F = ONE + S = CO + RO + 50 CONTINUE + IF( CO.GE.G .OR. MAX( F, CO, CA ).GE.SFMAX2 .OR. + $ MIN( RO, G, RA ).LE.SFMIN2 )GO TO 60 + F = F*SCLFAC + CO = CO*SCLFAC + CA = CA*SCLFAC + G = G / SCLFAC + RO = RO / SCLFAC + RA = RA / SCLFAC + GO TO 50 +C + 60 CONTINUE + G = CO / SCLFAC + 70 CONTINUE + IF( G.LT.RO .OR. MAX( RO, RA ).GE.SFMAX2 .OR. + $ MIN( F, CO, G, CA ).LE.SFMIN2 )GO TO 80 + F = F / SCLFAC + CO = CO / SCLFAC + CA = CA / SCLFAC + G = G / SCLFAC + RO = RO*SCLFAC + RA = RA*SCLFAC + GO TO 70 +C +C Now balance. +C + 80 CONTINUE + IF( ( CO+RO ).GE.FACTOR*S ) + $ GO TO 90 + IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN + IF( F*SCALE( I ).LE.SFMIN1 ) + $ GO TO 90 + END IF + IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN + IF( SCALE( I ).GE.SFMAX1 / F ) + $ GO TO 90 + END IF + G = ONE / F + SCALE( I ) = SCALE( I )*F + NOCONV = .TRUE. +C + CALL DSCAL( N, G, A( I, 1 ), LDA ) + CALL DSCAL( N, F, A( 1, I ), 1 ) + IF( M.GT.0 ) CALL DSCAL( M, G, B( I, 1 ), LDB ) + IF( P.GT.0 ) CALL DSCAL( P, F, C( 1, I ), 1 ) +C + 90 CONTINUE +C + IF( NOCONV ) + $ GO TO 30 +C +C Set the norm reduction parameter. +C + MAXRED = SNORM + SNORM = ZERO +C + DO 100 J = 1, N + CO = DASUM( N, A( 1, J ), 1 ) + IF( WITHC .AND. P.GT.0 ) + $ CO = CO + DASUM( P, C( 1, J ), 1 ) + SNORM = MAX( SNORM, CO ) + 100 CONTINUE +C + IF( WITHB ) THEN +C + DO 110 J = 1, M + SNORM = MAX( SNORM, DASUM( N, B( 1, J ), 1 ) ) + 110 CONTINUE +C + END IF + MAXRED = MAXRED/SNORM + RETURN +C *** Last line of TB01ID *** + END diff --git a/mex/sources/libslicot/TB01IZ.f b/mex/sources/libslicot/TB01IZ.f new file mode 100644 index 000000000..e719aa390 --- /dev/null +++ b/mex/sources/libslicot/TB01IZ.f @@ -0,0 +1,409 @@ + SUBROUTINE TB01IZ( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the 1-norm of a system matrix +C +C S = ( A B ) +C ( C 0 ) +C +C corresponding to the triple (A,B,C), by balancing. This involves +C a diagonal similarity transformation inv(D)*A*D applied +C iteratively to A to make the rows and columns of +C -1 +C diag(D,I) * S * diag(D,I) +C +C as close in norm as possible. +C +C The balancing can be performed optionally on the following +C particular system matrices +C +C S = A, S = ( A B ) or S = ( A ) +C ( C ) +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Indicates which matrices are involved in balancing, as +C follows: +C = 'A': All matrices are involved in balancing; +C = 'B': B and A matrices are involved in balancing; +C = 'C': C and A matrices are involved in balancing; +C = 'N': B and C matrices are not involved in balancing. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A, the number of rows of matrix B +C and the number of columns of matrix C. +C N represents the dimension of the state vector. N >= 0. +C +C M (input) INTEGER. +C The number of columns of matrix B. +C M represents the dimension of input vector. M >= 0. +C +C P (input) INTEGER. +C The number of rows of matrix C. +C P represents the dimension of output vector. P >= 0. +C +C MAXRED (input/output) DOUBLE PRECISION +C On entry, the maximum allowed reduction in the 1-norm of +C S (in an iteration) if zero rows or columns are +C encountered. +C If MAXRED > 0.0, MAXRED must be larger than one (to enable +C the norm reduction). +C If MAXRED <= 0.0, then the value 10.0 for MAXRED is +C used. +C On exit, if the 1-norm of the given matrix S is non-zero, +C the ratio between the 1-norm of the given matrix and the +C 1-norm of the balanced matrix. +C +C A (input/output) COMPLEX*16 array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the system state matrix A. +C On exit, the leading N-by-N part of this array contains +C the balanced matrix inv(D)*A*D. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input/output) COMPLEX*16 array, dimension (LDB,M) +C On entry, if M > 0, the leading N-by-M part of this array +C must contain the system input matrix B. +C On exit, if M > 0, the leading N-by-M part of this array +C contains the balanced matrix inv(D)*B. +C The array B is not referenced if M = 0. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,N) if M > 0. +C LDB >= 1 if M = 0. +C +C C (input/output) COMPLEX*16 array, dimension (LDC,N) +C On entry, if P > 0, the leading P-by-N part of this array +C must contain the system output matrix C. +C On exit, if P > 0, the leading P-by-N part of this array +C contains the balanced matrix C*D. +C The array C is not referenced if P = 0. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,P). +C +C SCALE (output) DOUBLE PRECISION array, dimension (N) +C The scaling factors applied to S. If D(j) is the scaling +C factor applied to row and column j, then SCALE(j) = D(j), +C for j = 1,...,N. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Balancing consists of applying a diagonal similarity +C transformation +C -1 +C diag(D,I) * S * diag(D,I) +C +C to make the 1-norms of each row of the first N rows of S and its +C corresponding column nearly equal. +C +C Information about the diagonal matrix D is returned in the vector +C SCALE. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Balancing, eigenvalue, matrix algebra, matrix operations, +C similarity transformation. +C +C ********************************************************************* +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION SCLFAC + PARAMETER ( SCLFAC = 1.0D+1 ) + DOUBLE PRECISION FACTOR, MAXR + PARAMETER ( FACTOR = 0.95D+0, MAXR = 10.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, LDA, LDB, LDC, M, N, P + DOUBLE PRECISION MAXRED +C .. +C .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) + DOUBLE PRECISION SCALE( * ) +C .. +C .. Local Scalars .. + LOGICAL NOCONV, WITHB, WITHC + INTEGER I, ICA, IRA, J + DOUBLE PRECISION CA, CO, F, G, MAXNRM, RA, RO, S, SFMAX1, + $ SFMAX2, SFMIN1, SFMIN2, SNORM, SRED + COMPLEX*16 CDUM +C .. +C .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH, DZASUM + EXTERNAL DLAMCH, DZASUM, IZAMAX, LSAME +C .. +C .. External Subroutines .. + EXTERNAL XERBLA, ZDSCAL +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG, MAX, MIN +C .. +C .. Statement Functions .. + DOUBLE PRECISION CABS1 +C .. +C .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +C .. +C .. Executable Statements .. +C +C Test the scalar input arguments. +C + INFO = 0 + WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) + WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) +C + IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) + $ THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( MAXRED.GT.ZERO .AND. MAXRED.LT.ONE ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( ( M.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. + $ ( M.EQ.0 .AND. LDB.LT.1 ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TB01IZ', -INFO ) + RETURN + END IF +C + IF( N.EQ.0 ) + $ RETURN +C +C Compute the 1-norm of the required part of matrix S and exit if +C it is zero. +C + SNORM = ZERO +C + DO 10 J = 1, N + SCALE( J ) = ONE + CO = DZASUM( N, A( 1, J ), 1 ) + IF( WITHC .AND. P.GT.0 ) + $ CO = CO + DZASUM( P, C( 1, J ), 1 ) + SNORM = MAX( SNORM, CO ) + 10 CONTINUE +C + IF( WITHB ) THEN +C + DO 20 J = 1, M + SNORM = MAX( SNORM, DZASUM( N, B( 1, J ), 1 ) ) + 20 CONTINUE +C + END IF +C + IF( SNORM.EQ.ZERO ) + $ RETURN +C +C Set some machine parameters and the maximum reduction in the +C 1-norm of S if zero rows or columns are encountered. +C + SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) + SFMAX1 = ONE / SFMIN1 + SFMIN2 = SFMIN1*SCLFAC + SFMAX2 = ONE / SFMIN2 +C + SRED = MAXRED + IF( SRED.LE.ZERO ) SRED = MAXR +C + MAXNRM = MAX( SNORM/SRED, SFMIN1 ) +C +C Balance the matrix. +C +C Iterative loop for norm reduction. +C + 30 CONTINUE + NOCONV = .FALSE. +C + DO 90 I = 1, N + CO = ZERO + RO = ZERO +C + DO 40 J = 1, N + IF( J.EQ.I ) + $ GO TO 40 + CO = CO + CABS1( A( J, I ) ) + RO = RO + CABS1( A( I, J ) ) + 40 CONTINUE +C + ICA = IZAMAX( N, A( 1, I ), 1 ) + CA = ABS( A( ICA, I ) ) + IRA = IZAMAX( N, A( I, 1 ), LDA ) + RA = ABS( A( I, IRA ) ) +C + IF( WITHC .AND. P.GT.0 ) THEN + CO = CO + DZASUM( P, C( 1, I ), 1 ) + ICA = IZAMAX( P, C( 1, I ), 1 ) + CA = MAX( CA, ABS( C( ICA, I ) ) ) + END IF +C + IF( WITHB .AND. M.GT.0 ) THEN + RO = RO + DZASUM( M, B( I, 1 ), LDB ) + IRA = IZAMAX( M, B( I, 1 ), LDB ) + RA = MAX( RA, ABS( B( I, IRA ) ) ) + END IF +C +C Special case of zero CO and/or RO. +C + IF( CO.EQ.ZERO .AND. RO.EQ.ZERO ) + $ GO TO 90 + IF( CO.EQ.ZERO ) THEN + IF( RO.LE.MAXNRM ) + $ GO TO 90 + CO = MAXNRM + END IF + IF( RO.EQ.ZERO ) THEN + IF( CO.LE.MAXNRM ) + $ GO TO 90 + RO = MAXNRM + END IF +C +C Guard against zero CO or RO due to underflow. +C + G = RO / SCLFAC + F = ONE + S = CO + RO + 50 CONTINUE + IF( CO.GE.G .OR. MAX( F, CO, CA ).GE.SFMAX2 .OR. + $ MIN( RO, G, RA ).LE.SFMIN2 )GO TO 60 + F = F*SCLFAC + CO = CO*SCLFAC + CA = CA*SCLFAC + G = G / SCLFAC + RO = RO / SCLFAC + RA = RA / SCLFAC + GO TO 50 +C + 60 CONTINUE + G = CO / SCLFAC + 70 CONTINUE + IF( G.LT.RO .OR. MAX( RO, RA ).GE.SFMAX2 .OR. + $ MIN( F, CO, G, CA ).LE.SFMIN2 )GO TO 80 + F = F / SCLFAC + CO = CO / SCLFAC + CA = CA / SCLFAC + G = G / SCLFAC + RO = RO*SCLFAC + RA = RA*SCLFAC + GO TO 70 +C +C Now balance. +C + 80 CONTINUE + IF( ( CO+RO ).GE.FACTOR*S ) + $ GO TO 90 + IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN + IF( F*SCALE( I ).LE.SFMIN1 ) + $ GO TO 90 + END IF + IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN + IF( SCALE( I ).GE.SFMAX1 / F ) + $ GO TO 90 + END IF + G = ONE / F + SCALE( I ) = SCALE( I )*F + NOCONV = .TRUE. +C + CALL ZDSCAL( N, G, A( I, 1 ), LDA ) + CALL ZDSCAL( N, F, A( 1, I ), 1 ) + IF( M.GT.0 ) CALL ZDSCAL( M, G, B( I, 1 ), LDB ) + IF( P.GT.0 ) CALL ZDSCAL( P, F, C( 1, I ), 1 ) +C + 90 CONTINUE +C + IF( NOCONV ) + $ GO TO 30 +C +C Set the norm reduction parameter. +C + MAXRED = SNORM + SNORM = ZERO +C + DO 100 J = 1, N + CO = DZASUM( N, A( 1, J ), 1 ) + IF( WITHC .AND. P.GT.0 ) + $ CO = CO + DZASUM( P, C( 1, J ), 1 ) + SNORM = MAX( SNORM, CO ) + 100 CONTINUE +C + IF( WITHB ) THEN +C + DO 110 J = 1, M + SNORM = MAX( SNORM, DZASUM( N, B( 1, J ), 1 ) ) + 110 CONTINUE +C + END IF + MAXRED = MAXRED/SNORM + RETURN +C *** Last line of TB01IZ *** + END diff --git a/mex/sources/libslicot/TB01KD.f b/mex/sources/libslicot/TB01KD.f new file mode 100644 index 000000000..a3d0a85d2 --- /dev/null +++ b/mex/sources/libslicot/TB01KD.f @@ -0,0 +1,334 @@ + SUBROUTINE TB01KD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B, + $ LDB, C, LDC, NDIM, U, LDU, WR, WI, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute an additive spectral decomposition of the transfer- +C function matrix of the system (A,B,C) by reducing the system +C state-matrix A to a block-diagonal form. +C The system matrices are transformed as +C A <-- inv(U)*A*U, B <--inv(U)*B and C <-- C*U. +C The leading diagonal block of the resulting A has eigenvalues +C in a suitably defined domain of interest. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C STDOM CHARACTER*1 +C Specifies whether the domain of interest is of stability +C type (left part of complex plane or inside of a circle) +C or of instability type (right part of complex plane or +C outside of a circle) as follows: +C = 'S': stability type domain; +C = 'U': instability type domain. +C +C JOBA CHARACTER*1 +C Specifies the shape of the state dynamics matrix on entry +C as follows: +C = 'S': A is in an upper real Schur form; +C = 'G': A is a general square dense matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation, +C i.e. the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs, or of columns of B. M >= 0. +C +C P (input) INTEGER +C The number of system outputs, or of rows of C. P >= 0. +C +C ALPHA (input) DOUBLE PRECISION. +C Specifies the boundary of the domain of interest for the +C eigenvalues of A. For a continuous-time system +C (DICO = 'C'), ALPHA is the boundary value for the real +C parts of eigenvalues, while for a discrete-time system +C (DICO = 'D'), ALPHA >= 0 represents the boundary value for +C the moduli of eigenvalues. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the unreduced state dynamics matrix A. +C If JOBA = 'S' then A must be a matrix in real Schur form. +C On exit, the leading N-by-N part of this array contains a +C block diagonal matrix inv(U) * A * U with two diagonal +C blocks in real Schur form with the elements below the +C first subdiagonal set to zero. +C The leading NDIM-by-NDIM block of A has eigenvalues in the +C domain of interest and the trailing (N-NDIM)-by-(N-NDIM) +C block has eigenvalues outside the domain of interest. +C The domain of interest for lambda(A), the eigenvalues +C of A, is defined by the parameters ALPHA, DICO and STDOM +C as follows: +C For a continuous-time system (DICO = 'C'): +C Real(lambda(A)) < ALPHA if STDOM = 'S'; +C Real(lambda(A)) > ALPHA if STDOM = 'U'; +C For a discrete-time system (DICO = 'D'): +C Abs(lambda(A)) < ALPHA if STDOM = 'S'; +C Abs(lambda(A)) > ALPHA if STDOM = 'U'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed input matrix inv(U) * B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed output matrix C * U. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C NDIM (output) INTEGER +C The number of eigenvalues of A lying inside the domain of +C interest for eigenvalues. +C +C U (output) DOUBLE PRECISION array, dimension (LDU,N) +C The leading N-by-N part of this array contains the +C transformation matrix used to reduce A to the block- +C diagonal form. The first NDIM columns of U span the +C invariant subspace of A corresponding to the eigenvalues +C of its leading diagonal block. The last N-NDIM columns +C of U span the reducing subspace of A corresponding to +C the eigenvalues of the trailing diagonal block of A. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= max(1,N). +C +C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) +C WR and WI contain the real and imaginary parts, +C respectively, of the computed eigenvalues of A. The +C eigenvalues will be in the same order that they appear on +C the diagonal of the output real Schur form of A. Complex +C conjugate pairs of eigenvalues will appear consecutively +C with the eigenvalue having the positive imaginary part +C first. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LDWORK >= MAX(1,N) if JOBA = 'S'; +C LDWORK >= MAX(1,3*N) if JOBA = 'G'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the QR algorithm failed to compute all the +C eigenvalues of A; +C = 2: a failure occured during the ordering of the real +C Schur form of A; +C = 3: the separation of the two diagonal blocks failed +C because of very close eigenvalues. +C +C METHOD +C +C A similarity transformation U is determined that reduces the +C system state-matrix A to a block-diagonal form (with two diagonal +C blocks), so that the leading diagonal block of the resulting A has +C eigenvalues in a specified domain of the complex plane. The +C determined transformation is applied to the system (A,B,C) as +C A <-- inv(U)*A*U, B <-- inv(U)*B and C <-- C*U. +C +C REFERENCES +C +C [1] Safonov, M.G., Jonckheere, E.A., Verma, M., Limebeer, D.J.N. +C Synthesis of positive real multivariable feedback systems. +C Int. J. Control, pp. 817-842, 1987. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires about 14N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine SADSDC. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Invariant subspace, real Schur form, similarity transformation, +C spectral factorization. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBA, STDOM + INTEGER INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, NDIM, P + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*), + $ WI(*), WR(*) +C .. Local Scalars .. + LOGICAL DISCR, LJOBG + INTEGER NDIM1, NR + DOUBLE PRECISION SCALE +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DLASET, DTRSYL, TB01LD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable Statements .. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + LJOBG = LSAME( JOBA, 'G' ) +C +C Check input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( STDOM, 'S' ) .OR. + $ LSAME( STDOM, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( JOBA, 'S' ) .OR. LJOBG ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDWORK.LT.MAX( 1, N ) .OR. + $ LDWORK.LT.MAX( 1, 3*N ) .AND. LJOBG ) THEN + INFO = -20 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01KD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + NDIM = 0 + IF( N.EQ.0 ) + $ RETURN +C +C Reduce A to an ordered real Schur form using an orthogonal +C similarity transformation A <- U'*A*U and accumulate the +C transformations in U. The reordering of the real Schur form of A +C is performed in accordance with the values of the parameters DICO, +C STDOM and ALPHA. Apply the transformation to B and C: B <- U'*B +C and C <- C*U. The eigenvalues of A are computed in (WR,WI). +C +C Workspace: need 3*N (if JOBA = 'G'), or N (if JOBA = 'S'); +C prefer larger. +C + CALL TB01LD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B, LDB, C, + $ LDC, NDIM, U, LDU, WR, WI, DWORK, LDWORK, INFO ) +C + IF ( INFO.NE.0 ) + $ RETURN +C + IF ( NDIM.GT.0 .AND. NDIM.LT.N ) THEN +C +C Reduce A to a block-diagonal form by a similarity +C transformation of the form +C -1 ( I -X ) +C A <- T AT, where T = ( ) and X satisfies the +C ( 0 I ) +C Sylvester equation +C +C A11*X - X*A22 = A12. +C + NR = N - NDIM + NDIM1 = NDIM + 1 + CALL DTRSYL( 'N', 'N', -1, NDIM, NR, A, LDA, A(NDIM1,NDIM1), + $ LDA, A(1,NDIM1), LDA, SCALE, INFO ) + IF ( INFO.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C -1 +C Compute B <- T B, C <- CT, U <- UT. +C + SCALE = ONE/SCALE + CALL DGEMM( 'N', 'N', NDIM, M, NR, SCALE, A(1,NDIM1), LDA, + $ B(NDIM1,1), LDB, ONE, B, LDB ) + CALL DGEMM( 'N', 'N', P, NR, NDIM, -SCALE, C, LDC, A(1,NDIM1), + $ LDA, ONE, C(1,NDIM1), LDC ) + CALL DGEMM( 'N', 'N', N, NR, NDIM, -SCALE, U, LDU, A(1,NDIM1), + $ LDA, ONE, U(1,NDIM1), LDU ) +C +C Set A12 to zero. +C + CALL DLASET( 'Full', NDIM, NR, ZERO, ZERO, A(1,NDIM1), LDA ) + END IF +C +C Set to zero the lower triangular part under the first subdiagonal +C of A. +C + IF ( N.GT.2 ) + $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A( 3, 1 ), LDA ) + RETURN +C *** Last line of TB01KD *** + END diff --git a/mex/sources/libslicot/TB01LD.f b/mex/sources/libslicot/TB01LD.f new file mode 100644 index 000000000..50f64c914 --- /dev/null +++ b/mex/sources/libslicot/TB01LD.f @@ -0,0 +1,348 @@ + SUBROUTINE TB01LD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B, + $ LDB, C, LDC, NDIM, U, LDU, WR, WI, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the system state matrix A to an ordered upper real +C Schur form by using an orthogonal similarity transformation +C A <-- U'*A*U and to apply the transformation to the matrices +C B and C: B <-- U'*B and C <-- C*U. +C The leading block of the resulting A has eigenvalues in a +C suitably defined domain of interest. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C STDOM CHARACTER*1 +C Specifies whether the domain of interest is of stability +C type (left part of complex plane or inside of a circle) +C or of instability type (right part of complex plane or +C outside of a circle) as follows: +C = 'S': stability type domain; +C = 'U': instability type domain. +C +C JOBA CHARACTER*1 +C Specifies the shape of the state dynamics matrix on entry +C as follows: +C = 'S': A is in an upper real Schur form; +C = 'G': A is a general square dense matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation, +C i.e. the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs, or of columns of B. M >= 0. +C +C P (input) INTEGER +C The number of system outputs, or of rows of C. P >= 0. +C +C ALPHA (input) DOUBLE PRECISION. +C Specifies the boundary of the domain of interest for the +C eigenvalues of A. For a continuous-time system +C (DICO = 'C'), ALPHA is the boundary value for the real +C parts of eigenvalues, while for a discrete-time system +C (DICO = 'D'), ALPHA >= 0 represents the boundary value +C for the moduli of eigenvalues. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the unreduced state dynamics matrix A. +C If JOBA = 'S' then A must be a matrix in real Schur form. +C On exit, the leading N-by-N part of this array contains +C the ordered real Schur matrix U' * A * U with the elements +C below the first subdiagonal set to zero. +C The leading NDIM-by-NDIM part of A has eigenvalues in the +C domain of interest and the trailing (N-NDIM)-by-(N-NDIM) +C part has eigenvalues outside the domain of interest. +C The domain of interest for lambda(A), the eigenvalues +C of A, is defined by the parameters ALPHA, DICO and STDOM +C as follows: +C For a continuous-time system (DICO = 'C'): +C Real(lambda(A)) < ALPHA if STDOM = 'S'; +C Real(lambda(A)) > ALPHA if STDOM = 'U'; +C For a discrete-time system (DICO = 'D'): +C Abs(lambda(A)) < ALPHA if STDOM = 'S'; +C Abs(lambda(A)) > ALPHA if STDOM = 'U'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed input matrix U' * B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed output matrix C * U. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C NDIM (output) INTEGER +C The number of eigenvalues of A lying inside the domain of +C interest for eigenvalues. +C +C U (output) DOUBLE PRECISION array, dimension (LDU,N) +C The leading N-by-N part of this array contains the +C orthogonal transformation matrix used to reduce A to the +C real Schur form and/or to reorder the diagonal blocks of +C real Schur form of A. The first NDIM columns of U form +C an orthogonal basis for the invariant subspace of A +C corresponding to the first NDIM eigenvalues. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= max(1,N). +C +C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) +C WR and WI contain the real and imaginary parts, +C respectively, of the computed eigenvalues of A. The +C eigenvalues will be in the same order that they appear on +C the diagonal of the output real Schur form of A. Complex +C conjugate pairs of eigenvalues will appear consecutively +C with the eigenvalue having the positive imaginary part +C first. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LDWORK >= MAX(1,N) if JOBA = 'S'; +C LDWORK >= MAX(1,3*N) if JOBA = 'G'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the QR algorithm failed to compute all the +C eigenvalues of A; +C = 2: a failure occured during the ordering of the real +C Schur form of A. +C +C METHOD +C +C Matrix A is reduced to an ordered upper real Schur form using an +C orthogonal similarity transformation A <-- U'*A*U. This +C transformation is determined so that the leading block of the +C resulting A has eigenvalues in a suitably defined domain of +C interest. Then, the transformation is applied to the matrices B +C and C: B <-- U'*B and C <-- C*U. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires about 14N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine SRSFOD. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001. +C +C KEYWORDS +C +C Invariant subspace, orthogonal transformation, real Schur form, +C similarity transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBA, STDOM + INTEGER INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, NDIM, P + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*), + $ WI(*), WR(*) +C .. Local Scalars .. + LOGICAL DISCR, LJOBG + INTEGER I, IERR, LDWP, SDIM + DOUBLE PRECISION WRKOPT +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. External Functions .. + LOGICAL LSAME, SELECT + EXTERNAL LSAME, SELECT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DLACPY, DLASET, + $ MB03QD, MB03QX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + LJOBG = LSAME( JOBA, 'G' ) +C +C Check input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( STDOM, 'S' ) .OR. + $ LSAME( STDOM, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( JOBA, 'S' ) .OR. LJOBG ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDWORK.LT.MAX( 1, N ) .OR. + $ LDWORK.LT.MAX( 1, 3*N ) .AND. LJOBG ) THEN + INFO = -20 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01LD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + NDIM = 0 + IF( N.EQ.0 ) + $ RETURN +C + IF( LSAME( JOBA, 'G' ) ) THEN +C +C Reduce A to real Schur form using an orthogonal similarity +C transformation A <- U'*A*U, accumulate the transformation in U +C and compute the eigenvalues of A in (WR,WI). +C +C Workspace: need 3*N; +C prefer larger. +C + CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + WRKOPT = DWORK( 1 ) + IF( INFO.NE.0 ) THEN + INFO = 1 + RETURN + END IF + ELSE +C +C Initialize U with an identity matrix. +C + CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) + WRKOPT = 0 + END IF +C +C Separate the spectrum of A. The leading NDIM-by-NDIM submatrix of +C A corresponds to the eigenvalues of interest. +C Workspace: need N. +C + CALL MB03QD( DICO, STDOM, 'Update', N, 1, N, ALPHA, A, LDA, + $ U, LDU, NDIM, DWORK, INFO ) + IF( INFO.NE.0 ) + $ RETURN +C +C Compute the eigenvalues. +C + CALL MB03QX( N, A, LDA, WR, WI, IERR ) +C +C Apply the transformation: B <-- U'*B. +C + IF( LDWORK.LT.N*M ) THEN +C +C Not enough working space for using DGEMM. +C + DO 10 I = 1, M + CALL DCOPY( N, B(1,I), 1, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, + $ B(1,I), 1 ) + 10 CONTINUE +C + ELSE + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, U, LDU, + $ DWORK, N, ZERO, B, LDB ) + WRKOPT = MAX( WRKOPT, DBLE( N*M ) ) + END IF +C +C Apply the transformation: C <-- C*U. +C + IF( LDWORK.LT.N*P ) THEN +C +C Not enough working space for using DGEMM. +C + DO 20 I = 1, P + CALL DCOPY( N, C(I,1), LDC, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, + $ C(I,1), LDC ) + 20 CONTINUE +C + ELSE + LDWP = MAX( 1, P ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDWP ) + CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, + $ DWORK, LDWP, U, LDU, ZERO, C, LDC ) + WRKOPT = MAX( WRKOPT, DBLE( N*P ) ) + END IF +C + DWORK( 1 ) = WRKOPT +C + RETURN +C *** Last line of TB01LD *** + END diff --git a/mex/sources/libslicot/TB01MD.f b/mex/sources/libslicot/TB01MD.f new file mode 100644 index 000000000..b63aacee0 --- /dev/null +++ b/mex/sources/libslicot/TB01MD.f @@ -0,0 +1,338 @@ + SUBROUTINE TB01MD( JOBU, UPLO, N, M, A, LDA, B, LDB, U, LDU, + $ DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the pair (B,A) to upper or lower controller Hessenberg +C form using (and optionally accumulating) unitary state-space +C transformations. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBU CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix U the unitary state-space transformations for +C reducing the system, as follows: +C = 'N': Do not form U; +C = 'I': U is initialized to the unit matrix and the +C unitary transformation matrix U is returned; +C = 'U': The given matrix U is updated by the unitary +C transformations used in the reduction. +C +C UPLO CHARACTER*1 +C Indicates whether the user wishes the pair (B,A) to be +C reduced to upper or lower controller Hessenberg form as +C follows: +C = 'U': Upper controller Hessenberg form; +C = 'L': Lower controller Hessenberg form. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e. the order of the +C matrix A. N >= 0. +C +C M (input) INTEGER +C The actual input dimension, i.e. the number of columns of +C the matrix B. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state transition matrix A to be transformed. +C On exit, the leading N-by-N part of this array contains +C the transformed state transition matrix U' * A * U. +C The annihilated elements are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B to be transformed. +C On exit, the leading N-by-M part of this array contains +C the transformed input matrix U' * B. +C The annihilated elements are set to zero. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) +C On entry, if JOBU = 'U', then the leading N-by-N part of +C this array must contain a given matrix U (e.g. from a +C previous call to another SLICOT routine), and on exit, the +C leading N-by-N part of this array contains the product of +C the input matrix U and the state-space transformation +C matrix which reduces the given pair to controller +C Hessenberg form. +C On exit, if JOBU = 'I', then the leading N-by-N part of +C this array contains the matrix of accumulated unitary +C similarity transformations which reduces the given pair +C to controller Hessenberg form. +C If JOBU = 'N', the array U is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDU = 1 and +C declare this array to be U(1,1) in the calling program). +C +C LDU INTEGER +C The leading dimension of array U. If JOBU = 'U' or +C JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (MAX(N,M-1)) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a unitary state-space transformation U, which +C reduces the pair (B,A) to one of the following controller +C Hessenberg forms: +C +C |* . . . *|* . . . . . . *| +C | . .|. .| +C | . .|. .| +C | . .|. .| +C [U'B|U'AU] = | *|. .| N +C | |* .| +C | | . .| +C | | . .| +C | | . .| +C | | * . . *| +C M N +C +C if UPLO = 'U', or +C +C |* . . * | | +C |. . | | +C |. . | | +C |. . | | +C [U'AU|U'B] = |. *| | N +C |. .|* | +C |. .|. . | +C |. .|. . | +C |. .|. . | +C |* . . . . . . *|* . . . *| +C N M +C if UPLO = 'L'. +C +C IF M >= N, then the matrix U'B is trapezoidal and U'AU is full. +C +C REFERENCES +C +C [1] Van Dooren, P. and Verhaegen, M.H.G. +C On the use of unitary state-space transformations. +C In : Contemporary Mathematics on Linear Algebra and its Role +C in Systems Theory, 47, AMS, Providence, 1985. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O((N + M) x N**2) operations and is +C backward stable (see [1]). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TB01AD by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C February 1997. +C +C KEYWORDS +C +C Controllability, controller Hessenberg form, orthogonal +C transformation, unitary transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBU, UPLO + INTEGER INFO, LDA, LDB, LDU, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), U(LDU,*) +C .. Local Scalars .. + LOGICAL LJOBA, LJOBI, LUPLO + INTEGER II, J, M1, N1, NJ, PAR1, PAR2, PAR3, PAR4, PAR5, + $ PAR6 + DOUBLE PRECISION DZ +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARFG, DLASET, DLATZM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LUPLO = LSAME( UPLO, 'U' ) + LJOBI = LSAME( JOBU, 'I' ) + LJOBA = LJOBI.OR.LSAME( JOBU, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBA .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( .NOT.LJOBA .AND. LDU.LT.1 .OR. + $ LJOBA .AND. LDU.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return +C + CALL XERBLA( 'TB01MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + M1 = M + 1 + N1 = N - 1 +C + IF ( LJOBI ) THEN +C +C Initialize U to the identity matrix. +C + CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) + END IF +C +C Perform transformations involving both B and A. +C + DO 20 J = 1, MIN( M, N1 ) + NJ = N - J + IF ( LUPLO ) THEN + PAR1 = J + PAR2 = J + PAR3 = J + 1 + PAR4 = M + PAR5 = N + ELSE + PAR1 = M - J + 1 + PAR2 = NJ + 1 + PAR3 = 1 + PAR4 = M - J + PAR5 = NJ + END IF +C + CALL DLARFG( NJ+1, B(PAR2,PAR1), B(PAR3,PAR1), 1, DZ ) +C +C Update A. +C + CALL DLATZM( 'Left', NJ+1, N, B(PAR3,PAR1), 1, DZ, A(PAR2,1), + $ A(PAR3,1), LDA, DWORK ) + CALL DLATZM( 'Right', N, NJ+1, B(PAR3,PAR1), 1, DZ, A(1,PAR2), + $ A(1,PAR3), LDA, DWORK ) +C + IF ( LJOBA ) THEN +C +C Update U. +C + CALL DLATZM( 'Right', N, NJ+1, B(PAR3,PAR1), 1, DZ, + $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) + END IF +C + IF ( J.NE.M ) THEN +C +C Update B +C + CALL DLATZM( 'Left', NJ+1, PAR4-PAR3+1, B(PAR3,PAR1), 1, DZ, + $ B(PAR2,PAR3), B(PAR3,PAR3), LDB, DWORK ) + END IF +C + DO 10 II = PAR3, PAR5 + B(II,PAR1) = ZERO + 10 CONTINUE +C + 20 CONTINUE +C + DO 40 J = M1, N1 +C +C Perform next transformations only involving A. +C + NJ = N - J + IF ( LUPLO ) THEN + PAR1 = J - M + PAR2 = J + PAR3 = J + 1 + PAR4 = N + PAR5 = J - M + 1 + PAR6 = N + ELSE + PAR1 = N + M1 - J + PAR2 = NJ + 1 + PAR3 = 1 + PAR4 = NJ + PAR5 = 1 + PAR6 = N + M - J + END IF +C + CALL DLARFG( NJ+1, A(PAR2,PAR1), A(PAR3,PAR1), 1, DZ ) +C +C Update A. +C + CALL DLATZM( 'Left', NJ+1, PAR6-PAR5+1, A(PAR3,PAR1), 1, DZ, + $ A(PAR2,PAR5), A(PAR3,PAR5), LDA, DWORK ) + CALL DLATZM( 'Right', N, NJ+1, A(PAR3,PAR1), 1, DZ, + $ A(1,PAR2), A(1,PAR3), LDA, DWORK ) +C + IF ( LJOBA ) THEN +C +C Update U. +C + CALL DLATZM( 'Right', N, NJ+1, A(PAR3,PAR1), 1, DZ, + $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) + END IF +C + DO 30 II = PAR3, PAR4 + A(II,PAR1) = ZERO + 30 CONTINUE +C + 40 CONTINUE +C + RETURN +C *** Last line of TB01MD *** + END diff --git a/mex/sources/libslicot/TB01ND.f b/mex/sources/libslicot/TB01ND.f new file mode 100644 index 000000000..cc93dd3ac --- /dev/null +++ b/mex/sources/libslicot/TB01ND.f @@ -0,0 +1,349 @@ + SUBROUTINE TB01ND( JOBU, UPLO, N, P, A, LDA, C, LDC, U, LDU, + $ DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the pair (A,C) to lower or upper observer Hessenberg +C form using (and optionally accumulating) unitary state-space +C transformations. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBU CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix U the unitary state-space transformations for +C reducing the system, as follows: +C = 'N': Do not form U; +C = 'I': U is initialized to the unit matrix and the +C unitary transformation matrix U is returned; +C = 'U': The given matrix U is updated by the unitary +C transformations used in the reduction. +C +C UPLO CHARACTER*1 +C Indicates whether the user wishes the pair (A,C) to be +C reduced to upper or lower observer Hessenberg form as +C follows: +C = 'U': Upper observer Hessenberg form; +C = 'L': Lower observer Hessenberg form. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e. the order of the +C matrix A. N >= 0. +C +C P (input) INTEGER +C The actual output dimension, i.e. the number of rows of +C the matrix C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state transition matrix A to be transformed. +C On exit, the leading N-by-N part of this array contains +C the transformed state transition matrix U' * A * U. +C The annihilated elements are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C to be transformed. +C On exit, the leading P-by-N part of this array contains +C the transformed output matrix C * U. +C The annihilated elements are set to zero. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) +C On entry, if JOBU = 'U', then the leading N-by-N part of +C this array must contain a given matrix U (e.g. from a +C previous call to another SLICOT routine), and on exit, the +C leading N-by-N part of this array contains the product of +C the input matrix U and the state-space transformation +C matrix which reduces the given pair to observer Hessenberg +C form. +C On exit, if JOBU = 'I', then the leading N-by-N part of +C this array contains the matrix of accumulated unitary +C similarity transformations which reduces the given pair +C to observer Hessenberg form. +C If JOBU = 'N', the array U is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDU = 1 and +C declare this array to be U(1,1) in the calling program). +C +C LDU INTEGER +C The leading dimension of array U. If JOBU = 'U' or +C JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (MAX(N,P-1)) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a unitary state-space transformation U, which +C reduces the pair (A,C) to one of the following observer Hessenberg +C forms: +C +C N +C |* . . . . . . *| +C |. .| +C |. .| +C |. .| N +C |* .| +C |U'AU| | . .| +C |----| = | . .| +C |CU | | * . . . *| +C ------------------- +C | * . . *| +C | . .| P +C | . .| +C | *| +C +C if UPLO = 'U', or +C +C N +C |* | +C |. . | +C |. . | P +C |* . . * | +C |CU | ------------------- +C |----| = |* . . . * | +C |U'AU| |. . | +C |. . | +C |. *| +C |. .| N +C |. .| +C |. .| +C |* . . . . . . *| +C +C if UPLO = 'L'. +C +C If P >= N, then the matrix CU is trapezoidal and U'AU is full. +C +C REFERENCES +C +C [1] Van Dooren, P. and Verhaegen, M.H.G. +C On the use of unitary state-space transformations. +C In : Contemporary Mathematics on Linear Algebra and its Role +C in Systems Theory, 47, AMS, Providence, 1985. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O((N + P) x N**2) operations and is +C backward stable (see [1]). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TB01BD by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C February 1997. +C +C KEYWORDS +C +C Controllability, observer Hessenberg form, orthogonal +C transformation, unitary transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDC, LDU, N, P + CHARACTER JOBU, UPLO +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), C(LDC,*), DWORK(*), U(LDU,*) +C .. Local Scalars .. + LOGICAL LJOBA, LJOBI, LUPLO + INTEGER II, J, N1, NJ, P1, PAR1, PAR2, PAR3, PAR4, PAR5, + $ PAR6 + DOUBLE PRECISION DZ +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARFG, DLASET, DLATZM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LUPLO = LSAME( UPLO, 'U' ) + LJOBI = LSAME( JOBU, 'I' ) + LJOBA = LJOBI.OR.LSAME( JOBU, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBA .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -8 + ELSE IF( .NOT.LJOBA .AND. LDU.LT.1 .OR. + $ LJOBA .AND. LDU.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return +C + CALL XERBLA( 'TB01ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. P.EQ.0 ) + $ RETURN +C + P1 = P + 1 + N1 = N - 1 +C + IF ( LJOBI ) THEN +C +C Initialize U to the identity matrix. +C + CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) + END IF +C +C Perform transformations involving both C and A. +C + DO 20 J = 1, MIN( P, N1 ) + NJ = N - J + IF ( LUPLO ) THEN + PAR1 = P - J + 1 + PAR2 = NJ + 1 + PAR3 = 1 + PAR4 = P - J + PAR5 = NJ + ELSE + PAR1 = J + PAR2 = J + PAR3 = J + 1 + PAR4 = P + PAR5 = N + END IF +C + CALL DLARFG( NJ+1, C(PAR1,PAR2), C(PAR1,PAR3), LDC, DZ ) +C +C Update A. +C + CALL DLATZM( 'Left', NJ+1, N, C(PAR1,PAR3), LDC, DZ, A(PAR2,1), + $ A(PAR3,1), LDA, DWORK ) + CALL DLATZM( 'Right', N, NJ+1, C(PAR1,PAR3), LDC, DZ, + $ A(1,PAR2), A(1,PAR3), LDA, DWORK ) +C + IF ( LJOBA ) THEN +C +C Update U. +C + CALL DLATZM( 'Right', N, NJ+1, C(PAR1,PAR3), LDC, DZ, + $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) + END IF +C + IF ( J.NE.P ) THEN +C +C Update C. +C + CALL DLATZM( 'Right', PAR4-PAR3+1, NJ+1, C(PAR1,PAR3), LDC, + $ DZ, C(PAR3,PAR2), C(PAR3,PAR3), LDC, DWORK ) + END IF +C + DO 10 II = PAR3, PAR5 + C(PAR1,II) = ZERO + 10 CONTINUE +C + 20 CONTINUE +C + DO 40 J = P1, N1 +C +C Perform next transformations only involving A. +C + NJ = N - J + IF ( LUPLO ) THEN + PAR1 = N + P1 - J + PAR2 = NJ + 1 + PAR3 = 1 + PAR4 = NJ + PAR5 = 1 + PAR6 = N + P - J + ELSE + PAR1 = J - P + PAR2 = J + PAR3 = J + 1 + PAR4 = N + PAR5 = J - P + 1 + PAR6 = N + END IF +C + IF ( NJ.GT.0 ) THEN +C + CALL DLARFG( NJ+1, A(PAR1,PAR2), A(PAR1,PAR3), LDA, DZ ) +C +C Update A. +C + CALL DLATZM( 'Left', NJ+1, N, A(PAR1,PAR3), LDA, DZ, + $ A(PAR2,1), A(PAR3,1), LDA, DWORK ) + CALL DLATZM( 'Right', PAR6-PAR5+1, NJ+1, A(PAR1,PAR3), LDA, + $ DZ, A(PAR5,PAR2), A(PAR5,PAR3), LDA, DWORK ) +C + IF ( LJOBA ) THEN +C +C Update U. +C + CALL DLATZM( 'Right', N, NJ+1, A(PAR1,PAR3), LDA, DZ, + $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) + END IF +C + DO 30 II = PAR3, PAR4 + A(PAR1,II) = ZERO + 30 CONTINUE +C + END IF +C + 40 CONTINUE +C + RETURN +C *** Last line of TB01ND *** + END diff --git a/mex/sources/libslicot/TB01PD.f b/mex/sources/libslicot/TB01PD.f new file mode 100644 index 000000000..c1c9594bd --- /dev/null +++ b/mex/sources/libslicot/TB01PD.f @@ -0,0 +1,352 @@ + SUBROUTINE TB01PD( JOB, EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, + $ NR, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a reduced (controllable, observable, or minimal) state- +C space representation (Ar,Br,Cr) for any original state-space +C representation (A,B,C). The matrix Ar is in upper block +C Hessenberg form. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Indicates whether the user wishes to remove the +C uncontrollable and/or unobservable parts as follows: +C = 'M': Remove both the uncontrollable and unobservable +C parts to get a minimal state-space representation; +C = 'C': Remove the uncontrollable part only to get a +C controllable state-space representation; +C = 'O': Remove the unobservable part only to get an +C observable state-space representation. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily balance +C the triplet (A,B,C) as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading NR-by-NR part of this array contains +C the upper block Hessenberg state dynamics matrix Ar of a +C minimal, controllable, or observable realization for the +C original system, depending on the value of JOB, JOB = 'M', +C JOB = 'C', or JOB = 'O', respectively. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M), +C if JOB = 'C', or (LDB,MAX(M,P)), otherwise. +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B; if JOB = 'M', +C or JOB = 'O', the remainder of the leading N-by-MAX(M,P) +C part is used as internal workspace. +C On exit, the leading NR-by-M part of this array contains +C the transformed input/state matrix Br of a minimal, +C controllable, or observable realization for the original +C system, depending on the value of JOB, JOB = 'M', +C JOB = 'C', or JOB = 'O', respectively. +C If JOB = 'C', only the first IWORK(1) rows of B are +C nonzero. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C; if JOB = 'M', +C or JOB = 'O', the remainder of the leading MAX(M,P)-by-N +C part is used as internal workspace. +C On exit, the leading P-by-NR part of this array contains +C the transformed state/output matrix Cr of a minimal, +C controllable, or observable realization for the original +C system, depending on the value of JOB, JOB = 'M', +C JOB = 'C', or JOB = 'O', respectively. +C If JOB = 'M', or JOB = 'O', only the last IWORK(1) columns +C (in the first NR columns) of C are nonzero. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,M,P) if N > 0. +C LDC >= 1 if N = 0. +C +C NR (output) INTEGER +C The order of the reduced state-space representation +C (Ar,Br,Cr) of a minimal, controllable, or observable +C realization for the original system, depending on +C JOB = 'M', JOB = 'C', or JOB = 'O'. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determination when +C transforming (A, B, C). If the user sets TOL > 0, then +C the given value of TOL is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance +C (determined by the SLICOT routine TB01UD) is used instead. +C +C Workspace +C +C IWORK INTEGER array, dimension (N+MAX(M,P)) +C On exit, if INFO = 0, the first nonzero elements of +C IWORK(1:N) return the orders of the diagonal blocks of A. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P)). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C If JOB = 'M', the matrices A and B are operated on by orthogonal +C similarity transformations (made up of products of Householder +C transformations) so as to produce an upper block Hessenberg matrix +C A1 and a matrix B1 with all but its first rank(B) rows zero; this +C separates out the controllable part of the original system. +C Applying the same algorithm to the dual of this subsystem, +C therefore separates out the controllable and observable (i.e. +C minimal) part of the original system representation, with the +C final Ar upper block Hessenberg (after using pertransposition). +C If JOB = 'C', or JOB = 'O', only the corresponding part of the +C above procedure is applied. +C +C REFERENCES +C +C [1] Van Dooren, P. +C The Generalized Eigenstructure Problem in Linear System +C Theory. (Algorithm 1) +C IEEE Trans. Auto. Contr., AC-26, pp. 111-129, 1981. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C +C REVISIONS +C +C A. Varga, DLR Oberpfaffenhofen, July 1998. +C A. Varga, DLR Oberpfaffenhofen, April 28, 1999. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Hessenberg form, minimal realization, multivariable system, +C orthogonal transformation, state-space model, state-space +C representation. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER LDIZ + PARAMETER ( LDIZ = 1 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL, JOB + INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) +C .. Local Scalars .. + LOGICAL LEQUIL, LNJOBC, LNJOBO + INTEGER I, INDCON, ITAU, IZ, JWORK, KL, MAXMP, NCONT, + $ WRKOPT + DOUBLE PRECISION MAXRED +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB07MD, TB01ID, TB01UD, TB01XD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + MAXMP = MAX( M, P ) + LNJOBC = .NOT.LSAME( JOB, 'C' ) + LNJOBO = .NOT.LSAME( JOB, 'O' ) + LEQUIL = LSAME( EQUIL, 'S' ) +C +C Test the input scalar arguments. +C + IF( LNJOBC .AND. LNJOBO .AND. .NOT.LSAME( JOB, 'M' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*MAXMP ) ) ) THEN + INFO = -16 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. ( LNJOBC .AND. MIN( N, P ).EQ.0 ) .OR. + $ ( LNJOBO .AND. MIN( N, M ).EQ.0 ) ) THEN + NR = 0 +C + DO 5 I = 1, N + IWORK(I) = 0 + 5 CONTINUE +C + DWORK(1) = ONE + RETURN + END IF +C +C If required, balance the triplet (A,B,C) (default MAXRED). +C Workspace: need N. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the code, +C as well as the preferred amount for good performance.) +C + IF ( LEQUIL ) THEN + MAXRED = ZERO + CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + WRKOPT = N + ELSE + WRKOPT = 1 + END IF +C + IZ = 1 + ITAU = 1 + JWORK = ITAU + N + IF ( LNJOBO ) THEN +C +C Separate out controllable subsystem (of order NCONT): +C A <-- Z'*A*Z, B <-- Z'*B, C <-- C*Z. +C +C Workspace: need N + MAX(N, 3*M, P). +C prefer larger. +C + CALL TB01UD( 'No Z', N, M, P, A, LDA, B, LDB, C, LDC, NCONT, + $ INDCON, IWORK, DWORK(IZ), LDIZ, DWORK(ITAU), TOL, + $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 + ELSE + NCONT = N + END IF +C + IF ( LNJOBC ) THEN +C +C Separate out the observable subsystem (of order NR): +C Form the dual of the subsystem of order NCONT (which is +C controllable, if JOB = 'M'), leaving rest as it is. +C + CALL AB07MD( 'Z', NCONT, M, P, A, LDA, B, LDB, C, LDC, DWORK, + $ 1, INFO ) +C +C And separate out the controllable part of this dual subsystem. +C +C Workspace: need NCONT + MAX(NCONT, 3*P, M). +C prefer larger. +C + CALL TB01UD( 'No Z', NCONT, P, M, A, LDA, B, LDB, C, LDC, NR, + $ INDCON, IWORK, DWORK(IZ), LDIZ, DWORK(ITAU), TOL, + $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Transpose and reorder (to get a block upper Hessenberg +C matrix A), giving, for JOB = 'M', the controllable and +C observable (i.e., minimal) part of original system. +C + IF( INDCON.GT.0 ) THEN + KL = IWORK(1) - 1 + IF ( INDCON.GE.2 ) + $ KL = KL + IWORK(2) + ELSE + KL = 0 + END IF + CALL TB01XD( 'Zero D', NR, P, M, KL, MAX( 0, NR-1 ), A, LDA, + $ B, LDB, C, LDC, DWORK, 1, INFO ) + ELSE + NR = NCONT + END IF +C +C Annihilate the trailing components of IWORK(1:N). +C + DO 10 I = INDCON + 1, N + IWORK(I) = 0 + 10 CONTINUE +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of TB01PD *** + END diff --git a/mex/sources/libslicot/TB01TD.f b/mex/sources/libslicot/TB01TD.f new file mode 100644 index 000000000..7c52957ad --- /dev/null +++ b/mex/sources/libslicot/TB01TD.f @@ -0,0 +1,308 @@ + SUBROUTINE TB01TD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, LOW, + $ IGH, SCSTAT, SCIN, SCOUT, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce a given state-space representation (A,B,C,D) to +C balanced form by means of state permutations and state, input and +C output scalings. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation, i.e. the +C order of the original state dynamics matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading N-by-N part of this array contains +C the balanced state dynamics matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, the leading N-by-M part of this array contains +C the balanced input/state matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, the leading P-by-N part of this array contains +C the balanced state/output matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original direct transmission matrix D. +C On exit, the leading P-by-M part of this array contains +C the scaled direct transmission matrix D. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C LOW (output) INTEGER +C The index of the lower end of the balanced submatrix of A. +C +C IGH (output) INTEGER +C The index of the upper end of the balanced submatrix of A. +C +C SCSTAT (output) DOUBLE PRECISION array, dimension (N) +C This array contains the information defining the +C similarity transformations used to permute and balance +C the state dynamics matrix A, as returned from the LAPACK +C library routine DGEBAL. +C +C SCIN (output) DOUBLE PRECISION array, dimension (M) +C Contains the scalars used to scale the system inputs so +C that the columns of the final matrix B have norms roughly +C equal to the column sums of the balanced matrix A +C (see FURTHER COMMENTS). +C The j-th input of the balanced state-space representation +C is SCIN(j)*(j-th column of the permuted and balanced +C input/state matrix B). +C +C SCOUT (output) DOUBLE PRECISION array, dimension (P) +C Contains the scalars used to scale the system outputs so +C that the rows of the final matrix C have norms roughly +C equal to the row sum of the balanced matrix A. +C The i-th output of the balanced state-space representation +C is SCOUT(i)*(i-th row of the permuted and balanced +C state/ouput matrix C). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Similarity transformations are used to permute the system states +C and balance the corresponding row and column sum norms of a +C submatrix of the state dynamics matrix A. These operations are +C also applied to the input/state matrix B and the system inputs +C are then scaled (see parameter SCIN) so that the columns of the +C final matrix B have norms roughly equal to the column sum norm of +C the balanced matrix A (see FURTHER COMMENTS). +C The above operations are also applied to the matrix C, and the +C system outputs are then scaled (see parameter SCOUT) so that the +C rows of the final matrix C have norms roughly equal to the row sum +C norm of the balanced matrix A (see FURTHER COMMENTS). +C Finally, the (I,J)-th element of the direct transmission matrix D +C is scaled as +C D(I,J) = D(I,J)*(1.0/SCIN(J))*SCOUT(I), where I = 1,2,...,P +C and J = 1,2,...,M. +C +C Scaling performed to balance the row/column sum norms is by +C integer powers of the machine base so as to avoid introducing +C rounding errors. +C +C REFERENCES +C +C [1] Wilkinson, J.H. and Reinsch, C. +C Handbook for Automatic Computation, (Vol II, Linear Algebra). +C Springer-Verlag, 1971, (contribution II/11). +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C The columns (rows) of the final matrix B (matrix C) have norms +C 'roughly' equal to the column (row) sum norm of the balanced +C matrix A, i.e. +C size/BASE < abssum <= size +C where +C BASE = the base of the arithmetic used on the computer, which +C can be obtained from the LAPACK Library routine +C DLAMCH; +C +C size = column or row sum norm of the balanced matrix A; +C abssum = column sum norm of the balanced matrix B or row sum +C norm of the balanced matrix C. +C +C The routine is BASE dependent. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TB01HD by T.W.C.Williams, Kingston +C Polytechnic, United Kingdom, October 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Balanced form, orthogonal transformation, similarity +C transformation, state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER IGH, INFO, LDA, LDB, LDC, LDD, LOW, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), SCIN(*), SCOUT(*), SCSTAT(*) +C .. Local Scalars .. + INTEGER I, J, K, KNEW, KOLD + DOUBLE PRECISION ACNORM, ARNORM, SCALE +C .. External Functions .. + DOUBLE PRECISION DLANGE + EXTERNAL DLANGE +C .. External Subroutines .. + EXTERNAL DGEBAL, DSCAL, DSWAP, TB01TY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -11 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01TD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, M, P ).EQ.0 ) THEN + LOW = 1 + IGH = N + RETURN + END IF +C +C Permute states, and balance a submatrix of A. +C + CALL DGEBAL( 'Both', N, A, LDA, LOW, IGH, SCSTAT, INFO ) +C +C Use the information in SCSTAT on state scalings and reorderings +C to transform B and C. +C + DO 10 K = 1, N + KOLD = K + IF ( ( LOW.GT.KOLD ) .OR. ( KOLD.GT.IGH ) ) THEN + IF ( KOLD.LT.LOW ) KOLD = LOW - KOLD + KNEW = INT( SCSTAT(KOLD) ) + IF ( KNEW.NE.KOLD ) THEN +C +C Exchange rows KOLD and KNEW of B. +C + CALL DSWAP( M, B(KOLD,1), LDB, B(KNEW,1), LDB ) +C +C Exchange columns KOLD and KNEW of C. +C + CALL DSWAP( P, C(1,KOLD), 1, C(1,KNEW), 1 ) + END IF + END IF + 10 CONTINUE +C + IF ( IGH.NE.LOW ) THEN +C + DO 20 K = LOW, IGH + SCALE = SCSTAT(K) +C +C Scale the K-th row of permuted B. +C + CALL DSCAL( M, ONE/SCALE, B(K,1), LDB ) +C +C Scale the K-th column of permuted C. +C + CALL DSCAL( P, SCALE, C(1,K), 1 ) + 20 CONTINUE +C + END IF +C +C Calculate the column and row sum norms of A. +C + ACNORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) + ARNORM = DLANGE( 'I-norm', N, N, A, LDA, DWORK ) +C +C Scale the columns of B (i.e. inputs) to have norms roughly ACNORM. +C + CALL TB01TY( 1, 0, 0, N, M, ACNORM, B, LDB, SCIN ) +C +C Scale the rows of C (i.e. outputs) to have norms roughly ARNORM. +C + CALL TB01TY( 0, 0, 0, P, N, ARNORM, C, LDC, SCOUT ) +C +C Finally, apply these input and output scalings to D and set SCIN. +C + DO 40 J = 1, M + SCALE = SCIN(J) +C + DO 30 I = 1, P + D(I,J) = D(I,J)*( SCALE*SCOUT(I) ) + 30 CONTINUE +C + SCIN(J) = ONE/SCALE + 40 CONTINUE +C + RETURN +C *** Last line of TB01TD *** + END diff --git a/mex/sources/libslicot/TB01TY.f b/mex/sources/libslicot/TB01TY.f new file mode 100644 index 000000000..6dada6fa4 --- /dev/null +++ b/mex/sources/libslicot/TB01TY.f @@ -0,0 +1,136 @@ + SUBROUTINE TB01TY( MODE, IOFF, JOFF, NROW, NCOL, SIZE, X, LDX, + $ BVECT ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C Balances the rows (MODE .EQ. 0) or columns (MODE .NE. 0) of the +C (NROW x NCOL) block of the matrix X with offset (IOFF,JOFF), i.e. +C with first (top left) element (IOFF + 1,JOFF + 1). Each non- +C zero row (column) is balanced in the sense that it is multiplied +C by that integer power of the base of the machine floating-point +C representation for which the sum of the absolute values of its +C entries (i.e. its 1-norm) satisfies +C +C (SIZE / BASE) .LT. ABSSUM .LE. SIZE +C +C for SIZE as input. (Note that this form of scaling does not +C introduce any rounding errors.) The vector BVECT then contains +C the appropriate scale factors in rows (IOFF + 1)...(IOFF + NROW) +C (columns (JOFF + 1)...(JOFF + NCOL) ). In particular, if the +C I-th row (J-th column) of the block is 'numerically' non-zero +C with 1-norm given by BASE**(-EXPT) for some real EXPT, then the +C desired scale factor (returned as element IOFF + I (JOFF + J) of +C BVECT) is BASE**IEXPT, where IEXPT is the largest integer .LE. +C EXPT: this integer is precisely the truncation INT(EXPT) except +C for negative non-integer EXPT, in which case this value is too +C high by 1 and so must be adjusted accordingly. Finally, note +C that the element of BVECT corresponding to a 'numerically' zero +C row (column) is simply set equal to 1.0. +C +C For efficiency, no tests of the input scalar parameters are +C performed. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER IOFF, JOFF, LDX, MODE, NCOL, NROW + DOUBLE PRECISION SIZE +C .. Array Arguments .. + DOUBLE PRECISION BVECT(*), X(LDX,*) +C .. Local Scalars .. + DOUBLE PRECISION ABSSUM, DIV, EPS, EXPT, SCALE, TEST + INTEGER BASE, I, IEXPT, J +C .. External Functions .. + DOUBLE PRECISION DASUM, DLAMCH + EXTERNAL DASUM, DLAMCH +C .. External Subroutines .. + EXTERNAL DSCAL +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG +C .. Executable Statements .. +C + BASE = DLAMCH( 'Base' ) + EPS = DLAMCH( 'Epsilon' ) +C + DIV = ONE/LOG( DBLE( BASE ) ) + IF ( MODE.NE.0 ) THEN +C +C Balance one column at a time using its column-sum norm. +C + DO 10 J = JOFF + 1, JOFF + NCOL + ABSSUM = DASUM( NROW, X(IOFF+1,J), 1 )/ABS( SIZE ) + TEST = ABSSUM/DBLE( NROW ) + IF ( TEST.GT.EPS ) THEN +C +C Non-zero column: calculate (and apply) correct scale +C factor. +C + EXPT = -DIV*LOG( ABSSUM ) + IEXPT = INT( EXPT ) + IF ( ( IEXPT.LT.0 ) .AND. ( DBLE( IEXPT ).NE.EXPT ) ) + $ IEXPT = IEXPT - 1 + SCALE = DBLE( BASE )**IEXPT + BVECT(J) = SCALE + CALL DSCAL( NROW, SCALE, X(IOFF+1,J), 1 ) + ELSE +C +C 'Numerically' zero column: do not rescale. +C + BVECT(J) = ONE + END IF + 10 CONTINUE +C + ELSE +C +C Balance one row at a time using its row-sum norm. +C + DO 20 I = IOFF + 1, IOFF + NROW + ABSSUM = DASUM( NCOL, X(I,JOFF+1), LDX )/ABS( SIZE ) + TEST = ABSSUM/DBLE( NCOL ) + IF ( TEST.GT.EPS ) THEN +C +C Non-zero row: calculate (and apply) correct scale factor. +C + EXPT = -DIV*LOG( ABSSUM ) + IEXPT = INT( EXPT ) + IF ( ( IEXPT.LT.0 ) .AND. ( DBLE( IEXPT ).NE.EXPT ) ) + $ IEXPT = IEXPT - 1 +C + SCALE = DBLE( BASE )**IEXPT + BVECT(I) = SCALE + CALL DSCAL( NCOL, SCALE, X(I,JOFF+1), LDX ) + ELSE +C +C 'Numerically' zero row: do not rescale. +C + BVECT(I) = ONE + END IF + 20 CONTINUE +C + END IF +C + RETURN +C *** Last line of TB01TY *** + END diff --git a/mex/sources/libslicot/TB01UD.f b/mex/sources/libslicot/TB01UD.f new file mode 100644 index 000000000..191780145 --- /dev/null +++ b/mex/sources/libslicot/TB01UD.f @@ -0,0 +1,491 @@ + SUBROUTINE TB01UD( JOBZ, N, M, P, A, LDA, B, LDB, C, LDC, NCONT, + $ INDCON, NBLK, Z, LDZ, TAU, TOL, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a controllable realization for the linear time-invariant +C multi-input system +C +C dX/dt = A * X + B * U, +C Y = C * X, +C +C where A, B, and C are N-by-N, N-by-M, and P-by-N matrices, +C respectively, and A and B are reduced by this routine to +C orthogonal canonical form using (and optionally accumulating) +C orthogonal similarity transformations, which are also applied +C to C. Specifically, the system (A, B, C) is reduced to the +C triplet (Ac, Bc, Cc), where Ac = Z' * A * Z, Bc = Z' * B, +C Cc = C * Z, with +C +C [ Acont * ] [ Bcont ] +C Ac = [ ], Bc = [ ], +C [ 0 Auncont ] [ 0 ] +C +C and +C +C [ A11 A12 . . . A1,p-1 A1p ] [ B1 ] +C [ A21 A22 . . . A2,p-1 A2p ] [ 0 ] +C [ 0 A32 . . . A3,p-1 A3p ] [ 0 ] +C Acont = [ . . . . . . . ], Bc = [ . ], +C [ . . . . . . ] [ . ] +C [ . . . . . ] [ . ] +C [ 0 0 . . . Ap,p-1 App ] [ 0 ] +C +C where the blocks B1, A21, ..., Ap,p-1 have full row ranks and +C p is the controllability index of the pair. The size of the +C block Auncont is equal to the dimension of the uncontrollable +C subspace of the pair (A, B). +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBZ CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal similarity transformations for +C reducing the system, as follows: +C = 'N': Do not form Z and do not store the orthogonal +C transformations; +C = 'F': Do not form Z, but store the orthogonal +C transformations in the factored form; +C = 'I': Z is initialized to the unit matrix and the +C orthogonal transformation matrix Z is returned. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e. the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs, or of columns of B. M >= 0. +C +C P (input) INTEGER +C The number of system outputs, or of rows of C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading NCONT-by-NCONT part contains the +C upper block Hessenberg state dynamics matrix Acont in Ac, +C given by Z' * A * Z, of a controllable realization for +C the original system. The elements below the first block- +C subdiagonal are set to zero. The leading N-by-N part +C contains the matrix Ac. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B. +C On exit, the leading NCONT-by-M part of this array +C contains the transformed input matrix Bcont in Bc, given +C by Z' * B, with all elements but the first block set to +C zero. The leading N-by-M part contains the matrix Bc. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed output matrix Cc, given by C * Z. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C NCONT (output) INTEGER +C The order of the controllable state-space representation. +C +C INDCON (output) INTEGER +C The controllability index of the controllable part of the +C system representation. +C +C NBLK (output) INTEGER array, dimension (N) +C The leading INDCON elements of this array contain the +C the orders of the diagonal blocks of Acont. +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C If JOBZ = 'I', then the leading N-by-N part of this +C array contains the matrix of accumulated orthogonal +C similarity transformations which reduces the given system +C to orthogonal canonical form. +C If JOBZ = 'F', the elements below the diagonal, with the +C array TAU, represent the orthogonal transformation matrix +C as a product of elementary reflectors. The transformation +C matrix can then be obtained by calling the LAPACK Library +C routine DORGQR. +C If JOBZ = 'N', the array Z is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDZ = 1 and +C declare this array to be Z(1,1) in the calling program). +C +C LDZ INTEGER +C The leading dimension of array Z. If JOBZ = 'I' or +C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The elements of TAU contain the scalar factors of the +C elementary reflectors used in the reduction of B and A. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determination when +C transforming (A, B). If the user sets TOL > 0, then +C the given value of TOL is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*N*EPS, is used instead, where EPS +C is the machine precision (see LAPACK Library routine +C DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N, 3*M, P). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Matrix B is first QR-decomposed and the appropriate orthogonal +C similarity transformation applied to the matrix A. Leaving the +C first rank(B) states unchanged, the remaining lower left block +C of A is then QR-decomposed and the new orthogonal matrix, Q1, +C is also applied to the right of A to complete the similarity +C transformation. By continuing in this manner, a completely +C controllable state-space pair (Acont, Bcont) is found for the +C given (A, B), where Acont is upper block Hessenberg with each +C subdiagonal block of full row rank, and Bcont is zero apart from +C its (independent) first rank(B) rows. +C All orthogonal transformations determined in this process are also +C applied to the matrix C, from the right. +C NOTE that the system controllability indices are easily +C calculated from the dimensions of the blocks of Acont. +C +C REFERENCES +C +C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. +C Orthogonal Invariants and Canonical Forms for Linear +C Controllable Systems. +C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. +C +C [2] Paige, C.C. +C Properties of numerical algorithms related to computing +C controllablity. +C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. +C +C [3] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and +C Postlethwaite, I. +C Optimal Pole Assignment Design of Linear Multi-Input Systems. +C Leicester University, Report 99-11, May 1996. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C If the system matrices A and B are badly scaled, it would be +C useful to scale them with SLICOT routine TB01ID, before calling +C the routine. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, Nov. 2003. +C A. Varga, DLR Oberpfaffenhofen, March 2002, Nov. 2003. +C +C KEYWORDS +C +C Controllability, minimal realization, orthogonal canonical form, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBZ + INTEGER INDCON, INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N, + $ NCONT, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), TAU(*), + $ Z(LDZ,*) + INTEGER IWORK(*), NBLK(*) +C .. Local Scalars .. + LOGICAL LJOBF, LJOBI, LJOBZ + INTEGER IQR, ITAU, J, MCRT, NBL, NCRT, NI, NJ, RANK, + $ WRKOPT + DOUBLE PRECISION ANORM, BNORM, FNRM, TOLDEF +C .. Local Arrays .. + DOUBLE PRECISION SVAL(3) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 + EXTERNAL DLAMCH, DLANGE, DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DLAPMT, DLASET, DORGQR, DORMQR, + $ MB01PD, MB03OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C + INFO = 0 + LJOBF = LSAME( JOBZ, 'F' ) + LJOBI = LSAME( JOBZ, 'I' ) + LJOBZ = LJOBF.OR.LJOBI +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( .NOT.LJOBZ .AND. LDZ.LT.1 .OR. + $ LJOBZ .AND. LDZ.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDWORK.LT.MAX( 1, N, 3*M, P ) ) THEN + INFO = -20 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01UD', -INFO ) + RETURN + END IF +C + NCONT = 0 + INDCON = 0 +C +C Calculate the absolute norms of A and B (used for scaling). +C + ANORM = DLANGE( 'M', N, N, A, LDA, DWORK ) + BNORM = DLANGE( 'M', N, M, B, LDB, DWORK ) +C +C Quick return if possible. +C + IF ( MIN( N, M ).EQ.0 .OR. BNORM.EQ.ZERO ) THEN + IF( N.GT.0 ) THEN + IF ( LJOBI ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) + ELSE IF ( LJOBF ) THEN + CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) + END IF + END IF + DWORK(1) = ONE + RETURN + END IF +C +C Scale (if needed) the matrices A and B. +C + CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO ) + CALL MB01PD( 'S', 'G', N, M, 0, 0, BNORM, 0, NBLK, B, LDB, INFO ) +C +C Compute the Frobenius norm of [ B A ] (used for rank estimation). +C + FNRM = DLAPY2( DLANGE( 'F', N, M, B, LDB, DWORK ), + $ DLANGE( 'F', N, N, A, LDA, DWORK ) ) +C + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance in controllability determination. +C + TOLDEF = DBLE( N*N )*DLAMCH( 'EPSILON' ) + END IF +C + IF ( FNRM.LT.TOLDEF ) + $ FNRM = ONE +C + WRKOPT = 1 + NI = 0 + ITAU = 1 + NCRT = N + MCRT = M + IQR = 1 +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + 10 CONTINUE +C +C Rank-revealing QR decomposition with column pivoting. +C The calculation is performed in NCRT rows of B starting from +C the row IQR (initialized to 1 and then set to rank(B)+1). +C Workspace: 3*MCRT. +C + CALL MB03OY( NCRT, MCRT, B(IQR,1), LDB, TOLDEF, FNRM, RANK, + $ SVAL, IWORK, TAU(ITAU), DWORK, INFO ) +C + IF ( RANK.NE.0 ) THEN + NJ = NI + NI = NCONT + NCONT = NCONT + RANK + INDCON = INDCON + 1 + NBLK(INDCON) = RANK +C +C Premultiply and postmultiply the appropriate block row +C and block column of A by Q' and Q, respectively. +C Workspace: need NCRT; +C prefer NCRT*NB. +C + CALL DORMQR( 'Left', 'Transpose', NCRT, NCRT, RANK, + $ B(IQR,1), LDB, TAU(ITAU), A(NI+1,NI+1), LDA, + $ DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Workspace: need N; +C prefer N*NB. +C + CALL DORMQR( 'Right', 'No transpose', N, NCRT, RANK, + $ B(IQR,1), LDB, TAU(ITAU), A(1,NI+1), LDA, + $ DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Postmultiply the appropriate block column of C by Q. +C Workspace: need P; +C prefer P*NB. +C + CALL DORMQR( 'Right', 'No transpose', P, NCRT, RANK, + $ B(IQR,1), LDB, TAU(ITAU), C(1,NI+1), LDC, + $ DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C If required, save transformations. +C + IF ( LJOBZ.AND.NCRT.GT.1 ) THEN + CALL DLACPY( 'L', NCRT-1, MIN( RANK, NCRT-1 ), + $ B(IQR+1,1), LDB, Z(NI+2,ITAU), LDZ ) + END IF +C +C Zero the subdiagonal elements of the current matrix. +C + IF ( RANK.GT.1 ) + $ CALL DLASET( 'L', RANK-1, RANK-1, ZERO, ZERO, B(IQR+1,1), + $ LDB ) +C +C Backward permutation of the columns of B or A. +C + IF ( INDCON.EQ.1 ) THEN + CALL DLAPMT( .FALSE., RANK, M, B(IQR,1), LDB, IWORK ) + IQR = RANK + 1 + ELSE + DO 20 J = 1, MCRT + CALL DCOPY( RANK, B(IQR,J), 1, A(NI+1,NJ+IWORK(J)), + $ 1 ) + 20 CONTINUE + END IF +C + ITAU = ITAU + RANK + IF ( RANK.NE.NCRT ) THEN + MCRT = RANK + NCRT = NCRT - RANK + CALL DLACPY( 'G', NCRT, MCRT, A(NCONT+1,NI+1), LDA, + $ B(IQR,1), LDB ) + CALL DLASET( 'G', NCRT, MCRT, ZERO, ZERO, + $ A(NCONT+1,NI+1), LDA ) + GO TO 10 + END IF + END IF +C +C If required, accumulate transformations. +C Workspace: need N; prefer N*NB. +C + IF ( LJOBI ) THEN + CALL DORGQR( N, N, ITAU-1, Z, LDZ, TAU, DWORK, + $ LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + END IF +C +C Annihilate the trailing blocks of B. +C + IF( IQR.LE.N ) + $ CALL DLASET( 'G', N-IQR+1, M, ZERO, ZERO, B(IQR,1), LDB ) +C +C Annihilate the trailing elements of TAU, if JOBZ = 'F'. +C + IF ( LJOBF ) THEN + DO 30 J = ITAU, N + TAU(J) = ZERO + 30 CONTINUE + END IF +C +C Undo scaling of A and B. +C + IF ( INDCON.LT.N ) THEN + NBL = INDCON + 1 + NBLK(NBL) = N - NCONT + ELSE + NBL = 0 + END IF + CALL MB01PD( 'U', 'H', N, N, 0, 0, ANORM, NBL, NBLK, A, LDA, + $ INFO ) + CALL MB01PD( 'U', 'G', NBLK(1), M, 0, 0, BNORM, 0, NBLK, B, LDB, + $ INFO ) +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of TB01UD *** + END diff --git a/mex/sources/libslicot/TB01VD.f b/mex/sources/libslicot/TB01VD.f new file mode 100644 index 000000000..26cd1c7c3 --- /dev/null +++ b/mex/sources/libslicot/TB01VD.f @@ -0,0 +1,503 @@ + SUBROUTINE TB01VD( APPLY, N, M, L, A, LDA, B, LDB, C, LDC, D, LDD, + $ X0, THETA, LTHETA, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To convert the linear discrete-time system given as (A, B, C, D), +C with initial state x0, into the output normal form [1], with +C parameter vector THETA. The matrix A is assumed to be stable. +C The matrices A, B, C, D and the vector x0 are converted, so that +C on exit they correspond to the system defined by THETA. +C +C ARGUMENTS +C +C Mode Parameters +C +C APPLY CHARACTER*1 +C Specifies whether or not the parameter vector should be +C transformed using a bijective mapping, as follows: +C = 'A' : apply the bijective mapping to the N vectors in +C THETA corresponding to the matrices A and C; +C = 'N' : do not apply the bijective mapping. +C The transformation performed when APPLY = 'A' allows +C to get rid of the constraints norm(THETAi) < 1, i = 1:N. +C A call of the SLICOT Library routine TB01VY associated to +C a call of TB01VD must use the same value of APPLY. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the system state matrix A, assumed to be stable. +C On exit, the leading N-by-N part of this array contains +C the transformed system state matrix corresponding to the +C output normal form with parameter vector THETA. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the system input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed system input matrix corresponding to the +C output normal form with parameter vector THETA. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading L-by-N part of this array must +C contain the system output matrix C. +C On exit, the leading L-by-N part of this array contains +C the transformed system output matrix corresponding to the +C output normal form with parameter vector THETA. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,L). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading L-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,L). +C +C X0 (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the initial state of the +C system, x0. +C On exit, this array contains the transformed initial state +C of the system, corresponding to the output normal form +C with parameter vector THETA. +C +C THETA (output) DOUBLE PRECISION array, dimension (LTHETA) +C The leading N*(L+M+1)+L*M part of this array contains the +C parameter vector that defines a system (A, B, C, D, x0) +C which is equivalent up to a similarity transformation to +C the system given on entry. The parameters are: +C +C THETA(1:N*L) : parameters for A, C; +C THETA(N*L+1:N*(L+M)) : parameters for B; +C THETA(N*(L+M)+1:N*(L+M)+L*M) : parameters for D; +C THETA(N*(L+M)+L*M+1:N*(L+M+1)+L*M): parameters for x0. +C +C LTHETA INTEGER +C The length of array THETA. LTHETA >= N*(L+M+1)+L*M. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N*N*L + N*L + N, +C N*N + MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), +C N*M)). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the Lyapunov equation A'*Q*A - Q = -scale^2*C'*C +C could only be solved with scale = 0; +C = 2: if matrix A is not discrete-time stable; +C = 3: if the QR algorithm failed to converge for +C matrix A. +C +C METHOD +C +C The matrices A and C are converted to output normal form. +C First, the Lyapunov equation +C +C A'*Q*A - Q = -scale^2*C'*C, +C +C is solved in the Cholesky factor T, T'*T = Q, and then T is used +C to get the transformation matrix. +C +C The matrix B and the initial state x0 are transformed accordingly. +C +C Then, the QR factorization of the transposed observability matrix +C is computed, and the matrix Q is used to further transform the +C system matrices. The parameters characterizing A and C are finally +C obtained by applying a set of N orthogonal transformations. +C +C REFERENCES +C +C [1] Peeters, R.L.M., Hanzon, B., and Olivi, M. +C Balanced realizations of discrete-time stable all-pass +C systems and the tangential Schur algorithm. +C Proceedings of the European Control Conference, +C 31 August - 3 September 1999, Karlsruhe, Germany. +C Session CP-6, Discrete-time Systems, 1999. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Oct. 2000, during a stay at University of Twente, NL. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, +C Feb. 2002, Feb. 2004. +C +C KEYWORDS +C +C Asymptotically stable, Lyapunov equation, output normal form, +C parameter estimation, similarity transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, HALF + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ HALF = 0.5D0 ) +C .. Scalar Arguments .. + CHARACTER APPLY + INTEGER INFO, L, LDA, LDB, LDC, LDD, LDWORK, LTHETA, M, + $ N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), THETA(*), X0(*) +C .. Local Scalars .. + DOUBLE PRECISION PIBY2, RI, SCALE, TI + INTEGER CA, I, IA, IN, IQ, IR, IT, ITAU, IU, IWI, IWR, + $ J, JWORK, K, LDCA, LDT, WRKOPT + LOGICAL LAPPLY +C .. External Functions .. + EXTERNAL DNRM2, LSAME + DOUBLE PRECISION DNRM2 + LOGICAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGEQRF, DGER, + $ DLACPY, DLASET, DORMQR, DSCAL, DTRMM, DTRMV, + $ DTRSM, MA02AD, SB03OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ATAN, INT, MAX, MIN, SQRT, TAN +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + LAPPLY = LSAME( APPLY, 'A' ) +C + INFO = 0 + IF ( .NOT.( LAPPLY .OR. LSAME( APPLY, 'N' ) ) ) THEN + INFO = -1 + ELSEIF ( N.LT.0 ) THEN + INFO = -2 + ELSEIF ( M.LT.0 ) THEN + INFO = -3 + ELSEIF ( L.LT.0 ) THEN + INFO = -4 + ELSEIF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSEIF ( LDC.LT.MAX( 1, L ) ) THEN + INFO = -10 + ELSEIF ( LDD.LT.MAX( 1, L ) ) THEN + INFO = -12 + ELSEIF ( LTHETA.LT.( N*( M + L + 1 ) + L*M ) ) THEN + INFO = -15 + ELSEIF ( LDWORK.LT.MAX( 1, N*N*L + N*L + N, N*N + + $ MAX( N*( N + MAX( N, L ) + 6 ) + + $ MIN( N, L ), N*M ) ) ) THEN + INFO = -17 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TB01VD', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( MAX( N, M, L ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + ELSE IF ( N.EQ.0 ) THEN + CALL DLACPY( 'Full', L, M, D, LDD, THETA, MAX( 1, L ) ) + DWORK(1) = ONE + RETURN + ELSE IF ( L.EQ.0 ) THEN + CALL DLACPY( 'Full', N, M, B, LDB, THETA, N ) + CALL DCOPY( N, X0, 1, THETA(N*M+1), 1 ) + DWORK(1) = ONE + RETURN + ENDIF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + WRKOPT = 1 + PIBY2 = TWO*ATAN( ONE ) +C +C Convert A and C to output normal form. +C First, solve the Lyapunov equation +C A'*Q*A - Q = -scale^2*C'*C, +C in the Cholesky factor T, T'*T = Q, and use T to get the +C transformation matrix. Copy A and C, to preserve them. +C +C Workspace: need N*(2*N + MAX(N,L) + 6) + MIN(N,L). +C prefer larger. +C +C Initialize the indices in the workspace. +C + LDT = MAX( N, L ) + CA = 1 + IA = 1 + IT = IA + N*N + IU = IT + LDT*N + IWR = IU + N*N + IWI = IWR + N +C + JWORK = IWI + N +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), N ) + CALL DLACPY( 'Full', L, N, C, LDC, DWORK(IT), LDT ) +C + CALL SB03OD( 'Discrete', 'NotFactored', 'NoTranspose', N, L, + $ DWORK(IA), N, DWORK(IU), N, DWORK(IT), LDT, SCALE, + $ DWORK(IWR), DWORK(IWI), DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) + IF ( INFO.NE.0 ) THEN + IF ( INFO.EQ.6 ) THEN + INFO = 3 + ELSE + INFO = 2 + ENDIF + RETURN + ENDIF + WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 +C + IF ( SCALE.EQ.ZERO ) THEN + INFO = 1 + RETURN + ENDIF +C +C Compute A = T*A*T^(-1). +C + CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, N, ONE, + $ DWORK(IT), LDT, A, LDA ) +C + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, N, ONE, + $ DWORK(IT), LDT, A, LDA ) + IF ( M.GT.0 ) THEN +C +C Compute B = (1/scale)*T*B. +C + CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, M, + $ ONE/SCALE, DWORK(IT), LDT, B, LDB ) + ENDIF +C +C Compute x0 = (1/scale)*T*x0. +C + CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', N, DWORK(IT), LDT, + $ X0, 1 ) + CALL DSCAL( N, ONE/SCALE, X0, 1 ) +C +C Compute C = scale*C*T^(-1). +C + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', L, N, + $ SCALE, DWORK(IT), LDT, C, LDC ) +C +C Now, the system has been transformed to the output normal form. +C Build the transposed observability matrix in DWORK(CA) and compute +C its QR factorization. +C + CALL MA02AD( 'Full', L, N, C, LDC, DWORK(CA), N ) +C + DO 10 I = 1, N - 1 + CALL DGEMM( 'Transpose', 'NoTranspose', N, L, N, ONE, A, LDA, + $ DWORK(CA+(I-1)*N*L), N, ZERO, DWORK(CA+I*N*L), N ) + 10 CONTINUE +C +C Compute the QR factorization. +C +C Workspace: need N*N*L + N + L*N. +C prefer N*N*L + N + NB*L*N. +C + ITAU = CA + N*N*L + JWORK = ITAU + N + CALL DGEQRF( N, L*N, DWORK(CA), N, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Compute Q such that R has all diagonal elements nonnegative. +C Only the first N*N part of R is needed. Move the details +C of the QR factorization process, to gain memory and efficiency. +C +C Workspace: need 2*N*N + 2*N. +C prefer 2*N*N + N + NB*N. +C + IR = N*N + 1 + IF ( L.NE.2 ) + $ CALL DCOPY( N, DWORK(ITAU), 1, DWORK(IR+N*N), 1 ) + CALL DLACPY( 'Lower', N, N, DWORK(CA), N, DWORK(IR), N ) + ITAU = IR + N*N + JWORK = ITAU + N +C + IQ = 1 + CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(IQ), N ) +C + DO 20 I = 1, N + IF ( DWORK(IR+(I-1)*(N+1)).LT.ZERO ) + $ DWORK(IQ+(I-1)*(N+1))= -ONE + 20 CONTINUE +C + CALL DORMQR( 'Left', 'NoTranspose', N, N, N, DWORK(IR), N, + $ DWORK(ITAU), DWORK(IQ), N, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + JWORK = IR +C +C Now, the transformation matrix Q is in DWORK(IQ). +C +C Compute A = Q'*A*Q. +C + CALL DGEMM( 'Transpose', 'NoTranspose', N, N, N, ONE, DWORK(IQ), + $ N, A, LDA, ZERO, DWORK(JWORK), N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, + $ DWORK(JWORK), N, DWORK(IQ), N, ZERO, A, LDA ) +C + IF ( M.GT.0 ) THEN +C +C Compute B = Q'*B. +C Workspace: need N*N + N*M. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(JWORK), N ) + CALL DGEMM( 'Transpose', 'NoTranspose', N, M, N, ONE, + $ DWORK(IQ), N, DWORK(JWORK), N, ZERO, B, LDB ) + ENDIF +C +C Compute C = C*Q. +C Workspace: need N*N + N*L. +C + CALL DLACPY( 'Full', L, N, C, LDC, DWORK(JWORK), L ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', L, N, N, ONE, + $ DWORK(JWORK), L, DWORK(IQ), N, ZERO, C, LDC ) +C +C Compute x0 = Q'*x0. +C + CALL DCOPY( N, X0, 1, DWORK(JWORK), 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, DWORK(IQ), N, DWORK(JWORK), + $ 1, ZERO, X0, 1 ) +C +C Now, copy C and A into the workspace to make it easier to read out +C the corresponding part of THETA, and to apply the transformations. +C + LDCA = N + L +C + DO 30 I = 1, N + CALL DCOPY( L, C(1,I), 1, DWORK(CA+(I-1)*LDCA), 1 ) + CALL DCOPY( N, A(1,I), 1, DWORK(CA+L+(I-1)*LDCA), 1 ) + 30 CONTINUE +C + JWORK = CA + LDCA*N +C +C The parameters characterizing A and C are extracted in this loop. +C Workspace: need N*(N + L + 1). +C + DO 60 I = 1, N + CALL DCOPY( L, DWORK(CA+1+(N-I)*(LDCA+1)), 1, THETA((I-1)*L+1), + $ 1 ) + RI = DWORK(CA+(N-I)*(LDCA+1)) + TI = DNRM2( L, THETA((I-1)*L+1), 1 ) +C +C Multiply the part of [C; A] which will be currently transformed +C with Ui = [ -THETAi, Si; RI, THETAi' ] from the left, without +C storing Ui. Ui has the size (L+1)-by-(L+1). +C + CALL DGEMV( 'Transpose', L, N, ONE, DWORK(CA+N-I+1), LDCA, + $ THETA((I-1)*L+1), 1, ZERO, DWORK(JWORK), 1 ) +C + IF ( TI.GT.ZERO ) THEN + CALL DGER( L, N, (RI-ONE)/TI/TI, THETA((I-1)*L+1), 1, + $ DWORK(JWORK), 1, DWORK(CA+N-I+1), LDCA ) + ELSE +C +C The call below is for the limiting case. +C + CALL DGER( L, N, -HALF, THETA((I-1)*L+1), 1, + $ DWORK(JWORK), 1, DWORK(CA+N-I+1), LDCA ) + ENDIF +C + CALL DGER( L, N, -ONE, THETA((I-1)*L+1), 1, DWORK(CA+N-I), + $ LDCA, DWORK(CA+N-I+1), LDCA ) + CALL DAXPY( N, RI, DWORK(CA+N-I), LDCA, DWORK(JWORK), 1 ) +C +C Move these results to their appropriate locations. +C + DO 50 J = 1, N + IN = CA + N - I + ( J - 1 )*LDCA + DO 40 K = IN + 1, IN + L + DWORK(K-1) = DWORK(K) + 40 CONTINUE + DWORK(IN+L) = DWORK(JWORK+J-1) + 50 CONTINUE +C +C Now, apply the bijective mapping, which allows to get rid +C of the constraint norm(THETAi) < 1. +C + IF ( LAPPLY .AND. TI.NE.ZERO ) + $ CALL DSCAL( L, TAN( TI*PIBY2 )/TI, THETA((I-1)*L+1), 1 ) +C + 60 CONTINUE +C + IF ( M.GT.0 ) THEN +C +C The next part of THETA is B. +C + CALL DLACPY( 'Full', N, M, B, LDB, THETA(N*L+1), N ) +C +C Copy the matrix D. +C + CALL DLACPY( 'Full', L, M, D, LDD, THETA(N*(L+M)+1), L ) + ENDIF +C +C Copy the initial state x0. +C + CALL DCOPY( N, X0, 1, THETA(N*(L+M)+L*M+1), 1 ) +C + DWORK(1) = WRKOPT + RETURN +C +C *** Last line of TB01VD *** + END diff --git a/mex/sources/libslicot/TB01VY.f b/mex/sources/libslicot/TB01VY.f new file mode 100644 index 000000000..d18361a20 --- /dev/null +++ b/mex/sources/libslicot/TB01VY.f @@ -0,0 +1,317 @@ + SUBROUTINE TB01VY( APPLY, N, M, L, THETA, LTHETA, A, LDA, B, LDB, + $ C, LDC, D, LDD, X0, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To convert the linear discrete-time system given as its output +C normal form [1], with parameter vector THETA, into the state-space +C representation (A, B, C, D), with the initial state x0. +C +C ARGUMENTS +C +C Mode Parameters +C +C APPLY CHARACTER*1 +C Specifies whether or not the parameter vector should be +C transformed using a bijective mapping, as follows: +C = 'A' : apply the bijective mapping to the N vectors in +C THETA corresponding to the matrices A and C; +C = 'N' : do not apply the bijective mapping. +C The transformation performed when APPLY = 'A' allows +C to get rid of the constraints norm(THETAi) < 1, i = 1:N. +C A call of the SLICOT Library routine TB01VD associated to +C a call of TB01VY must use the same value of APPLY. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L >= 0. +C +C THETA (input) DOUBLE PRECISION array, dimension (LTHETA) +C The leading N*(L+M+1)+L*M part of this array must contain +C the parameter vector that defines a system (A, B, C, D), +C with the initial state x0. The parameters are: +C +C THETA(1:N*L) : parameters for A, C; +C THETA(N*L+1:N*(L+M)) : parameters for B; +C THETA(N*(L+M)+1:N*(L+M)+L*M) : parameters for D; +C THETA(N*(L+M)+L*M+1:N*(L+M+1)+L*M): parameters for x0. +C +C LTHETA INTEGER +C The length of array THETA. LTHETA >= N*(L+M+1)+L*M. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the system +C state matrix corresponding to the output normal form with +C parameter vector THETA. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array contains the system +C input matrix corresponding to the output normal form with +C parameter vector THETA. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C The leading L-by-N part of this array contains the system +C output matrix corresponding to the output normal form with +C parameter vector THETA. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,L). +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M) +C The leading L-by-M part of this array contains the system +C input/output matrix corresponding to the output normal +C form with parameter vector THETA. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,L). +C +C X0 (output) DOUBLE PRECISION array, dimension (N) +C This array contains the initial state of the system, x0, +C corresponding to the output normal form with parameter +C vector THETA. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= N*(N+L+1). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The parameters characterizing A and C are used to build N +C orthogonal transformations, which are then applied to recover +C these matrices. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Oct. 2000, during a stay at University of Twente, NL. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, +C Feb. 2002, Feb. 2004. +C +C KEYWORDS +C +C Asymptotically stable, output normal form, parameter estimation, +C similarity transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D0 ) +C .. Scalar Arguments .. + CHARACTER APPLY + INTEGER INFO, L, LDA, LDB, LDC, LDD, LDWORK, LTHETA, M, + $ N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), THETA(*), X0(*) +C .. Local Scalars .. + DOUBLE PRECISION FACTOR, RI, TI, TOBYPI + INTEGER CA, JWORK, I, IN, J, K, LDCA + LOGICAL LAPPLY +C .. External Functions .. + EXTERNAL DNRM2, LSAME + DOUBLE PRECISION DNRM2 + LOGICAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLACPY, DSCAL, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC ATAN, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + LAPPLY = LSAME( APPLY, 'A' ) +C + INFO = 0 + IF ( .NOT.( LAPPLY .OR. LSAME( APPLY, 'N' ) ) ) THEN + INFO = -1 + ELSEIF ( N.LT.0 ) THEN + INFO = -2 + ELSEIF ( M.LT.0 ) THEN + INFO = -3 + ELSEIF ( L.LT.0 ) THEN + INFO = -4 + ELSEIF ( LTHETA.LT.( N*( L + M + 1 ) + L*M ) ) THEN + INFO = -6 + ELSEIF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSEIF ( LDC.LT.MAX( 1, L ) ) THEN + INFO = -12 + ELSEIF ( LDD.LT.MAX( 1, L ) ) THEN + INFO = -14 + ELSEIF ( LDWORK.LT.N*( N + L + 1 ) ) THEN + INFO = -17 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TB01VY', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( MAX( N, M, L ).EQ.0 ) + $ RETURN +C + IF ( M.GT.0 ) THEN +C +C Copy the matrix B from THETA. +C + CALL DLACPY( 'Full', N, M, THETA(N*L+1), N, B, LDB ) +C +C Copy the matrix D. +C + CALL DLACPY( 'Full', L, M, THETA(N*(L+M)+1), L, D, LDD ) + ENDIF +C + IF ( N.EQ.0 ) THEN + RETURN + ELSE IF ( L.EQ.0 ) THEN + CALL DCOPY( N, THETA(N*M+1), 1, X0, 1 ) + RETURN + END IF +C +C Initialize the indices in the workspace. +C + LDCA = N + L +C + CA = 1 +C + JWORK = CA + N*LDCA + TOBYPI = HALF/ATAN( ONE ) +C +C Generate the matrices C and A from their parameters. +C Start with the block matrix [0; I], where 0 is a block of zeros +C of size L-by-N, and I is the identity matrix of order N. +C + DWORK(CA) = ZERO + CALL DCOPY( N*(L+N), DWORK(CA), 0, DWORK(CA), 1 ) + DWORK(CA+L) = ONE + CALL DCOPY( N, DWORK(CA+L), 0, DWORK(CA+L), LDCA+1 ) +C +C Now, read out THETA(1 : N*L) and perform the transformations +C defined by the parameters in THETA. +C + DO 30 I = N, 1, -1 +C +C Save THETAi in the first column of C and use the copy for +C further processing. +C + CALL DCOPY( L, THETA((I-1)*L+1), 1, C, 1 ) + TI = DNRM2( L, C, 1 ) + IF ( LAPPLY .AND. TI.NE.ZERO ) THEN +C +C Apply the bijective mapping which guarantees that TI < 1. +C + FACTOR = TOBYPI*ATAN( TI )/TI +C +C Scale THETAi and apply the same scaling on TI. +C + CALL DSCAL( L, FACTOR, C, 1 ) + TI = TI*FACTOR + END IF +C +C RI = sqrt( 1 - TI**2 ). +C + RI = SQRT( ( ONE - TI )*( ONE + TI ) ) +C +C Multiply a certain part of DWORK(CA) with Ui' from the left, +C where Ui = [ -THETAi, Si; RI, THETAi' ] is (L+1)-by-(L+1), but +C Ui is not stored. +C + CALL DGEMV( 'Transpose', L, N, -ONE, DWORK(CA+N-I), LDCA, C, 1, + $ ZERO, DWORK(JWORK), 1 ) +C + IF ( TI.GT.ZERO ) THEN + CALL DGER( L, N, (ONE-RI)/TI/TI, C, 1, DWORK(JWORK), 1, + $ DWORK(CA+N-I), LDCA ) + ELSE +C +C The call below is for the limiting case. +C + CALL DGER( L, N, HALF, C, 1, DWORK(JWORK), 1, + $ DWORK(CA+N-I), LDCA ) + ENDIF +C + CALL DGER( L, N, ONE, C, 1, DWORK(CA+N-I+L), LDCA, + $ DWORK(CA+N-I), LDCA ) + CALL DAXPY( N, RI, DWORK(CA+N-I+L), LDCA, DWORK(JWORK), 1 ) +C +C Move these results to their appropriate locations. +C + DO 20 J = 1, N + IN = CA + N - I + ( J - 1 )*LDCA + DO 10 K = IN + L, IN + 1, -1 + DWORK(K) = DWORK(K-1) + 10 CONTINUE + DWORK(IN) = DWORK(JWORK+J-1) + 20 CONTINUE +C + 30 CONTINUE +C +C Now, DWORK(CA) = [C; A]. Copy to C and A. +C + DO 40 I = 1, N + CALL DCOPY( L, DWORK(CA+(I-1)*LDCA), 1, C(1,I), 1 ) + CALL DCOPY( N, DWORK(CA+L+(I-1)*LDCA), 1, A(1,I), 1 ) + 40 CONTINUE +C +C Copy the initial state x0. +C + CALL DCOPY( N, THETA(N*(L+M)+L*M+1), 1, X0, 1 ) +C + RETURN +C +C *** Last line of TB01VY *** + END diff --git a/mex/sources/libslicot/TB01WD.f b/mex/sources/libslicot/TB01WD.f new file mode 100644 index 000000000..36dd01231 --- /dev/null +++ b/mex/sources/libslicot/TB01WD.f @@ -0,0 +1,259 @@ + SUBROUTINE TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, U, LDU, + $ WR, WI, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the system state matrix A to an upper real Schur form +C by using an orthogonal similarity transformation A <-- U'*A*U and +C to apply the transformation to the matrices B and C: B <-- U'*B +C and C <-- C*U. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e. the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs, or of columns of B. M >= 0. +C +C P (input) INTEGER +C The number of system outputs, or of rows of C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading N-by-N part of this array contains +C the matrix U' * A * U in real Schur form. The elements +C below the first subdiagonal are set to zero. +C Note: A matrix is in real Schur form if it is upper +C quasi-triangular with 1-by-1 and 2-by-2 blocks. +C 2-by-2 blocks are standardized in the form +C [ a b ] +C [ c a ] +C where b*c < 0. The eigenvalues of such a block +C are a +- sqrt(bc). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed input matrix U' * B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed output matrix C * U. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C U (output) DOUBLE PRECISION array, dimension (LDU,N) +C The leading N-by-N part of this array contains the +C orthogonal transformation matrix used to reduce A to the +C real Schur form. The columns of U are the Schur vectors of +C matrix A. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= max(1,N). +C +C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) +C WR and WI contain the real and imaginary parts, +C respectively, of the computed eigenvalues of A. The +C eigenvalues will be in the same order that they appear on +C the diagonal of the output real Schur form of A. Complex +C conjugate pairs of eigenvalues will appear consecutively +C with the eigenvalue having the positive imaginary part +C first. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. LWORK >= 3*N. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, the QR algorithm failed to compute +C all the eigenvalues; elements i+1:N of WR and WI +C contain those eigenvalues which have converged; +C U contains the matrix which reduces A to its +C partially converged Schur form. +C +C METHOD +C +C Matrix A is reduced to a real Schur form using an orthogonal +C similarity transformation A <- U'*A*U. Then, the transformation +C is applied to the matrices B and C: B <-- U'*B and C <-- C*U. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires about 10N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine SRSFDC. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Orthogonal transformation, real Schur form, similarity +C transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*), + $ WI(*), WR(*) +C .. Local Scalars .. + INTEGER I, LDWP, SDIM + DOUBLE PRECISION WRKOPT +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. External Functions .. + LOGICAL LSAME, SELECT + EXTERNAL LSAME, SELECT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DLACPY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C + INFO = 0 +C +C Check input parameters. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -9 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.3*N ) THEN + INFO = -15 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01WD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C +C Reduce A to real Schur form using an orthogonal similarity +C transformation A <- U'*A*U, accumulate the transformation in U +C and compute the eigenvalues of A in (WR,WI). +C +C Workspace: need 3*N; +C prefer larger. +C + CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + WRKOPT = DWORK( 1 ) + IF( INFO.NE.0 ) + $ RETURN +C +C Apply the transformation: B <-- U'*B. +C + IF( LDWORK.LT.N*M ) THEN +C +C Not enough working space for using DGEMM. +C + DO 10 I = 1, M + CALL DCOPY( N, B(1,I), 1, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, + $ B(1,I), 1 ) + 10 CONTINUE +C + ELSE + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, U, LDU, + $ DWORK, N, ZERO, B, LDB ) + WRKOPT = MAX( WRKOPT, DBLE( N*M ) ) + END IF +C +C Apply the transformation: C <-- C*U. +C + IF( LDWORK.LT.N*P ) THEN +C +C Not enough working space for using DGEMM. +C + DO 20 I = 1, P + CALL DCOPY( N, C(I,1), LDC, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, + $ C(I,1), LDC ) + 20 CONTINUE +C + ELSE + LDWP = MAX( 1, P ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDWP ) + CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, + $ DWORK, LDWP, U, LDU, ZERO, C, LDC ) + WRKOPT = MAX( WRKOPT, DBLE( N*P ) ) + END IF +C + DWORK( 1 ) = WRKOPT +C + RETURN +C *** Last line of TB01WD *** + END diff --git a/mex/sources/libslicot/TB01XD.f b/mex/sources/libslicot/TB01XD.f new file mode 100644 index 000000000..78bf92957 --- /dev/null +++ b/mex/sources/libslicot/TB01XD.f @@ -0,0 +1,284 @@ + SUBROUTINE TB01XD( JOBD, N, M, P, KL, KU, A, LDA, B, LDB, C, LDC, + $ D, LDD, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply a special transformation to a system given as a triple +C (A,B,C), +C +C A <-- P * A' * P, B <-- P * C', C <-- B' * P, +C +C where P is a matrix with 1 on the secondary diagonal, and with 0 +C in the other entries. Matrix A can be specified as a band matrix. +C Optionally, matrix D of the system can be transposed. This +C transformation is actually a special similarity transformation of +C the dual system. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears in +C the given state space model: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A, the number of rows of matrix B +C and the number of columns of matrix C. +C N represents the dimension of the state vector. N >= 0. +C +C M (input) INTEGER. +C The number of columns of matrix B. +C M represents the dimension of input vector. M >= 0. +C +C P (input) INTEGER. +C The number of rows of matrix C. +C P represents the dimension of output vector. P >= 0. +C +C KL (input) INTEGER +C The number of subdiagonals of A to be transformed. +C MAX( 0, N-1 ) >= KL >= 0. +C +C KU (input) INTEGER +C The number of superdiagonals of A to be transformed. +C MAX( 0, N-1 ) >= KU >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the system state matrix A. +C On exit, the leading N-by-N part of this array contains +C the transformed (pertransposed) matrix P*A'*P. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,MAX(M,P)) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, the leading N-by-P part of this array contains +C the dual input/state matrix P*C'. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,N) if M > 0 or P > 0. +C LDB >= 1 if M = 0 and P = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, the leading M-by-N part of this array contains +C the dual state/output matrix B'*P. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,M,P) if N > 0. +C LDC >= 1 if N = 0. +C +C D (input/output) DOUBLE PRECISION array, dimension +C (LDD,MAX(M,P)) +C On entry, if JOBD = 'D', the leading P-by-M part of this +C array must contain the original direct transmission +C matrix D. +C On exit, if JOBD = 'D', the leading M-by-P part of this +C array contains the transposed direct transmission matrix +C D'. The array D is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,M,P) if JOBD = 'D'. +C LDD >= 1 if JOBD = 'Z'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The rows and/or columns of the matrices of the triplet (A,B,C) +C and, optionally, of the matrix D are swapped in a special way. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C Partly based on routine DMPTR (A. Varga, German Aerospace +C Research Establishment, DLR, Aug. 1992). +C +C +C REVISIONS +C +C 07-31-1998, 04-25-1999, A. Varga. +C 03-16-2004, V. Sima. +C +C KEYWORDS +C +C Matrix algebra, matrix operations, similarity transformation. +C +C ********************************************************************* +C +C .. +C .. Scalar Arguments .. + CHARACTER JOBD + INTEGER INFO, KL, KU, LDA, LDB, LDC, LDD, M, N, P +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ) +C .. +C .. Local Scalars .. + LOGICAL LJOBD + INTEGER J, J1, LDA1, MAXMP, MINMP, NM1 +C .. +C .. External functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DSWAP, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the scalar input arguments. +C + INFO = 0 + LJOBD = LSAME( JOBD, 'D' ) + MAXMP = MAX( M, P ) + MINMP = MIN( M, P ) + NM1 = N - 1 +C + IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( KL.LT.0 .OR. KL.GT.MAX( 0, NM1 ) ) THEN + INFO = -5 + ELSE IF( KU.LT.0 .OR. KU.GT.MAX( 0, NM1 ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( ( MAXMP.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. + $ ( MINMP.EQ.0 .AND. LDB.LT.1 ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.1 .OR. ( LJOBD .AND. LDD.LT.MAXMP ) ) THEN + INFO = -14 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01XD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( LJOBD ) THEN +C +C Replace D by D', if non-scalar. +C + DO 5 J = 1, MAXMP + IF ( J.LT.MINMP ) THEN + CALL DSWAP( MINMP-J, D(J+1,J), 1, D(J,J+1), LDD ) + ELSE IF ( J.GT.P ) THEN + CALL DCOPY( P, D(1,J), 1, D(J,1), LDD ) + ELSE IF ( J.GT.M ) THEN + CALL DCOPY( M, D(J,1), LDD, D(1,J), 1 ) + END IF + 5 CONTINUE +C + END IF +C + IF( N.EQ.0 ) + $ RETURN +C +C Replace matrix A by P*A'*P. +C + IF ( KL.EQ.NM1 .AND. KU.EQ.NM1 ) THEN +C +C Full matrix A. +C + DO 10 J = 1, NM1 + CALL DSWAP( N-J, A( 1, J ), 1, A( N-J+1, J+1 ), -LDA ) + 10 CONTINUE +C + ELSE +C +C Band matrix A. +C + LDA1 = LDA + 1 +C +C Pertranspose the KL subdiagonals. +C + DO 20 J = 1, MIN( KL, N-2 ) + J1 = ( N - J )/2 + CALL DSWAP( J1, A(J+1,1), LDA1, A(N-J1+1,N-J1+1-J), -LDA1 ) + 20 CONTINUE +C +C Pertranspose the KU superdiagonals. +C + DO 30 J = 1, MIN( KU, N-2 ) + J1 = ( N - J )/2 + CALL DSWAP( J1, A(1,J+1), LDA1, A(N-J1+1-J,N-J1+1), -LDA1 ) + 30 CONTINUE +C +C Pertranspose the diagonal. +C + J1 = N/2 + CALL DSWAP( J1, A(1,1), LDA1, A(N-J1+1,N-J1+1), -LDA1 ) +C + END IF +C +C Replace matrix B by P*C' and matrix C by B'*P. +C + DO 40 J = 1, MAXMP + IF ( J.LE.MINMP ) THEN + CALL DSWAP( N, B(1,J), 1, C(J,1), -LDC ) + ELSE IF ( J.GT.P ) THEN + CALL DCOPY( N, B(1,J), 1, C(J,1), -LDC ) + ELSE + CALL DCOPY( N, C(J,1), -LDC, B(1,J), 1 ) + END IF + 40 CONTINUE +C + RETURN +C *** Last line of TB01XD *** + END diff --git a/mex/sources/libslicot/TB01XZ.f b/mex/sources/libslicot/TB01XZ.f new file mode 100644 index 000000000..ef73d0ce3 --- /dev/null +++ b/mex/sources/libslicot/TB01XZ.f @@ -0,0 +1,280 @@ + SUBROUTINE TB01XZ( JOBD, N, M, P, KL, KU, A, LDA, B, LDB, C, LDC, + $ D, LDD, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply a special transformation to a system given as a triple +C (A,B,C), +C +C A <-- P * A' * P, B <-- P * C', C <-- B' * P, +C +C where P is a matrix with 1 on the secondary diagonal, and with 0 +C in the other entries. Matrix A can be specified as a band matrix. +C Optionally, matrix D of the system can be transposed. This +C transformation is actually a special similarity transformation of +C the dual system. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears in +C the given state space model: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A, the number of rows of matrix B +C and the number of columns of matrix C. +C N represents the dimension of the state vector. N >= 0. +C +C M (input) INTEGER. +C The number of columns of matrix B. +C M represents the dimension of input vector. M >= 0. +C +C P (input) INTEGER. +C The number of rows of matrix C. +C P represents the dimension of output vector. P >= 0. +C +C KL (input) INTEGER +C The number of subdiagonals of A to be transformed. +C MAX( 0, N-1 ) >= KL >= 0. +C +C KU (input) INTEGER +C The number of superdiagonals of A to be transformed. +C MAX( 0, N-1 ) >= KU >= 0. +C +C A (input/output) COMPLEX*16 array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the system state matrix A. +C On exit, the leading N-by-N part of this array contains +C the transformed (pertransposed) matrix P*A'*P. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) COMPLEX*16 array, dimension (LDB,MAX(M,P)) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, the leading N-by-P part of this array contains +C the dual input/state matrix P*C'. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,N) if M > 0 or P > 0. +C LDB >= 1 if M = 0 and P = 0. +C +C C (input/output) COMPLEX*16 array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, the leading M-by-N part of this array contains +C the dual state/output matrix B'*P. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,M,P) if N > 0. +C LDC >= 1 if N = 0. +C +C D (input/output) COMPLEX*16 array, dimension (LDD,MAX(M,P)) +C On entry, if JOBD = 'D', the leading P-by-M part of this +C array must contain the original direct transmission +C matrix D. +C On exit, if JOBD = 'D', the leading M-by-P part of this +C array contains the transposed direct transmission matrix +C D'. The array D is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,M,P) if JOBD = 'D'. +C LDD >= 1 if JOBD = 'Z'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The rows and/or columns of the matrices of the triplet (A,B,C) +C and, optionally, of the matrix D are swapped in a special way. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Matrix algebra, matrix operations, similarity transformation. +C +C ********************************************************************* +C +C .. +C .. Scalar Arguments .. + CHARACTER JOBD + INTEGER INFO, KL, KU, LDA, LDB, LDC, LDD, M, N, P +C .. +C .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ) +C .. +C .. Local Scalars .. + LOGICAL LJOBD + INTEGER J, J1, LDA1, MAXMP, MINMP, NM1 +C .. +C .. External functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. +C .. External Subroutines .. + EXTERNAL XERBLA, ZCOPY, ZSWAP +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the scalar input arguments. +C + INFO = 0 + LJOBD = LSAME( JOBD, 'D' ) + MAXMP = MAX( M, P ) + MINMP = MIN( M, P ) + NM1 = N - 1 +C + IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( KL.LT.0 .OR. KL.GT.MAX( 0, NM1 ) ) THEN + INFO = -5 + ELSE IF( KU.LT.0 .OR. KU.GT.MAX( 0, NM1 ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( ( MAXMP.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. + $ ( MINMP.EQ.0 .AND. LDB.LT.1 ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.1 .OR. ( LJOBD .AND. LDD.LT.MAXMP ) ) THEN + INFO = -14 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01XZ', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( LJOBD ) THEN +C +C Replace D by D', if non-scalar. +C + DO 5 J = 1, MAXMP + IF ( J.LT.MINMP ) THEN + CALL ZSWAP( MINMP-J, D(J+1,J), 1, D(J,J+1), LDD ) + ELSE IF ( J.GT.P ) THEN + CALL ZCOPY( P, D(1,J), 1, D(J,1), LDD ) + ELSE IF ( J.GT.M ) THEN + CALL ZCOPY( M, D(J,1), LDD, D(1,J), 1 ) + END IF + 5 CONTINUE +C + END IF +C + IF( N.EQ.0 ) + $ RETURN +C +C Replace matrix A by P*A'*P. +C + IF ( KL.EQ.NM1 .AND. KU.EQ.NM1 ) THEN +C +C Full matrix A. +C + DO 10 J = 1, NM1 + CALL ZSWAP( N-J, A( 1, J ), 1, A( N-J+1, J+1 ), -LDA ) + 10 CONTINUE +C + ELSE +C +C Band matrix A. +C + LDA1 = LDA + 1 +C +C Pertranspose the KL subdiagonals. +C + DO 20 J = 1, MIN( KL, N-2 ) + J1 = ( N - J )/2 + CALL ZSWAP( J1, A(J+1,1), LDA1, A(N-J1+1,N-J1+1-J), -LDA1 ) + 20 CONTINUE +C +C Pertranspose the KU superdiagonals. +C + DO 30 J = 1, MIN( KU, N-2 ) + J1 = ( N - J )/2 + CALL ZSWAP( J1, A(1,J+1), LDA1, A(N-J1+1-J,N-J1+1), -LDA1 ) + 30 CONTINUE +C +C Pertranspose the diagonal. +C + J1 = N/2 + CALL ZSWAP( J1, A(1,1), LDA1, A(N-J1+1,N-J1+1), -LDA1 ) +C + END IF +C +C Replace matrix B by P*C' and matrix C by B'*P. +C + DO 40 J = 1, MAXMP + IF ( J.LE.MINMP ) THEN + CALL ZSWAP( N, B(1,J), 1, C(J,1), -LDC ) + ELSE IF ( J.GT.P ) THEN + CALL ZCOPY( N, B(1,J), 1, C(J,1), -LDC ) + ELSE + CALL ZCOPY( N, C(J,1), -LDC, B(1,J), 1 ) + END IF + 40 CONTINUE +C + RETURN +C *** Last line of TB01XZ *** + END diff --git a/mex/sources/libslicot/TB01YD.f b/mex/sources/libslicot/TB01YD.f new file mode 100644 index 000000000..f653ffab5 --- /dev/null +++ b/mex/sources/libslicot/TB01YD.f @@ -0,0 +1,188 @@ + SUBROUTINE TB01YD( N, M, P, A, LDA, B, LDB, C, LDC, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply a special similarity transformation to a system given as +C a triple (A,B,C), +C +C A <-- P * A * P, B <-- P * B, C <-- C * P, +C +C where P is a matrix with 1 on the secondary diagonal, and with 0 +C in the other entries. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A, the number of rows of matrix B +C and the number of columns of matrix C. +C N represents the dimension of the state vector. N >= 0. +C +C M (input) INTEGER. +C The number of columns of matrix B. +C M represents the dimension of input vector. M >= 0. +C +C P (input) INTEGER. +C The number of rows of matrix C. +C P represents the dimension of output vector. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the system state matrix A. +C On exit, the leading N-by-N part of this array contains +C the transformed matrix P*A*P. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the system input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed matrix P*B. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,N) if M > 0. +C LDB >= 1 if M = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the system output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed matrix C*P. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,P). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The rows and/or columns of the matrices of the triplet (A,B,C) +C are swapped in a special way. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Matrix algebra, matrix operations, similarity transformation. +C +C ********************************************************************* +C +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, M, N, P +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) +C .. +C .. Local Scalars .. + INTEGER J, NBY2 +C .. +C .. External Subroutines .. + EXTERNAL DSWAP, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MOD +C .. +C .. Executable Statements .. +C +C Test the scalar input arguments. +C + INFO = 0 +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -9 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01YD', -INFO ) + RETURN + END IF +C + IF( N.LE.1 ) + $ RETURN +C +C Transform the matrix A. +C + NBY2 = N/2 +C + DO 10 J = 1, NBY2 + CALL DSWAP( N, A( 1, J ), -1, A( 1, N-J+1 ), 1 ) + 10 CONTINUE +C + IF( MOD( N, 2 ).NE.0 .AND. N.GT.2 ) + $ CALL DSWAP( NBY2, A( NBY2+2, NBY2+1 ), -1, A( 1, NBY2+1 ), 1 ) +C + IF( M.GT.0 ) THEN +C +C Transform the matrix B. +C + DO 20 J = 1, NBY2 + CALL DSWAP( M, B( J, 1 ), LDB, B( N-J+1, 1 ), LDB ) + 20 CONTINUE +C + END IF +C + IF( P.GT.0 ) THEN +C +C Transform the matrix C. +C + DO 30 J = 1, NBY2 + CALL DSWAP( P, C( 1, J ), 1, C( 1, N-J+1 ), 1 ) + 30 CONTINUE +C + END IF +C + RETURN +C *** Last line of TB01YD *** + END diff --git a/mex/sources/libslicot/TB01ZD.f b/mex/sources/libslicot/TB01ZD.f new file mode 100644 index 000000000..6f8acc3a4 --- /dev/null +++ b/mex/sources/libslicot/TB01ZD.f @@ -0,0 +1,440 @@ + SUBROUTINE TB01ZD( JOBZ, N, P, A, LDA, B, C, LDC, NCONT, Z, LDZ, + $ TAU, TOL, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a controllable realization for the linear time-invariant +C single-input system +C +C dX/dt = A * X + B * U, +C Y = C * X, +C +C where A is an N-by-N matrix, B is an N element vector, C is an +C P-by-N matrix, and A and B are reduced by this routine to +C orthogonal canonical form using (and optionally accumulating) +C orthogonal similarity transformations, which are also applied +C to C. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBZ CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal similarity transformations for +C reducing the system, as follows: +C = 'N': Do not form Z and do not store the orthogonal +C transformations; +C = 'F': Do not form Z, but store the orthogonal +C transformations in the factored form; +C = 'I': Z is initialized to the unit matrix and the +C orthogonal transformation matrix Z is returned. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e. the order of the matrix A. N >= 0. +C +C P (input) INTEGER +C The number of system outputs, or of rows of C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading NCONT-by-NCONT upper Hessenberg +C part of this array contains the canonical form of the +C state dynamics matrix, given by Z' * A * Z, of a +C controllable realization for the original system. The +C elements below the first subdiagonal are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, the original input/state vector B. +C On exit, the leading NCONT elements of this array contain +C canonical form of the input/state vector, given by Z' * B, +C with all elements but B(1) set to zero. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output/state matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed output/state matrix, given by C * Z, and +C the leading P-by-NCONT part contains the output/state +C matrix of the controllable realization. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C NCONT (output) INTEGER +C The order of the controllable state-space representation. +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C If JOBZ = 'I', then the leading N-by-N part of this array +C contains the matrix of accumulated orthogonal similarity +C transformations which reduces the given system to +C orthogonal canonical form. +C If JOBZ = 'F', the elements below the diagonal, with the +C array TAU, represent the orthogonal transformation matrix +C as a product of elementary reflectors. The transformation +C matrix can then be obtained by calling the LAPACK Library +C routine DORGQR. +C If JOBZ = 'N', the array Z is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDZ = 1 and +C declare this array to be Z(1,1) in the calling program). +C +C LDZ INTEGER +C The leading dimension of array Z. If JOBZ = 'I' or +C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The elements of TAU contain the scalar factors of the +C elementary reflectors used in the reduction of B and A. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the +C controllability of (A,B). If the user sets TOL > 0, then +C the given value of TOL is used as an absolute tolerance; +C elements with absolute value less than TOL are considered +C neglijible. If the user sets TOL <= 0, then an implicitly +C computed, default tolerance, defined by +C TOLDEF = N*EPS*MAX( NORM(A), NORM(B) ) is used instead, +C where EPS is the machine precision (see LAPACK Library +C routine DLAMCH). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N,P). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The Householder matrix which reduces all but the first element +C of vector B to zero is found and this orthogonal similarity +C transformation is applied to the matrix A. The resulting A is then +C reduced to upper Hessenberg form by a sequence of Householder +C transformations. Finally, the order of the controllable state- +C space representation (NCONT) is determined by finding the position +C of the first sub-diagonal element of A which is below an +C appropriate zero threshold, either TOL or TOLDEF (see parameter +C TOL); if NORM(B) is smaller than this threshold, NCONT is set to +C zero, and no computations for reducing the system to orthogonal +C canonical form are performed. +C All orthogonal transformations determined in this process are also +C applied to the matrix C, from the right. +C +C REFERENCES +C +C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. +C Orthogonal Invariants and Canonical Forms for Linear +C Controllable Systems. +C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. +C +C [2] Hammarling, S.J. +C Notes on the use of orthogonal similarity transformations in +C control. +C NPL Report DITC 8/82, August 1982. +C +C [3] Paige, C.C +C Properties of numerical algorithms related to computing +C controllability. +C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001, +C Sept. 2003. +C +C KEYWORDS +C +C Controllability, minimal realization, orthogonal canonical form, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBZ + INTEGER INFO, LDA, LDC, LDWORK, LDZ, N, NCONT, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(*), C(LDC,*), DWORK(*), TAU(*), + $ Z(LDZ,*) +C .. Local Scalars .. + LOGICAL LJOBF, LJOBI, LJOBZ + INTEGER ITAU, J + DOUBLE PRECISION ANORM, B1, BNORM, FANORM, FBNORM, H, THRESH, + $ TOLDEF, WRKOPT +C .. Local Arrays .. + DOUBLE PRECISION NBLK(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DGEHRD, DLACPY, DLARF, DLARFG, DLASET, DORGQR, + $ DORMHR, MB01PD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX +C .. Executable Statements .. +C + INFO = 0 + LJOBF = LSAME( JOBZ, 'F' ) + LJOBI = LSAME( JOBZ, 'I' ) + LJOBZ = LJOBF.OR.LJOBI +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -8 + ELSE IF( LDZ.LT.1 .OR. ( LJOBZ .AND. LDZ.LT.N ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.MAX( 1, N, P ) ) THEN + INFO = -15 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01ZD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + NCONT = 0 + DWORK(1) = ONE + IF ( N.EQ.0 ) + $ RETURN +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + WRKOPT = ONE +C +C Calculate the absolute norms of A and B (used for scaling). +C + ANORM = DLANGE( 'Max', N, N, A, LDA, DWORK ) + BNORM = DLANGE( 'Max', N, 1, B, N, DWORK ) +C +C Return if matrix B is zero. +C + IF( BNORM.EQ.ZERO ) THEN + IF( LJOBF ) THEN + CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) + ELSE IF( LJOBI ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) + END IF + RETURN + END IF +C +C Scale (if needed) the matrices A and B. +C + CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO ) + CALL MB01PD( 'S', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) +C +C Calculate the Frobenius norm of A and the 1-norm of B (used for +C controlability test). +C + FANORM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) + FBNORM = DLANGE( '1-norm', N, 1, B, N, DWORK ) +C + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance in controllability determination. +C + THRESH = DBLE(N)*DLAMCH( 'EPSILON' ) + TOLDEF = THRESH*MAX( FANORM, FBNORM ) + END IF +C + ITAU = 1 + IF ( FBNORM.GT.TOLDEF ) THEN +C +C B is not negligible compared with A. +C + IF ( N.GT.1 ) THEN +C +C Transform B by a Householder matrix Z1: store vector +C describing this temporarily in B and in the local scalar H. +C + CALL DLARFG( N, B(1), B(2), 1, H ) +C + B1 = B(1) + B(1) = ONE +C +C Form Z1 * A * Z1. +C Workspace: need N. +C + CALL DLARF( 'Right', N, N, B, 1, H, A, LDA, DWORK ) + CALL DLARF( 'Left', N, N, B, 1, H, A, LDA, DWORK ) +C +C Form C * Z1. +C Workspace: need P. +C + CALL DLARF( 'Right', P, N, B, 1, H, C, LDC, DWORK ) +C + B(1) = B1 + TAU(1) = H + ITAU = ITAU + 1 + ELSE + B1 = B(1) + TAU(1) = ZERO + END IF +C +C Reduce modified A to upper Hessenberg form by an orthogonal +C similarity transformation with matrix Z2. +C Workspace: need N; prefer N*NB. +C + CALL DGEHRD( N, 1, N, A, LDA, TAU(ITAU), DWORK, LDWORK, INFO ) + WRKOPT = DWORK(1) +C +C Form C * Z2. +C Workspace: need P; prefer P*NB. +C + CALL DORMHR( 'Right', 'No transpose', P, N, 1, N, A, LDA, + $ TAU(ITAU), C, LDC, DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, DWORK(1) ) +C + IF ( LJOBZ ) THEN +C +C Save the orthogonal transformations used, so that they could +C be accumulated by calling DORGQR routine. +C + IF ( N.GT.1 ) + $ CALL DLACPY( 'Full', N-1, 1, B(2), N-1, Z(2,1), LDZ ) + IF ( N.GT.2 ) + $ CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA, Z(3,2), + $ LDZ ) + IF ( LJOBI ) THEN +C +C Form the orthogonal transformation matrix Z = Z1 * Z2. +C Workspace: need N; prefer N*NB. +C + CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, DWORK(1) ) + END IF + END IF +C +C Annihilate the lower part of A and B. +C + IF ( N.GT.2 ) + $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) + IF ( N.GT.1 ) + $ CALL DLASET( 'Full', N-1, 1, ZERO, ZERO, B(2), N-1 ) +C +C Find NCONT by checking sizes of the sub-diagonal elements of +C transformed A. +C + IF ( TOL.LE.ZERO ) + $ TOLDEF = THRESH*MAX( FANORM, ABS( B1 ) ) +C + J = 1 +C +C WHILE ( J < N and ABS( A(J+1,J) ) > TOLDEF ) DO +C + 10 CONTINUE + IF ( J.LT.N ) THEN + IF ( ABS( A(J+1,J) ).GT.TOLDEF ) THEN + J = J + 1 + GO TO 10 + END IF + END IF +C +C END WHILE 10 +C +C First negligible sub-diagonal element found, if any: set NCONT. +C + NCONT = J + IF ( J.LT.N ) + $ A(J+1,J) = ZERO +C +C Undo scaling of A and B. +C + CALL MB01PD( 'U', 'H', NCONT, NCONT, 0, 0, ANORM, 0, NBLK, A, + $ LDA, INFO ) + CALL MB01PD( 'U', 'G', 1, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) + IF ( NCONT.LT.N ) + $ CALL MB01PD( 'U', 'G', N, N-NCONT, 0, 0, ANORM, 0, NBLK, + $ A(1,NCONT+1), LDA, INFO ) + ELSE +C +C B is negligible compared with A. No computations for reducing +C the system to orthogonal canonical form have been performed, +C except scaling (which is undoed). +C + CALL MB01PD( 'U', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, + $ INFO ) + CALL MB01PD( 'U', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) + IF( LJOBF ) THEN + CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) + ELSE IF( LJOBI ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) + END IF + END IF +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of TB01ZD *** + END diff --git a/mex/sources/libslicot/TB03AD.f b/mex/sources/libslicot/TB03AD.f new file mode 100644 index 000000000..318c2f323 --- /dev/null +++ b/mex/sources/libslicot/TB03AD.f @@ -0,0 +1,746 @@ + SUBROUTINE TB03AD( LERI, EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, + $ D, LDD, NR, INDEX, PCOEFF, LDPCO1, LDPCO2, + $ QCOEFF, LDQCO1, LDQCO2, VCOEFF, LDVCO1, LDVCO2, + $ TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a relatively prime left polynomial matrix representation +C inv(P(s))*Q(s) or right polynomial matrix representation +C Q(s)*inv(P(s)) with the same transfer matrix T(s) as that of a +C given state-space representation, i.e. +C +C inv(P(s))*Q(s) = Q(s)*inv(P(s)) = T(s) = C*inv(s*I-A)*B + D. +C +C ARGUMENTS +C +C Mode Parameters +C +C LERI CHARACTER*1 +C Indicates whether the left polynomial matrix +C representation or the right polynomial matrix +C representation is required as follows: +C = 'L': A left matrix fraction is required; +C = 'R': A right matrix fraction is required. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to balance the triplet +C (A,B,C), before computing a minimal state-space +C representation, as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation, i.e. the +C order of the original state dynamics matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading NR-by-NR part of this array contains +C the upper block Hessenberg state dynamics matrix Amin of a +C minimal realization for the original system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,MAX(M,P)) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B; the remainder +C of the leading N-by-MAX(M,P) part is used as internal +C workspace. +C On exit, the leading NR-by-M part of this array contains +C the transformed input/state matrix Bmin. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C; the remainder +C of the leading MAX(M,P)-by-N part is used as internal +C workspace. +C On exit, the leading P-by-NR part of this array contains +C the transformed state/output matrix Cmin. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) +C The leading P-by-M part of this array must contain the +C original direct transmission matrix D; the remainder of +C the leading MAX(M,P)-by-MAX(M,P) part is used as internal +C workspace. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,M,P). +C +C NR (output) INTEGER +C The order of the minimal state-space representation +C (Amin,Bmin,Cmin). +C +C INDEX (output) INTEGER array, dimension (P), if LERI = 'L', or +C dimension (M), if LERI = 'R'. +C If LERI = 'L', INDEX(I), I = 1,2,...,P, contains the +C maximum degree of the polynomials in the I-th row of the +C denominator matrix P(s) of the left polynomial matrix +C representation. +C These elements are ordered so that +C INDEX(1) >= INDEX(2) >= ... >= INDEX(P). +C If LERI = 'R', INDEX(I), I = 1,2,...,M, contains the +C maximum degree of the polynomials in the I-th column of +C the denominator matrix P(s) of the right polynomial +C matrix representation. +C These elements are ordered so that +C INDEX(1) >= INDEX(2) >= ... >= INDEX(M). +C +C PCOEFF (output) DOUBLE PRECISION array, dimension +C (LDPCO1,LDPCO2,N+1) +C If LERI = 'L' then porm = P, otherwise porm = M. +C The leading porm-by-porm-by-kpcoef part of this array +C contains the coefficients of the denominator matrix P(s), +C where kpcoef = MAX(INDEX(I)) + 1. +C PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) +C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if +C LERI = 'L' then iorj = I, otherwise iorj = J. +C Thus for LERI = 'L', P(s) = +C diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). +C +C LDPCO1 INTEGER +C The leading dimension of array PCOEFF. +C LDPCO1 >= MAX(1,P), if LERI = 'L'; +C LDPCO1 >= MAX(1,M), if LERI = 'R'. +C +C LDPCO2 INTEGER +C The second dimension of array PCOEFF. +C LDPCO2 >= MAX(1,P), if LERI = 'L'; +C LDPCO2 >= MAX(1,M), if LERI = 'R'. +C +C QCOEFF (output) DOUBLE PRECISION array, dimension +C (LDQCO1,LDQCO2,N+1) +C If LERI = 'L' then porp = M, otherwise porp = P. +C If LERI = 'L', the leading porm-by-porp-by-kpcoef part +C of this array contains the coefficients of the numerator +C matrix Q(s). +C If LERI = 'R', the leading porp-by-porm-by-kpcoef part +C of this array contains the coefficients of the numerator +C matrix Q(s). +C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). +C +C LDQCO1 INTEGER +C The leading dimension of array QCOEFF. +C LDQCO1 >= MAX(1,P), if LERI = 'L'; +C LDQCO1 >= MAX(1,M,P), if LERI = 'R'. +C +C LDQCO2 INTEGER +C The second dimension of array QCOEFF. +C LDQCO2 >= MAX(1,M), if LERI = 'L'; +C LDQCO2 >= MAX(1,M,P), if LERI = 'R'. +C +C VCOEFF (output) DOUBLE PRECISION array, dimension +C (LDVCO1,LDVCO2,N+1) +C The leading porm-by-NR-by-kpcoef part of this array +C contains the coefficients of the intermediate matrix V(s). +C VCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). +C +C LDVCO1 INTEGER +C The leading dimension of array VCOEFF. +C LDVCO1 >= MAX(1,P), if LERI = 'L'; +C LDVCO1 >= MAX(1,M), if LERI = 'R'. +C +C LDVCO2 INTEGER +C The second dimension of array VCOEFF. LDVCO2 >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determination when +C transforming (A, B, C). If the user sets TOL > 0, then +C the given value of TOL is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance +C (determined by the SLICOT routine TB01UD) is used instead. +C +C Workspace +C +C IWORK INTEGER array, dimension (N+MAX(M,P)) +C On exit, if INFO = 0, the first nonzero elements of +C IWORK(1:N) return the orders of the diagonal blocks of A. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P), PM*(PM + 2)) +C where PM = P, if LERI = 'L'; +C PM = M, if LERI = 'R'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if a singular matrix was encountered during the +C computation of V(s); +C = 2: if a singular matrix was encountered during the +C computation of P(s). +C +C METHOD +C +C The method for a left matrix fraction will be described here: +C right matrix fractions are dealt with by constructing a left +C fraction for the dual of the original system. The first step is to +C obtain, by means of orthogonal similarity transformations, a +C minimal state-space representation (Amin,Bmin,Cmin,D) for the +C original system (A,B,C,D), where Amin is lower block Hessenberg +C with all its superdiagonal blocks upper triangular and Cmin has +C all but its first rank(C) columns zero. The number and dimensions +C of the blocks of Amin now immediately yield the row degrees of +C P(s) with P(s) row proper: furthermore, the P-by-NR polynomial +C matrix V(s) (playing a similar role to S(s) in Wolovich's +C Structure Theorem) can be calculated a column block at a time, in +C reverse order, from Amin. P(s) is then found as if it were the +C O-th column block of V(s) (using Cmin as well as Amin), while +C Q(s) = (V(s) * Bmin) + (P(s) * D). Finally, a special similarity +C transformation is used to put Amin in an upper block Hessenberg +C form. +C +C REFERENCES +C +C [1] Williams, T.W.C. +C An Orthogonal Structure Theorem for Linear Systems. +C Kingston Polytechnic Control Systems Research Group, +C Internal Report 82/2, July 1982. +C +C [2] Patel, R.V. +C On Computing Matrix Fraction Descriptions and Canonical +C Forms of Linear Time-Invariant Systems. +C UMIST Control Systems Centre Report 489, 1980. +C (Algorithms 1 and 2, extensively modified). +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, March 1998. +C Supersedes Release 3.0 routine TB01SD. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2000. +C +C KEYWORDS +C +C Canonical form, coprime matrix fraction, dual system, elementary +C polynomial operations, Hessenberg form, minimal realization, +C orthogonal transformation, polynomial matrix, state-space +C representation, transfer matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL, LERI + INTEGER INFO, LDA, LDB, LDC, LDD, LDPCO1, LDPCO2, + $ LDQCO1, LDQCO2, LDVCO1, LDVCO2, LDWORK, M, N, + $ NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER INDEX(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), PCOEFF(LDPCO1,LDPCO2,*), + $ QCOEFF(LDQCO1,LDQCO2,*), VCOEFF(LDVCO1,LDVCO2,*) +C .. Local Scalars .. + LOGICAL LEQUIL, LLERIL, LLERIR + INTEGER I, IC, IFIRST, INDBLK, INPLUS, IOFF, IRANKC, + $ ISTART, ISTOP, ITAU, IZ, JOFF, JWORK, K, KMAX, + $ KPCOEF, KPLUS, KWORK, LDWRIC, MAXMP, MPLIM, + $ MWORK, NCOL, NCONT, NREFLC, NROW, PWORK, WRKOPT + DOUBLE PRECISION MAXRED +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB07MD, DGEMM, DGEQRF, DGETRF, DLACPY, DLASET, + $ DORMQR, DTRSM, MA02GD, TB01ID, TB01UD, TB01YD, + $ TB03AY, TC01OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + INFO = 0 + LLERIL = LSAME( LERI, 'L' ) + LLERIR = LSAME( LERI, 'R' ) + LEQUIL = LSAME( EQUIL, 'S' ) + MAXMP = MAX( M, P ) + MPLIM = MAX( 1, MAXMP ) + IF ( LLERIR ) THEN +C +C Initialization for right matrix fraction. +C + PWORK = M + MWORK = P + ELSE +C +C Initialization for left matrix fraction. +C + PWORK = P + MWORK = M + END IF +C +C Test the input scalar arguments. +C + IF( .NOT.LLERIL .AND. .NOT.LLERIR ) THEN + INFO = -1 + ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MPLIM ) THEN + INFO = -11 + ELSE IF( LDD.LT.MPLIM ) THEN + INFO = -13 + ELSE IF( LDPCO1.LT.MAX( 1, PWORK ) ) THEN + INFO = -17 + ELSE IF( LDPCO2.LT.MAX( 1, PWORK ) ) THEN + INFO = -18 + ELSE IF( LDQCO1.LT.MAX( 1, PWORK ) .OR. LLERIR .AND. + $ LDQCO1.LT.MPLIM ) THEN + INFO = -20 + ELSE IF( LDQCO2.LT.MAX( 1, MWORK ) .OR. LLERIR .AND. + $ LDQCO2.LT.MPLIM ) THEN + INFO = -21 + ELSE IF( LDVCO1.LT.MAX( 1, PWORK ) ) THEN + INFO = -23 + ELSE IF( LDVCO2.LT.MAX( 1, N ) ) THEN + INFO = -24 + ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*MAXMP ), + $ PWORK*( PWORK + 2 ) ) ) THEN + INFO = -28 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB03AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, M, P ).EQ.0 ) THEN + NR = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF ( LLERIR ) THEN +C +C For right matrix fraction, obtain dual system. +C + CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ INFO ) + END IF +C +C Obtain minimal realization, in canonical form, for this system. +C Part of the code in SLICOT routine TB01PD is included in-line +C here. (TB01PD cannot be directly used.) +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C +C If required, balance the triplet (A,B,C) (default MAXRED). +C Workspace: need N. +C + IF ( LEQUIL ) THEN + MAXRED = ZERO + CALL TB01ID( 'A', N, MWORK, PWORK, MAXRED, A, LDA, B, LDB, C, + $ LDC, DWORK, INFO ) + END IF +C + IZ = 1 + ITAU = 1 + JWORK = ITAU + N +C +C Separate out controllable subsystem (of order NCONT): +C A <-- Z'*A*Z, B <-- Z'*B, C <-- C*Z. +C +C Workspace: need N + MAX(N, 3*MWORK, PWORK). +C prefer larger. +C + CALL TB01UD( 'No Z', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, + $ NCONT, INDBLK, IWORK, DWORK(IZ), 1, DWORK(ITAU), TOL, + $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 +C +C Separate out the observable subsystem (of order NR): +C Form the dual of the subsystem of order NCONT (which is +C controllable), leaving rest as it is. +C + CALL AB07MD( 'Z', NCONT, MWORK, PWORK, A, LDA, B, LDB, C, LDC, + $ DWORK, 1, INFO ) +C +C And separate out the controllable part of this dual subsystem. +C +C Workspace: need NCONT + MAX(NCONT, 3*PWORK, MWORK). +C prefer larger. +C + CALL TB01UD( 'No Z', NCONT, PWORK, MWORK, A, LDA, B, LDB, C, LDC, + $ NR, INDBLK, IWORK, DWORK(IZ), 1, DWORK(ITAU), TOL, + $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Retranspose, giving controllable and observable (i.e. minimal) +C part of original system. +C + CALL AB07MD( 'Z', NR, PWORK, MWORK, A, LDA, B, LDB, C, LDC, DWORK, + $ 1, INFO ) +C +C Annihilate the trailing components of IWORK(1:N). +C + DO 10 I = INDBLK + 1, N + IWORK(I) = 0 + 10 CONTINUE +C +C Initialize polynomial matrices P(s), Q(s) and V(s) to zero. +C + DO 20 K = 1, N + 1 + CALL DLASET( 'Full', PWORK, PWORK, ZERO, ZERO, PCOEFF(1,1,K), + $ LDPCO1 ) + CALL DLASET( 'Full', PWORK, MWORK, ZERO, ZERO, QCOEFF(1,1,K), + $ LDQCO1 ) + CALL DLASET( 'Full', PWORK, NR, ZERO, ZERO, VCOEFF(1,1,K), + $ LDVCO1 ) + 20 CONTINUE +C +C Finish initializing V(s), and set up row degrees of P(s). +C + INPLUS = INDBLK + 1 + ISTART = 1 + JOFF = NR +C + DO 40 K = 1, INDBLK + KWORK = INPLUS - K + KPLUS = KWORK + 1 + ISTOP = IWORK(KWORK) + JOFF = JOFF - ISTOP +C + DO 30 I = ISTART, ISTOP + INDEX(I) = KWORK + VCOEFF(I,JOFF+I,KPLUS) = ONE + 30 CONTINUE +C + ISTART = ISTOP + 1 + 40 CONTINUE +C +C ISTART = IWORK(1)+1 now: if .LE. PWORK, set up final rows of P(s). +C + DO 50 I = ISTART, PWORK + INDEX(I) = 0 + PCOEFF(I,I,1) = ONE + 50 CONTINUE +C +C Triangularize the superdiagonal blocks of Amin. +C + NROW = IWORK(INDBLK) + IOFF = NR - NROW + KMAX = INDBLK - 1 + ITAU = 1 + IFIRST = 0 + IF ( INDBLK.GT.2 ) IFIRST = IOFF - IWORK(KMAX) +C +C QR decomposition of each superdiagonal block of A in turn +C (done in reverse order to preserve upper triangular blocks in A). +C + DO 60 K = 1, KMAX +C +C Calculate dimensions of new block & its position in A. +C + KWORK = INDBLK - K + NCOL = NROW + NROW = IWORK(KWORK) + JOFF = IOFF + IOFF = IOFF - NROW + NREFLC = MIN( NROW, NCOL ) + JWORK = ITAU + NREFLC + IF ( KWORK.GE.2 ) IFIRST = IFIRST - IWORK(KWORK-1) +C +C Find QR decomposition of this (full rank) block: +C block = QR. No pivoting is needed. +C +C Workspace: need MIN(NROW,NCOL) + NCOL; +C prefer MIN(NROW,NCOL) + NCOL*NB. +C + CALL DGEQRF( NROW, NCOL, A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Premultiply appropriate row block of A by Q'. +C +C Workspace: need MIN(NROW,NCOL) + JOFF; +C prefer MIN(NROW,NCOL) + JOFF*NB. +C + CALL DORMQR( 'Left', 'Transpose', NROW, JOFF, NREFLC, + $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), A(IOFF+1,1), + $ LDA, DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Premultiply appropriate row block of B by Q' also. +C +C Workspace: need MIN(NROW,NCOL) + MWORK; +C prefer MIN(NROW,NCOL) + MWORK*NB. +C + CALL DORMQR( 'Left', 'Transpose', NROW, MWORK, NREFLC, + $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), B(IOFF+1,1), + $ LDB, DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C And postmultiply the non-zero part of appropriate column +C block of A by Q. +C +C Workspace: need MIN(NROW,NCOL) + NR; +C prefer MIN(NROW,NCOL) + NR*NB. +C + CALL DORMQR( 'Right', 'No Transpose', NR-IFIRST, NROW, NREFLC, + $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), + $ A(IFIRST+1,IOFF+1), LDA, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Annihilate the lower triangular part of the block in A. +C + IF ( K.NE.KMAX .AND. NROW.GT.1 ) + $ CALL DLASET( 'Lower', NROW-1, NCOL, ZERO, ZERO, + $ A(IOFF+2,JOFF+1), LDA ) +C + 60 CONTINUE +C +C Finally: postmultiply non-zero columns of C by Q (K = KMAX). +C +C Workspace: need MIN(NROW,NCOL) + PWORK; +C prefer MIN(NROW,NCOL) + PWORK*NB. +C + CALL DORMQR( 'Right', 'No Transpose', PWORK, NROW, NREFLC, + $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), C, LDC, + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Annihilate the lower triangular part of the block in A. +C + IF ( NROW.GT.1 ) + $ CALL DLASET( 'Lower', NROW-1, NCOL, ZERO, ZERO, + $ A(IOFF+2,JOFF+1), LDA ) +C +C Calculate the (PWORK x NR) polynomial matrix V(s) ... +C + CALL TB03AY( NR, A, LDA, INDBLK, IWORK, VCOEFF, LDVCO1, LDVCO2, + $ PCOEFF, LDPCO1, LDPCO2, INFO) +C + IF ( INFO.NE.0 ) THEN + INFO = 1 + RETURN + ELSE +C +C And then use this matrix to calculate P(s): first store +C C1 from C. +C + IC = 1 + IRANKC = IWORK(1) + LDWRIC = MAX( 1, PWORK ) + CALL DLACPY( 'Full', PWORK, IRANKC, C, LDC, DWORK(IC), LDWRIC ) +C + IF ( IRANKC.LT.PWORK ) THEN +C +C rank(C) .LT. PWORK: obtain QR decomposition of C1, +C giving R and Q. +C +C Workspace: need PWORK*IRANKC + 2*IRANKC; +C prefer PWORK*IRANKC + IRANKC + IRANKC*NB. +C + ITAU = IC + LDWRIC*IRANKC + JWORK = ITAU + IRANKC +C + CALL DGEQRF( PWORK, IRANKC, DWORK(IC), LDWRIC, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C First IRANKC rows of Pbar(s) are given by Wbar(s) * inv(R). +C Check for zero diagonal elements of R. +C + DO 70 I = 1, IRANKC + IF ( DWORK(IC+(I-1)*LDWRIC+I-1).EQ.ZERO ) THEN +C +C Error return. +C + INFO = 2 + RETURN + END IF + 70 CONTINUE +C + NROW = IRANKC +C + DO 80 K = 1, INPLUS + CALL DTRSM( 'Right', 'Upper', 'No Transpose', 'Non-unit', + $ NROW, IRANKC, ONE, DWORK(IC), LDWRIC, + $ PCOEFF(1,1,K), LDPCO1 ) + NROW = IWORK(K) + 80 CONTINUE +C +C P(s) itself is now given by Pbar(s) * Q'. +C + NROW = PWORK +C + DO 90 K = 1, INPLUS +C +C Workspace: need PWORK*IRANKC + IRANKC + NROW; +C prefer PWORK*IRANKC + IRANKC + NROW*NB. +C + CALL DORMQR( 'Right', 'Transpose', NROW, PWORK, IRANKC, + $ DWORK(IC), LDWRIC, DWORK(ITAU), + $ PCOEFF(1,1,K), LDPCO1, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) + NROW = IWORK(K) + 90 CONTINUE +C + ELSE +C +C Special case rank(C) = PWORK, full: +C no QR decomposition (P(s)=Wbar(s)*inv(C1)). +C + CALL DGETRF( PWORK, PWORK, DWORK(IC), LDWRIC, IWORK(N+1), + $ INFO ) +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + INFO = 2 + RETURN + ELSE +C + NROW = IRANKC +C +C Workspace: need PWORK*IRANKC + N. +C + DO 100 K = 1, INPLUS + CALL DTRSM( 'Right', 'Upper', 'No Transpose', + $ 'Non-unit', NROW, PWORK, ONE, DWORK(IC), + $ LDWRIC, PCOEFF(1,1,K), LDPCO1 ) + CALL DTRSM( 'Right', 'Lower', 'No Transpose', 'Unit', + $ NROW, PWORK, ONE, DWORK(IC), LDWRIC, + $ PCOEFF(1,1,K), LDPCO1 ) + CALL MA02GD( NROW, PCOEFF(1,1,K), LDPCO1, 1, PWORK, + $ IWORK(N+1), -1 ) + NROW = IWORK(K) + 100 CONTINUE + END IF + END IF +C +C Finally, Q(s) = V(s) * B + P(s) * D can now be evaluated. +C + NROW = PWORK +C + DO 110 K = 1, INPLUS + CALL DGEMM( 'No transpose', 'No transpose', NROW, MWORK, + $ NR, ONE, VCOEFF(1,1,K), LDVCO1, B, LDB, ZERO, + $ QCOEFF(1,1,K), LDQCO1 ) + CALL DGEMM( 'No transpose', 'No transpose', NROW, MWORK, + $ PWORK, ONE, PCOEFF(1,1,K), LDPCO1, D, LDD, ONE, + $ QCOEFF(1,1,K), LDQCO1 ) + NROW = IWORK(K) + 110 CONTINUE +C + END IF +C + IF ( LLERIR ) THEN +C +C For right matrix fraction, return to original (dual of dual) +C system. +C + CALL AB07MD( 'Z', NR, MWORK, PWORK, A, LDA, B, LDB, C, LDC, + $ DWORK, 1, INFO ) +C +C Also, obtain the dual of the polynomial matrix representation. +C + KPCOEF = 0 +C + DO 120 I = 1, PWORK + KPCOEF = MAX( KPCOEF, INDEX(I) ) + 120 CONTINUE +C + KPCOEF = KPCOEF + 1 + CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, + $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO ) + ELSE +C +C Reorder the rows and columns of the system, to get an upper +C block Hessenberg matrix A of the minimal system. +C + CALL TB01YD( NR, M, P, A, LDA, B, LDB, C, LDC, INFO ) + END IF +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of TB03AD *** + END diff --git a/mex/sources/libslicot/TB03AY.f b/mex/sources/libslicot/TB03AY.f new file mode 100644 index 000000000..eeffc6e23 --- /dev/null +++ b/mex/sources/libslicot/TB03AY.f @@ -0,0 +1,159 @@ + SUBROUTINE TB03AY( NR, A, LDA, INDBLK, NBLK, VCOEFF, LDVCO1, + $ LDVCO2, PCOEFF, LDPCO1, LDPCO2, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate the (PWORK-by-NR) polynomial matrix V(s) one +C (PWORK-by-NBLK(L-1)) block V:L-1(s) at a time, in reverse order +C (L = INDBLK,...,1). At each stage, the (NBLK(L)-by-NBLK(L)) poly- +C nomial matrix W(s) = V2(s) * A2 is formed, where V2(s) is that +C part of V(s) already computed and A2 is the subdiagonal (incl.) +C part of the L-th column block of A; W(s) is temporarily stored in +C the top left part of P(s), as is subsequently the further matrix +C Wbar(s) = s * V:L(s) - W(s). Then, except for the final stage +C L = 1 (when the next step is to calculate P(s) itself, not here), +C the top left part of V:L-1(s) is given by Wbar(s) * inv(R), where +C R is the upper triangular part of the L-th superdiagonal block of +C A. Finally, note that the coefficient matrices W(.,.,K) can only +C be non-zero for K = L + 1,...,INPLUS, with each of these matrices +C having only its first NBLK(L-1) rows non-trivial. Similarly, +C Wbar(.,.,K) (and so clearly V:L-1(.,.,K) ) can only be non-zero +C for K = L,...,INPLUS, with each of these having only its first +C NBLK(K-1) rows non-trivial except for K = L, which has NBLK(L) +C such rows. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Coprime matrix fraction, elementary polynomial operations, +C polynomial matrix, state-space representation, transfer matrix. +C +C NOTE: In the interests of speed, this routine does not check the +C inputs for errors. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INDBLK, INFO, LDA, LDPCO1, LDPCO2, LDVCO1, + $ LDVCO2, NR +C .. Array Arguments .. + INTEGER NBLK(*) + DOUBLE PRECISION A(LDA,*), PCOEFF(LDPCO1,LDPCO2,*), + $ VCOEFF(LDVCO1,LDVCO2,*) +C .. Local Scalars .. + INTEGER I, INPLUS, IOFF, J, JOFF, K, KPLUS, L, LSTART, + $ LSTOP, LWORK, NCOL, NROW +C .. External Subroutines .. + EXTERNAL DAXPY, DGEMM, DLACPY, DSCAL, DTRSM +C .. Executable Statements .. +C + INFO = 0 + INPLUS = INDBLK + 1 + JOFF = NR +C +C Calculate each column block V:LWORK-1(s) of V(s) in turn. +C + DO 70 L = 1, INDBLK + LWORK = INPLUS - L +C +C Determine number of columns of V:LWORK(s) & its position in V. +C + NCOL = NBLK(LWORK) + JOFF = JOFF - NCOL +C +C Find limits for V2(s) * A2 calculation: skips zero rows +C in V(s). +C + LSTART = JOFF + 1 + LSTOP = JOFF +C +C Calculate W(s) and store (temporarily) in top left part +C of P(s). +C + DO 10 K = LWORK + 1, INPLUS + NROW = NBLK(K-1) + LSTOP = LSTOP + NROW + CALL DGEMM( 'No transpose', 'No transpose', NROW, NCOL, + $ LSTOP-LSTART+1, ONE, VCOEFF(1,LSTART,K), LDVCO1, + $ A(LSTART,JOFF+1), LDA, ZERO, PCOEFF(1,1,K), + $ LDPCO1 ) + 10 CONTINUE +C +C Replace W(s) by Wbar(s) = s * V:L(s) - W(s). +C + NROW = NCOL +C + DO 30 K = LWORK, INDBLK + KPLUS = K + 1 +C + DO 20 J = 1, NCOL + CALL DSCAL( NROW, -ONE, PCOEFF(1,J,K), 1 ) + CALL DAXPY( NROW, ONE, VCOEFF(1,JOFF+J,KPLUS), 1, + $ PCOEFF(1,J,K), 1 ) + 20 CONTINUE +C + NROW = NBLK(K) + 30 CONTINUE +C + DO 40 J = 1, NCOL + CALL DSCAL( NROW, -ONE, PCOEFF(1,J,INPLUS), 1 ) + 40 CONTINUE +C + IF ( LWORK.NE.1 ) THEN +C +C If not final stage, use the upper triangular R (from A) +C to calculate V:L-1(s), finally storing this new block. +C + IOFF = JOFF - NBLK(LWORK-1) +C + DO 50 I = 1, NCOL + IF ( A(IOFF+I,JOFF+I).EQ.ZERO ) THEN +C +C Error return. +C + INFO = I + RETURN + END IF + 50 CONTINUE +C + NROW = NBLK(LWORK) +C + DO 60 K = LWORK, INPLUS + CALL DLACPY( 'Full', NROW, NCOL, PCOEFF(1,1,K), LDPCO1, + $ VCOEFF(1,IOFF+1,K), LDVCO1 ) + CALL DTRSM( 'Right', 'Upper', 'No Transpose', 'Non-unit', + $ NROW, NCOL, ONE, A(IOFF+1,JOFF+1), LDA, + $ VCOEFF(1,IOFF+1,K), LDVCO1 ) + NROW = NBLK(K) + 60 CONTINUE +C + END IF + 70 CONTINUE +C + RETURN +C *** Last line of TB03AY *** + END diff --git a/mex/sources/libslicot/TB04AD.f b/mex/sources/libslicot/TB04AD.f new file mode 100644 index 000000000..d864d1914 --- /dev/null +++ b/mex/sources/libslicot/TB04AD.f @@ -0,0 +1,395 @@ + SUBROUTINE TB04AD( ROWCOL, N, M, P, A, LDA, B, LDB, C, LDC, D, + $ LDD, NR, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1, + $ LDUCO2, TOL1, TOL2, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find the transfer matrix T(s) of a given state-space +C representation (A,B,C,D). T(s) is expressed as either row or +C column polynomial vectors over monic least common denominator +C polynomials. +C +C ARGUMENTS +C +C Mode Parameters +C +C ROWCOL CHARACTER*1 +C Indicates whether the transfer matrix T(s) is required +C as rows or columns over common denominators as follows: +C = 'R': T(s) is required as rows over common denominators; +C = 'C': T(s) is required as columns over common +C denominators. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation, i.e. the +C order of the original state dynamics matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading NR-by-NR part of this array contains +C the upper block Hessenberg state dynamics matrix A of a +C transformed representation for the original system: this +C is completely controllable if ROWCOL = 'R', or completely +C observable if ROWCOL = 'C'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M), +C if ROWCOL = 'R', and (LDB,MAX(M,P)) if ROWCOL = 'C'. +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B; if +C ROWCOL = 'C', the remainder of the leading N-by-MAX(M,P) +C part is used as internal workspace. +C On exit, the leading NR-by-M part of this array contains +C the transformed input/state matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C; if +C ROWCOL = 'C', the remainder of the leading MAX(M,P)-by-N +C part is used as internal workspace. +C On exit, the leading P-by-NR part of this array contains +C the transformed state/output matrix C. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,P) if ROWCOL = 'R'; +C LDC >= MAX(1,M,P) if ROWCOL = 'C'. +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M), +C if ROWCOL = 'R', and (LDD,MAX(M,P)) if ROWCOL = 'C'. +C The leading P-by-M part of this array must contain the +C original direct transmission matrix D; if ROWCOL = 'C', +C this array is modified internally, but restored on exit, +C and the remainder of the leading MAX(M,P)-by-MAX(M,P) +C part is used as internal workspace. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P) if ROWCOL = 'R'; +C LDD >= MAX(1,M,P) if ROWCOL = 'C'. +C +C NR (output) INTEGER +C The order of the transformed state-space representation. +C +C INDEX (output) INTEGER array, dimension (porm), where porm = P, +C if ROWCOL = 'R', and porm = M, if ROWCOL = 'C'. +C The degrees of the denominator polynomials. +C +C DCOEFF (output) DOUBLE PRECISION array, dimension (LDDCOE,N+1) +C The leading porm-by-kdcoef part of this array contains +C the coefficients of each denominator polynomial, where +C kdcoef = MAX(INDEX(I)) + 1. +C DCOEFF(I,K) is the coefficient in s**(INDEX(I)-K+1) of +C the I-th denominator polynomial, where K = 1,2,...,kdcoef. +C +C LDDCOE INTEGER +C The leading dimension of array DCOEFF. +C LDDCOE >= MAX(1,P) if ROWCOL = 'R'; +C LDDCOE >= MAX(1,M) if ROWCOL = 'C'. +C +C UCOEFF (output) DOUBLE PRECISION array, dimension +C (LDUCO1,LDUCO2,N+1) +C If ROWCOL = 'R' then porp = M, otherwise porp = P. +C The leading porm-by-porp-by-kdcoef part of this array +C contains the coefficients of the numerator matrix U(s). +C UCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) +C of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef; +C if ROWCOL = 'R' then iorj = I, otherwise iorj = J. +C Thus for ROWCOL = 'R', U(s) = +C diag(s**INDEX(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...). +C +C LDUCO1 INTEGER +C The leading dimension of array UCOEFF. +C LDUCO1 >= MAX(1,P) if ROWCOL = 'R'; +C LDUCO1 >= MAX(1,M) if ROWCOL = 'C'. +C +C LDUCO2 INTEGER +C The second dimension of array UCOEFF. +C LDUCO2 >= MAX(1,M) if ROWCOL = 'R'; +C LDUCO2 >= MAX(1,P) if ROWCOL = 'C'. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C The tolerance to be used in determining the i-th row of +C T(s), where i = 1,2,...,porm. If the user sets TOL1 > 0, +C then the given value of TOL1 is used as an absolute +C tolerance; elements with absolute value less than TOL1 are +C considered neglijible. If the user sets TOL1 <= 0, then +C an implicitly computed, default tolerance, defined in +C the SLICOT Library routine TB01ZD, is used instead. +C +C TOL2 DOUBLE PRECISION +C The tolerance to be used to separate out a controllable +C subsystem of (A,B,C). If the user sets TOL2 > 0, then +C the given value of TOL2 is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL2 is considered to be of full rank. If the user sets +C TOL2 <= 0, then an implicitly computed, default tolerance, +C defined in the SLICOT Library routine TB01UD, is used +C instead. +C +C Workspace +C +C IWORK DOUBLE PRECISION array, dimension (N+MAX(M,P)) +C On exit, if INFO = 0, the first nonzero elements of +C IWORK(1:N) return the orders of the diagonal blocks of A. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N*(N + 1) + MAX(N*MP + 2*N + MAX(N,MP), +C 3*MP, PM)), +C where MP = M, PM = P, if ROWCOL = 'R'; +C MP = P, PM = M, if ROWCOL = 'C'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The method for transfer matrices factorized by rows will be +C described here: T(s) factorized by columns is dealt with by +C operating on the dual of the original system. Each row of +C T(s) is simply a single-output relatively left prime polynomial +C matrix representation, so can be calculated by applying a +C simplified version of the Orthogonal Structure Theorem to a +C minimal state-space representation for the corresponding row of +C the given system. A minimal state-space representation is obtained +C using the Orthogonal Canonical Form to first separate out a +C completely controllable one for the overall system and then, for +C each row in turn, applying it again to the resulting dual SIMO +C (single-input multi-output) system. Note that the elements of the +C transformed matrix A so calculated are individually scaled in a +C way which guarantees a monic denominator polynomial. +C +C REFERENCES +C +C [1] Williams, T.W.C. +C An Orthogonal Structure Theorem for Linear Systems. +C Control Systems Research Group, Kingston Polytechnic, +C Internal Report 82/2, 1982. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, March 1998. +C Supersedes Release 3.0 routine TB01QD. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Controllability, dual system, minimal realization, orthogonal +C canonical form, orthogonal transformation, polynomial matrix, +C transfer matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ROWCOL + INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, + $ LDUCO2, LDWORK, M, N, NR, P + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + INTEGER INDEX(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DCOEFF(LDDCOE,*), DWORK(*), + $ UCOEFF(LDUCO1,LDUCO2,*) +C .. Local Scalars .. + LOGICAL LROCOC, LROCOR + CHARACTER*1 JOBD + INTEGER I, IA, ITAU, J, JWORK, K, KDCOEF, MAXMP, MAXMPN, + $ MPLIM, MWORK, N1, PWORK +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB07MD, DLASET, DSWAP, TB01XD, TB04AY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C .. Executable Statements .. +C + INFO = 0 + LROCOR = LSAME( ROWCOL, 'R' ) + LROCOC = LSAME( ROWCOL, 'C' ) + MAXMP = MAX( M, P ) + MPLIM = MAX( 1, MAXMP ) + MAXMPN = MAX( MAXMP, N ) + N1 = MAX( 1, N ) + IF ( LROCOR ) THEN +C +C T(s) given as rows over common denominators. +C + PWORK = P + MWORK = M + ELSE +C +C T(s) given as columns over common denominators. +C + PWORK = M + MWORK = P + END IF +C +C Test the input scalar arguments. +C + IF( .NOT.LROCOR .AND. .NOT.LROCOC ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.N1 ) THEN + INFO = -6 + ELSE IF( LDB.LT.N1 ) THEN + INFO = -8 + ELSE IF( ( LROCOC .AND. LDC.LT.MPLIM ) + $ .OR. LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( ( LROCOC .AND. LDD.LT.MPLIM ) + $ .OR. LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDDCOE.LT.MAX( 1, PWORK ) ) THEN + INFO = -16 + ELSE IF( LDUCO1.LT.MAX( 1, PWORK ) ) THEN + INFO = -18 + ELSE IF( LDUCO2.LT.MAX( 1, MWORK ) ) THEN + INFO = -19 + ELSE IF( LDWORK.LT.MAX( 1, N*( N + 1 ) + + $ MAX( N*MWORK + 2*N + MAX( N, MWORK ), + $ 3*MWORK, PWORK ) ) ) THEN + INFO = -24 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB04AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAXMPN.EQ.0 ) + $ RETURN +C + JOBD = 'D' + IA = 1 + ITAU = IA + N*N + JWORK = ITAU + N +C + IF ( LROCOC ) THEN +C +C Initialization for T(s) given as columns over common +C denominators. +C + CALL AB07MD( JOBD, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ INFO ) + END IF +C +C Initialize polynomial matrix U(s) to zero. +C + DO 10 K = 1, N + 1 + CALL DLASET( 'Full', PWORK, MWORK, ZERO, ZERO, UCOEFF(1,1,K), + $ LDUCO1 ) + 10 CONTINUE +C +C Calculate T(s) by applying the Orthogonal Structure Theorem to +C each of the PWORK MISO subsystems (A,B,C:I,D:I) in turn. +C + CALL TB04AY( N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, LDD, + $ NR, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1, LDUCO2, + $ DWORK(IA), N1, DWORK(ITAU), TOL1, TOL2, IWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) + DWORK(1) = DWORK(JWORK) + DBLE( JWORK-1 ) +C + IF ( LROCOC ) THEN +C +C For T(s) factorized by columns, return to original (dual of +C dual) system, and reorder the rows and columns to get an upper +C block Hessenberg state dynamics matrix. +C + CALL TB01XD( JOBD, N, MWORK, PWORK, IWORK(1)+IWORK(2)-1, N-1, + $ A, LDA, B, LDB, C, LDC, D, LDD, INFO ) +C + IF ( MPLIM.NE.1 ) THEN +C +C Also, transpose U(s) (not 1-by-1). +C + KDCOEF = 0 +C + DO 20 I = 1, PWORK + KDCOEF = MAX( KDCOEF, INDEX(I) ) + 20 CONTINUE +C + KDCOEF = KDCOEF + 1 +C + DO 50 K = 1, KDCOEF +C + DO 40 J = 1, MPLIM - 1 + CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, + $ UCOEFF(J,J+1,K), LDUCO1 ) + 40 CONTINUE +C + 50 CONTINUE +C + END IF + END IF +C + RETURN +C *** Last line of TB04AD *** + END diff --git a/mex/sources/libslicot/TB04AY.f b/mex/sources/libslicot/TB04AY.f new file mode 100644 index 000000000..afce62c3b --- /dev/null +++ b/mex/sources/libslicot/TB04AY.f @@ -0,0 +1,246 @@ + SUBROUTINE TB04AY( N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, + $ LDD, NCONT, INDEXD, DCOEFF, LDDCOE, UCOEFF, + $ LDUCO1, LDUCO2, AT, N1, TAU, TOL1, TOL2, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C Calculates the (PWORK x MWORK) transfer matrix T(s), in the form +C of polynomial row vectors over monic least common denominator +C polynomials, of a given state-space representation (ssr). Each +C such row of T(s) is simply a single-output relatively left prime +C polynomial matrix representation (pmr), so can be calculated by +C applying a simplified version of the Orthogonal Structure +C Theorem to a minimal ssr for the corresponding row of the given +C system: such an ssr is obtained by using the Orthogonal Canon- +C ical Form to first separate out a completely controllable one +C for the overall system and then, for each row in turn, applying +C it again to the resulting dual SIMO system. The Orthogonal +C Structure Theorem produces non-monic denominator and V:I(s) +C polynomials: this is avoided here by first scaling AT (the +C transpose of the controllable part of A, found in this routine) +C by suitable products of its sub-diagonal elements (these are then +C no longer needed, so freeing the entire lower triangle for +C storing the coefficients of V(s) apart from the leading 1's, +C which are treated implicitly). These polynomials are calculated +C in reverse order (IW = NMINL - 1,...,1), the monic denominator +C D:I(s) found exactly as if it were V:0(s), and finally the +C numerator vector U:I(s) obtained from the Orthogonal Structure +C Theorem relation. +C +C ****************************************************************** +C + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, + $ LDUCO2, LDWORK, MWORK, N, N1, NCONT, PWORK + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + INTEGER INDEXD(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), AT(N1,*), B(LDB,*), C(LDC,*), + $ D(LDD,*), DCOEFF(LDDCOE,*), DWORK(*), + $ UCOEFF(LDUCO1,LDUCO2,*), TAU(*) +C .. Local Scalars .. + INTEGER I, IB, IBI, IC, INDCON, IS, IV, IVMIN1, IWPLUS, + $ IZ, J, JWORK, K, L, LWORK, MAXM, NMINL, NPLUS, + $ WRKOPT + DOUBLE PRECISION TEMP +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSCAL, TB01UD, TB01ZD +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C +C Separate out controllable subsystem (of order NCONT). +C +C Workspace: MAX(N, 3*MWORK, PWORK). +C + CALL TB01UD( 'No Z', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, + $ NCONT, INDCON, IWORK, AT, 1, TAU, TOL2, IWORK(N+1), + $ DWORK, LDWORK, INFO ) + WRKOPT = INT( DWORK(1) ) +C + IS = 1 + IC = IS + NCONT + IZ = IC + IB = IC + NCONT + LWORK = IB + MWORK*NCONT + MAXM = MAX( 1, MWORK ) +C +C Calculate each row of T(s) in turn. +C + DO 140 I = 1, PWORK +C +C Form the dual of I-th NCONT-order MISO subsystem ... +C + CALL DCOPY( NCONT, C(I,1), LDC, DWORK(IC), 1 ) +C + DO 10 J = 1, NCONT + CALL DCOPY( NCONT, A(J,1), LDA, AT(1,J), 1 ) + CALL DCOPY( MWORK, B(J,1), LDB, DWORK((J-1)*MAXM+IB), 1 ) + 10 CONTINUE +C +C and separate out its controllable part, giving minimal +C state-space realization for row I. +C +C Workspace: MWORK*NCONT + 2*NCONT + MAX(NCONT,MWORK). +C + CALL TB01ZD( 'No Z', NCONT, MWORK, AT, N1, DWORK(IC), + $ DWORK(IB), MAXM, NMINL, DWORK(IZ), 1, TAU, TOL1, + $ DWORK(LWORK), LDWORK-LWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(LWORK) )+LWORK-1 ) +C +C Store degree of (monic) denominator, and leading coefficient +C vector of numerator. +C + INDEXD(I) = NMINL + DCOEFF(I,1) = ONE + CALL DCOPY( MWORK, D(I,1), LDD, UCOEFF(I,1,1), LDUCO1 ) +C + IF ( NMINL.EQ.1 ) THEN +C +C Finish off numerator, denominator for simple case NMINL=1. +C + TEMP = -AT(1,1) + DCOEFF(I,2) = TEMP + CALL DCOPY( MWORK, D(I,1), LDD, UCOEFF(I,1,2), LDUCO1 ) + CALL DSCAL( MWORK, TEMP, UCOEFF(I,1,2), LDUCO1 ) + CALL DAXPY( MWORK, DWORK(IC), DWORK(IB), 1, UCOEFF(I,1,2), + $ LDUCO1 ) + ELSE IF ( NMINL.GT.1 ) THEN +C +C Set up factors for scaling upper triangle of AT ... +C + CALL DCOPY( NMINL-1, AT(2,1), N1+1, DWORK(IC+1), 1 ) + NPLUS = NMINL + 1 +C + DO 20 L = IS, IS + NMINL - 1 + DWORK(L) = ONE + 20 CONTINUE +C +C and scale it, row by row, starting with row NMINL. +C + DO 40 JWORK = NMINL, 1, -1 +C + DO 30 J = JWORK, NMINL + AT(JWORK,J) = DWORK(IS+J-1)*AT(JWORK,J) + 30 CONTINUE +C +C Update scale factors for next row. +C + CALL DSCAL( NMINL-JWORK+1, DWORK(IC+JWORK-1), + $ DWORK(IS+JWORK-1), 1 ) + 40 CONTINUE +C +C Calculate each monic polynomial V:JWORK(s) in turn: +C K-th coefficient stored as AT(IV,K-1). +C + DO 70 IV = 2, NMINL + JWORK = NPLUS - IV + IWPLUS = JWORK + 1 + IVMIN1 = IV - 1 +C +C Set up coefficients due to leading 1's of existing +C V:I(s)'s. +C + DO 50 K = 1, IVMIN1 + AT(IV,K) = -AT(IWPLUS,JWORK+K) + 50 CONTINUE +C + IF ( IV.NE.2 ) THEN +C +C Then add contribution from s * V:JWORK+1(s) term. +C + CALL DAXPY( IV-2, ONE, AT(IVMIN1,1), N1, AT(IV,1), + $ N1 ) +C +C Finally, add effect of lower coefficients of existing +C V:I(s)'s. +C + DO 60 K = 2, IVMIN1 + AT(IV,K) = AT(IV,K) - DDOT( K-1, + $ AT(IWPLUS,JWORK+1), N1, + $ AT(IV-K+1,1), -(N1+1) ) + 60 CONTINUE +C + END IF + 70 CONTINUE +C +C Determine denominator polynomial D(s) as if it were V:0(s). +C + DO 80 K = 2, NPLUS + DCOEFF(I,K) = -AT(1,K-1) + 80 CONTINUE +C + CALL DAXPY( NMINL-1, ONE, AT(NMINL,1), N1, DCOEFF(I,2), + $ LDDCOE ) +C + DO 90 K = 3, NPLUS + DCOEFF(I,K) = DCOEFF(I,K) - DDOT( K-2, AT, N1, + $ AT(NMINL-K+3,1), -(N1+1) ) + 90 CONTINUE +C +C Scale (B' * Z), stored in DWORK(IB). +C + IBI = IB +C + DO 100 L = 1, NMINL + CALL DSCAL( MWORK, DWORK(IS+L-1), DWORK(IBI), 1 ) + IBI = IBI + MAXM + 100 CONTINUE +C +C Evaluate numerator polynomial vector (V(s) * B) + (D(s) +C * D:I): first set up coefficients due to D:I and leading +C 1's of V(s). +C + IBI = IB +C + DO 110 K = 2, NPLUS + CALL DCOPY( MWORK, DWORK(IBI), 1, UCOEFF(I,1,K), LDUCO1 ) + CALL DAXPY( MWORK, DCOEFF(I,K), D(I,1), LDD, + $ UCOEFF(I,1,K), LDUCO1 ) + IBI = IBI + MAXM + 110 CONTINUE +C +C Add contribution from lower coefficients of V(s). +C + DO 130 K = 3, NPLUS +C + DO 120 J = 1, MWORK + UCOEFF(I,J,K) = UCOEFF(I,J,K) + DDOT( K-2, + $ AT(NMINL-K+3,1), -(N1+1), + $ DWORK(IB+J-1), MAXM ) + 120 CONTINUE +C + 130 CONTINUE +C + END IF + 140 CONTINUE +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of TB04AY *** + END diff --git a/mex/sources/libslicot/TB04BD.f b/mex/sources/libslicot/TB04BD.f new file mode 100644 index 000000000..0d8d5d0c0 --- /dev/null +++ b/mex/sources/libslicot/TB04BD.f @@ -0,0 +1,600 @@ + SUBROUTINE TB04BD( JOBD, ORDER, EQUIL, N, M, P, MD, A, LDA, B, + $ LDB, C, LDC, D, LDD, IGN, LDIGN, IGD, LDIGD, + $ GN, GD, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the transfer function matrix G of a state-space +C representation (A,B,C,D) of a linear time-invariant multivariable +C system, using the pole-zeros method. Each element of the transfer +C function matrix is returned in a cancelled, minimal form, with +C numerator and denominator polynomials stored either in increasing +C or decreasing order of the powers of the indeterminate. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears in +C the given state-space model: +C = 'D': D is present; +C = 'Z': D is assumed to be a zero matrix. +C +C ORDER CHARACTER*1 +C Specifies the order in which the polynomial coefficients +C are stored, as follows: +C = 'I': Increasing order of powers of the indeterminate; +C = 'D': Decreasing order of powers of the indeterminate. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system (A,B,C,D). N >= 0. +C +C M (input) INTEGER +C The number of the system inputs. M >= 0. +C +C P (input) INTEGER +C The number of the system outputs. P >= 0. +C +C MD (input) INTEGER +C The maximum degree of the polynomials in G, plus 1. An +C upper bound for MD is N+1. MD >= 1. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, if EQUIL = 'S', the leading N-by-N part of this +C array contains the balanced matrix inv(S)*A*S, as returned +C by SLICOT Library routine TB01ID. +C If EQUIL = 'N', this array is unchanged on exit. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B. +C On exit, the contents of B are destroyed: all elements but +C those in the first row are set to zero. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C. +C On exit, if EQUIL = 'S', the leading P-by-N part of this +C array contains the balanced matrix C*S, as returned by +C SLICOT Library routine TB01ID. +C If EQUIL = 'N', this array is unchanged on exit. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C If JOBD = 'D', the leading P-by-M part of this array must +C contain the matrix D. +C If JOBD = 'Z', the array D is not referenced. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P), if JOBD = 'D'; +C LDD >= 1, if JOBD = 'Z'. +C +C IGN (output) INTEGER array, dimension (LDIGN,M) +C The leading P-by-M part of this array contains the degrees +C of the numerator polynomials in the transfer function +C matrix G. Specifically, the (i,j) element of IGN contains +C the degree of the numerator polynomial of the transfer +C function G(i,j) from the j-th input to the i-th output. +C +C LDIGN INTEGER +C The leading dimension of array IGN. LDIGN >= max(1,P). +C +C IGD (output) INTEGER array, dimension (LDIGD,M) +C The leading P-by-M part of this array contains the degrees +C of the denominator polynomials in the transfer function +C matrix G. Specifically, the (i,j) element of IGD contains +C the degree of the denominator polynomial of the transfer +C function G(i,j). +C +C LDIGD INTEGER +C The leading dimension of array IGD. LDIGD >= max(1,P). +C +C GN (output) DOUBLE PRECISION array, dimension (P*M*MD) +C This array contains the coefficients of the numerator +C polynomials, Num(i,j), of the transfer function matrix G. +C The polynomials are stored in a column-wise order, i.e., +C Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), Num(2,2), +C ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., Num(P,M); +C MD memory locations are reserved for each polynomial, +C hence, the (i,j) polynomial is stored starting from the +C location ((j-1)*P+i-1)*MD+1. The coefficients appear in +C increasing or decreasing order of the powers of the +C indeterminate, according to ORDER. +C +C GD (output) DOUBLE PRECISION array, dimension (P*M*MD) +C This array contains the coefficients of the denominator +C polynomials, Den(i,j), of the transfer function matrix G. +C The polynomials are stored in the same way as the +C numerator polynomials. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the +C controllability of a single-input system (A,b) or (A',c'), +C where b and c' are columns in B and C' (C transposed). If +C the user sets TOL > 0, then the given value of TOL is used +C as an absolute tolerance; elements with absolute value +C less than TOL are considered neglijible. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*EPS*MAX( NORM(A), NORM(bc) ) is used +C instead, where EPS is the machine precision (see LAPACK +C Library routine DLAMCH), and bc denotes the currently used +C column in B or C' (see METHOD). +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N*(N+P) + +C MAX( N + MAX( N,P ), N*(2*N+5))) +C If N >= P, N >= 1, the formula above can be written as +C LDWORK >= N*(3*N + P + 5). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the QR algorithm failed to converge when trying to +C compute the zeros of a transfer function; +C = 2: the QR algorithm failed to converge when trying to +C compute the poles of a transfer function. +C The errors INFO = 1 or 2 are unlikely to appear. +C +C METHOD +C +C The routine implements the pole-zero method proposed in [1]. +C This method is based on an algorithm for computing the transfer +C function of a single-input single-output (SISO) system. +C Let (A,b,c,d) be a SISO system. Its transfer function is computed +C as follows: +C +C 1) Find a controllable realization (Ac,bc,cc) of (A,b,c). +C 2) Find an observable realization (Ao,bo,co) of (Ac,bc,cc). +C 3) Compute the r eigenvalues of Ao (the poles of (Ao,bo,co)). +C 4) Compute the zeros of (Ao,bo,co,d). +C 5) Compute the gain of (Ao,bo,co,d). +C +C This algorithm can be implemented using only orthogonal +C transformations [1]. However, for better efficiency, the +C implementation in TB04BD uses one elementary transformation +C in Step 4 and r elementary transformations in Step 5 (to reduce +C an upper Hessenberg matrix to upper triangular form). These +C special elementary transformations are numerically stable +C in practice. +C +C In the multi-input multi-output (MIMO) case, the algorithm +C computes each element (i,j) of the transfer function matrix G, +C for i = 1 : P, and for j = 1 : M. For efficiency reasons, Step 1 +C is performed once for each value of j (each column of B). The +C matrices Ac and Ao result in Hessenberg form. +C +C REFERENCES +C +C [1] Varga, A. and Sima, V. +C Numerically Stable Algorithm for Transfer Function Matrix +C Evaluation. +C Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable in practice and requires about +C 20*N**3 floating point operations at most, but usually much less. +C +C FURTHER COMMENTS +C +C For maximum efficiency of index calculations, GN and GD are +C implemented as one-dimensional arrays. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2002. +C Partly based on the BIMASC Library routine TSMT1 by A. Varga. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalue, state-space representation, transfer function, zeros. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, C100 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL, JOBD, ORDER + DOUBLE PRECISION TOL + INTEGER INFO, LDA, LDB, LDC, LDD, LDIGD, LDIGN, LDWORK, + $ M, MD, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), GD(*), GN(*) + INTEGER IGD(LDIGD,*), IGN(LDIGN,*), IWORK(*) +C .. Local Scalars .. + DOUBLE PRECISION ANORM, DIJ, EPSN, MAXRED, TOLDEF, X + INTEGER I, IA, IAC, IAS, IB, IC, ICC, IERR, IIP, IM, + $ IP, IPM1, IRP, ITAU, ITAU1, IZ, J, JJ, JWORK, + $ JWORK1, K, L, NCONT, WRKOPT + LOGICAL ASCEND, DIJNZ, FNDEIG, WITHD +C .. Local Arrays .. + DOUBLE PRECISION Z(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DHSEQR, DLACPY, MA02AD, MC01PD, + $ MC01PY, TB01ID, TB01ZD, TB04BX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar parameters. +C + INFO = 0 + WITHD = LSAME( JOBD, 'D' ) + ASCEND = LSAME( ORDER, 'I' ) + IF( .NOT.WITHD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN + INFO = -1 + ELSE IF( .NOT.ASCEND .AND. .NOT.LSAME( ORDER, 'D' ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( MD.LT.1 ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN + INFO = -15 + ELSE IF( LDIGN.LT.MAX( 1, P ) ) THEN + INFO = -17 + ELSE IF( LDIGD.LT.MAX( 1, P ) ) THEN + INFO = -19 + ELSE IF( LDWORK.LT.MAX( 1, N*( N + P ) + + $ MAX( N + MAX( N, P ), N*( 2*N + 5 ) ) ) + $ ) THEN + INFO = -25 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB04BD', -INFO ) + RETURN + END IF +C +C Initialize GN and GD to zero. +C + Z(1) = ZERO + CALL DCOPY( P*M*MD, Z, 0, GN, 1 ) + CALL DCOPY( P*M*MD, Z, 0, GD, 1 ) +C +C Quick return if possible. +C + IF( MIN( N, P, M ).EQ.0 ) THEN + IF( MIN( P, M ).GT.0 ) THEN + K = 1 +C + DO 20 J = 1, M +C + DO 10 I = 1, P + IGN(I,J) = 0 + IGD(I,J) = 0 + IF ( WITHD ) + $ GN(K) = D(I,J) + GD(K) = ONE + K = K + MD + 10 CONTINUE +C + 20 CONTINUE +C + END IF + DWORK(1) = ONE + RETURN + END IF +C +C Prepare the computation of the default tolerance. +C + TOLDEF = TOL + IF( TOLDEF.LE.ZERO ) THEN + EPSN = DBLE( N )*DLAMCH( 'Epsilon' ) + ANORM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) + END IF +C +C Initializations. +C + IA = 1 + IC = IA + N*N + ITAU = IC + P*N + JWORK = ITAU + N + IAC = ITAU +C + K = 1 + DIJ = ZERO +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(S)*A*S, B <- inv(S)*B and C <- C*S, where S is a +C diagonal scaling matrix. +C Workspace: need N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, IERR ) + END IF +C +C Compute the transfer function matrix of the system (A,B,C,D). +C + DO 80 J = 1, M +C +C Save A and C. +C Workspace: need W1 = N*(N+P). +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), N ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(IC), P ) +C +C Remove the uncontrollable part of the system (A,B(J),C). +C Workspace: need W1+N+MAX(N,P); +C prefer larger. +C + CALL TB01ZD( 'No Z', N, P, DWORK(IA), N, B(1,J), DWORK(IC), P, + $ NCONT, Z, 1, DWORK(ITAU), TOL, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + IF ( J.EQ.1 ) + $ WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 +C + IB = IAC + NCONT*NCONT + ICC = IB + NCONT + ITAU1 = ICC + NCONT + IRP = ITAU1 + IIP = IRP + NCONT + IAS = IIP + NCONT + JWORK1 = IAS + NCONT*NCONT +C + DO 70 I = 1, P + IF ( WITHD ) + $ DIJ = D(I,J) + IF ( NCONT.GT.0 ) THEN +C +C Form the matrices of the state-space representation of +C the dual system for the controllable part. +C Workspace: need W2 = W1+N*(N+2). +C + CALL MA02AD( 'Full', NCONT, NCONT, DWORK(IA), N, + $ DWORK(IAC), NCONT ) + CALL DCOPY( NCONT, B(1,J), 1, DWORK(IB), 1 ) + CALL DCOPY( NCONT, DWORK(IC+I-1), P, DWORK(ICC), 1 ) +C +C Remove the unobservable part of the system (A,B(J),C(I)). +C Workspace: need W2+2*N; +C prefer larger. +C + CALL TB01ZD( 'No Z', NCONT, 1, DWORK(IAC), NCONT, + $ DWORK(ICC), DWORK(IB), 1, IP, Z, 1, + $ DWORK(ITAU1), TOL, DWORK(IIP), LDWORK-IIP+1, + $ IERR ) + IF ( I.EQ.1 ) + $ WRKOPT = MAX( WRKOPT, INT( DWORK(IIP) ) + IIP - 1 ) +C + IF ( IP.GT.0 ) THEN +C +C Save the state matrix of the minimal part. +C Workspace: need W3 = W2+N*(N+2). +C + CALL DLACPY( 'Full', IP, IP, DWORK(IAC), NCONT, + $ DWORK(IAS), IP ) +C +C Compute the poles of the transfer function. +C Workspace: need W3+N; +C prefer larger. +C + CALL DHSEQR( 'Eigenvalues', 'No vectors', IP, 1, IP, + $ DWORK(IAC), NCONT, DWORK(IRP), + $ DWORK(IIP), Z, 1, DWORK(JWORK1), + $ LDWORK-JWORK1+1, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + WRKOPT = MAX( WRKOPT, + $ INT( DWORK(JWORK1) ) + JWORK1 - 1 ) +C +C Compute the zeros of the transfer function. +C + IPM1 = IP - 1 + DIJNZ = WITHD .AND. DIJ.NE.ZERO + FNDEIG = DIJNZ .OR. IPM1.GT.0 + IF ( .NOT.FNDEIG ) THEN + IZ = 0 + ELSE IF ( DIJNZ ) THEN +C +C Add the contribution due to D(i,j). +C Note that the matrix whose eigenvalues have to +C be computed remains in an upper Hessenberg form. +C + IZ = IP + CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS), IP, + $ DWORK(IAC), NCONT ) + CALL DAXPY( IZ, -DWORK(ICC)/DIJ, DWORK(IB), 1, + $ DWORK(IAC), NCONT ) + ELSE + IF( TOL.LE.ZERO ) + $ TOLDEF = EPSN*MAX( ANORM, + $ DLANGE( 'Frobenius', IP, 1, + $ DWORK(IB), 1, DWORK ) + $ ) +C + DO 30 IM = 1, IPM1 + IF ( ABS( DWORK(IB+IM-1) ).GT.TOLDEF ) GO TO 40 + 30 CONTINUE +C + IZ = 0 + GO TO 50 +C + 40 CONTINUE +C +C Restore (part of) the saved state matrix. +C + IZ = IP - IM + CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS+IM*(IP+1)), + $ IP, DWORK(IAC), NCONT ) +C +C Apply the output injection. +C + CALL DAXPY( IZ, -DWORK(IAS+IM*(IP+1)-IP)/ + $ DWORK(IB+IM-1), DWORK(IB+IM), 1, + $ DWORK(IAC), NCONT ) + END IF +C + IF ( FNDEIG ) THEN +C +C Find the zeros. +C Workspace: need W3+N; +C prefer larger. +C + CALL DHSEQR( 'Eigenvalues', 'No vectors', IZ, 1, + $ IZ, DWORK(IAC), NCONT, GN(K), GD(K), + $ Z, 1, DWORK(JWORK1), LDWORK-JWORK1+1, + $ IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + END IF +C +C Compute the gain. +C + 50 CONTINUE + IF ( DIJNZ ) THEN + X = DIJ + ELSE + CALL TB04BX( IP, IZ, DWORK(IAS), IP, DWORK(ICC), + $ DWORK(IB), DIJ, DWORK(IRP), + $ DWORK(IIP), GN(K), GD(K), X, IWORK ) + END IF +C +C Form the numerator coefficients in increasing or +C decreasing powers of the indeterminate. +C IAS is used here as pointer to the workspace. +C + IF ( ASCEND ) THEN + CALL MC01PD( IZ, GN(K), GD(K), DWORK(IB), + $ DWORK(IAS), IERR ) + ELSE + CALL MC01PY( IZ, GN(K), GD(K), DWORK(IB), + $ DWORK(IAS), IERR ) + END IF + JJ = K +C + DO 60 L = IB, IB + IZ + GN(JJ) = DWORK(L)*X + JJ = JJ + 1 + 60 CONTINUE +C +C Form the denominator coefficients. +C + IF ( ASCEND ) THEN + CALL MC01PD( IP, DWORK(IRP), DWORK(IIP), GD(K), + $ DWORK(IAS), IERR ) + ELSE + CALL MC01PY( IP, DWORK(IRP), DWORK(IIP), GD(K), + $ DWORK(IAS), IERR ) + END IF + IGN(I,J) = IZ + IGD(I,J) = IP + ELSE +C +C Null element. +C + IGN(I,J) = 0 + IGD(I,J) = 0 + GN(K) = DIJ + GD(K) = ONE + END IF +C + ELSE +C +C Null element. +C + IGN(I,J) = 0 + IGD(I,J) = 0 + GN(K) = DIJ + GD(K) = ONE + END IF +C + K = K + MD + 70 CONTINUE +C + 80 CONTINUE +C + RETURN +C *** Last line of TB04BD *** + END diff --git a/mex/sources/libslicot/TB04BV.f b/mex/sources/libslicot/TB04BV.f new file mode 100644 index 000000000..10b58b592 --- /dev/null +++ b/mex/sources/libslicot/TB04BV.f @@ -0,0 +1,343 @@ + SUBROUTINE TB04BV( ORDER, P, M, MD, IGN, LDIGN, IGD, LDIGD, GN, + $ GD, D, LDD, TOL, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To separate the strictly proper part G0 from the constant part D +C of an P-by-M proper transfer function matrix G. +C +C ARGUMENTS +C +C Mode Parameters +C +C ORDER CHARACTER*1 +C Specifies the order in which the polynomial coefficients +C of the transfer function matrix are stored, as follows: +C = 'I': Increasing order of powers of the indeterminate; +C = 'D': Decreasing order of powers of the indeterminate. +C +C Input/Output Parameters +C +C P (input) INTEGER +C The number of the system outputs. P >= 0. +C +C M (input) INTEGER +C The number of the system inputs. M >= 0. +C +C MD (input) INTEGER +C The maximum degree of the polynomials in G, plus 1, i.e., +C MD = MAX(IGD(I,J)) + 1. +C I,J +C +C IGN (input/output) INTEGER array, dimension (LDIGN,M) +C On entry, the leading P-by-M part of this array must +C contain the degrees of the numerator polynomials in G: +C the (i,j) element of IGN must contain the degree of the +C numerator polynomial of the polynomial ratio G(i,j). +C On exit, the leading P-by-M part of this array contains +C the degrees of the numerator polynomials in G0. +C +C LDIGN INTEGER +C The leading dimension of array IGN. LDIGN >= max(1,P). +C +C IGD (input) INTEGER array, dimension (LDIGD,M) +C The leading P-by-M part of this array must contain the +C degrees of the denominator polynomials in G (and G0): +C the (i,j) element of IGD contains the degree of the +C denominator polynomial of the polynomial ratio G(i,j). +C +C LDIGD INTEGER +C The leading dimension of array IGD. LDIGD >= max(1,P). +C +C GN (input/output) DOUBLE PRECISION array, dimension (P*M*MD) +C On entry, this array must contain the coefficients of the +C numerator polynomials, Num(i,j), of the transfer function +C matrix G. The polynomials are stored in a column-wise +C order, i.e., Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), +C Num(2,2), ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., +C Num(P,M); MD memory locations are reserved for each +C polynomial, hence, the (i,j) polynomial is stored starting +C from the location ((j-1)*P+i-1)*MD+1. The coefficients +C appear in increasing or decreasing order of the powers +C of the indeterminate, according to ORDER. +C On exit, this array contains the coefficients of the +C numerator polynomials of the strictly proper part G0 of +C the transfer function matrix G, stored similarly. +C +C GD (input) DOUBLE PRECISION array, dimension (P*M*MD) +C This array must contain the coefficients of the +C denominator polynomials, Den(i,j), of the transfer +C function matrix G. The polynomials are stored as for the +C numerator polynomials. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array contains the +C matrix D. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= max(1,P). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the degrees of +C the numerators Num0(i,j) of the strictly proper part of +C the transfer function matrix G. If the user sets TOL > 0, +C then the given value of TOL is used as an absolute +C tolerance; the leading coefficients with absolute value +C less than TOL are considered neglijible. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = IGN(i,j)*EPS*NORM( Num(i,j) ) is used +C instead, where EPS is the machine precision (see LAPACK +C Library routine DLAMCH), and NORM denotes the infinity +C norm (the maximum coefficient in absolute value). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the transfer function matrix is not proper; +C = 2: if a denominator polynomial is null. +C +C METHOD +C +C The (i,j) entry of the real matrix D is zero, if the degree of +C Num(i,j), IGN(i,j), is less than the degree of Den(i,j), IGD(i,j), +C and it is given by the ratio of the leading coefficients of +C Num(i,j) and Den(i,j), if IGN(i,j) is equal to IGD(i,j), +C for i = 1 : P, and for j = 1 : M. +C +C FURTHER COMMENTS +C +C For maximum efficiency of index calculations, GN and GD are +C implemented as one-dimensional arrays. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2002. +C Based on the BIMASC Library routine TMPRP by A. Varga. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. +C +C KEYWORDS +C +C State-space representation, transfer function. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ORDER + DOUBLE PRECISION TOL + INTEGER INFO, LDD, LDIGD, LDIGN, M, MD, P +C .. Array Arguments .. + DOUBLE PRECISION D(LDD,*), GD(*), GN(*) + INTEGER IGD(LDIGD,*), IGN(LDIGN,*) +C .. Local Scalars .. + LOGICAL ASCEND + INTEGER I, II, J, K, KK, KM, ND, NN + DOUBLE PRECISION DIJ, EPS, TOLDEF +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar parameters. +C + INFO = 0 + ASCEND = LSAME( ORDER, 'I' ) + IF( .NOT.ASCEND .AND. .NOT.LSAME( ORDER, 'D' ) ) THEN + INFO = -1 + ELSE IF( P.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( MD.LT.1 ) THEN + INFO = -4 + ELSE IF( LDIGN.LT.MAX( 1, P ) ) THEN + INFO = -6 + ELSE IF( LDIGD.LT.MAX( 1, P ) ) THEN + INFO = -8 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB04BV', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( P, M ).EQ.0 ) + $ RETURN +C +C Prepare the computation of the default tolerance. +C + TOLDEF = TOL + IF( TOLDEF.LE.ZERO ) + $ EPS = DLAMCH( 'Epsilon' ) +C + K = 1 +C + IF ( ASCEND ) THEN +C +C Polynomial coefficients are stored in increasing order. +C + DO 40 J = 1, M +C + DO 30 I = 1, P + NN = IGN(I,J) + ND = IGD(I,J) + IF ( NN.GT.ND ) THEN +C +C Error return: the transfer function matrix is +C not proper. +C + INFO = 1 + RETURN + ELSE IF ( NN.LT.ND .OR. ( ND.EQ.0 .AND. GN(K).EQ.ZERO ) ) + $ THEN + D(I,J) = ZERO + ELSE +C +C Here NN = ND. +C + KK = K + NN +C + IF ( GD(KK).EQ.ZERO ) THEN +C +C Error return: the denominator is null. +C + INFO = 2 + RETURN + ENDIF +C + DIJ = GN(KK) / GD(KK) + D(I,J) = DIJ + GN(KK) = ZERO + IF ( NN.GT.0 ) THEN + CALL DAXPY( NN, -DIJ, GD(K), 1, GN(K), 1 ) + IF ( TOL.LE.ZERO ) + $ TOLDEF = DBLE( NN )*EPS* + $ ABS( GN(IDAMAX( NN, GN(K), 1 ) ) ) + KM = NN + DO 10 II = 1, KM + KK = KK - 1 + NN = NN - 1 + IF ( ABS( GN(KK) ).GT.TOLDEF ) + $ GO TO 20 + 10 CONTINUE +C + 20 CONTINUE +C + IGN(I,J) = NN + ENDIF + ENDIF + K = K + MD + 30 CONTINUE +C + 40 CONTINUE +C + ELSE +C +C Polynomial coefficients are stored in decreasing order. +C + DO 90 J = 1, M +C + DO 80 I = 1, P + NN = IGN(I,J) + ND = IGD(I,J) + IF ( NN.GT.ND ) THEN +C +C Error return: the transfer function matrix is +C not proper. +C + INFO = 1 + RETURN + ELSE IF ( NN.LT.ND .OR. ( ND.EQ.0 .AND. GN(K).EQ.ZERO ) ) + $ THEN + D(I,J) = ZERO + ELSE +C +C Here NN = ND. +C + KK = K +C + IF ( GD(KK).EQ.ZERO ) THEN +C +C Error return: the denominator is null. +C + INFO = 2 + RETURN + ENDIF +C + DIJ = GN(KK) / GD(KK) + D(I,J) = DIJ + GN(KK) = ZERO + IF ( NN.GT.0 ) THEN + CALL DAXPY( NN, -DIJ, GD(K+1), 1, GN(K+1), 1 ) + IF ( TOL.LE.ZERO ) + $ TOLDEF = DBLE( NN )*EPS* + $ ABS( GN(IDAMAX( NN, GN(K+1), 1 ) ) ) + KM = NN + DO 50 II = 1, KM + KK = KK + 1 + NN = NN - 1 + IF ( ABS( GN(KK) ).GT.TOLDEF ) + $ GO TO 60 + 50 CONTINUE +C + 60 CONTINUE +C + IGN(I,J) = NN + DO 70 II = 0, NN + GN(K+II) = GN(KK+II) + 70 CONTINUE +C + ENDIF + ENDIF + K = K + MD + 80 CONTINUE +C + 90 CONTINUE +C + ENDIF +C + RETURN +C *** Last line of TB04BV *** + END diff --git a/mex/sources/libslicot/TB04BW.f b/mex/sources/libslicot/TB04BW.f new file mode 100644 index 000000000..7fb2a3217 --- /dev/null +++ b/mex/sources/libslicot/TB04BW.f @@ -0,0 +1,280 @@ + SUBROUTINE TB04BW( ORDER, P, M, MD, IGN, LDIGN, IGD, LDIGD, GN, + $ GD, D, LDD, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the sum of an P-by-M rational matrix G and a real +C P-by-M matrix D. +C +C ARGUMENTS +C +C Mode Parameters +C +C ORDER CHARACTER*1 +C Specifies the order in which the polynomial coefficients +C of the rational matrix are stored, as follows: +C = 'I': Increasing order of powers of the indeterminate; +C = 'D': Decreasing order of powers of the indeterminate. +C +C Input/Output Parameters +C +C P (input) INTEGER +C The number of the system outputs. P >= 0. +C +C M (input) INTEGER +C The number of the system inputs. M >= 0. +C +C MD (input) INTEGER +C The maximum degree of the polynomials in G, plus 1, i.e., +C MD = MAX(IGN(I,J),IGD(I,J)) + 1. +C I,J +C +C IGN (input/output) INTEGER array, dimension (LDIGN,M) +C On entry, the leading P-by-M part of this array must +C contain the degrees of the numerator polynomials in G: +C the (i,j) element of IGN must contain the degree of the +C numerator polynomial of the polynomial ratio G(i,j). +C On exit, the leading P-by-M part of this array contains +C the degrees of the numerator polynomials in G + D. +C +C LDIGN INTEGER +C The leading dimension of array IGN. LDIGN >= max(1,P). +C +C IGD (input) INTEGER array, dimension (LDIGD,M) +C The leading P-by-M part of this array must contain the +C degrees of the denominator polynomials in G (and G + D): +C the (i,j) element of IGD contains the degree of the +C denominator polynomial of the polynomial ratio G(i,j). +C +C LDIGD INTEGER +C The leading dimension of array IGD. LDIGD >= max(1,P). +C +C GN (input/output) DOUBLE PRECISION array, dimension (P*M*MD) +C On entry, this array must contain the coefficients of the +C numerator polynomials, Num(i,j), of the rational matrix G. +C The polynomials are stored in a column-wise order, i.e., +C Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), Num(2,2), +C ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., Num(P,M); +C MD memory locations are reserved for each polynomial, +C hence, the (i,j) polynomial is stored starting from the +C location ((j-1)*P+i-1)*MD+1. The coefficients appear in +C increasing or decreasing order of the powers of the +C indeterminate, according to ORDER. +C On exit, this array contains the coefficients of the +C numerator polynomials of the rational matrix G + D, +C stored similarly. +C +C GD (input) DOUBLE PRECISION array, dimension (P*M*MD) +C This array must contain the coefficients of the +C denominator polynomials, Den(i,j), of the rational +C matrix G. The polynomials are stored as for the +C numerator polynomials. +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C matrix D. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= max(1,P). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The (i,j) entry of the real matrix D is added to the (i,j) entry +C of the matrix G, g(i,j), which is a ratio of two polynomials, +C for i = 1 : P, and for j = 1 : M. If g(i,j) = 0, it is assumed +C that its denominator is 1. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable. +C +C FURTHER COMMENTS +C +C Often, the rational matrix G is found from a state-space +C representation (A,B,C), and D corresponds to the direct +C feedthrough matrix of the system. The sum G + D gives the +C transfer function matrix of the system (A,B,C,D). +C For maximum efficiency of index calculations, GN and GD are +C implemented as one-dimensional arrays. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2002. +C Based on the BIMASC Library routine TMCADD by A. Varga. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. +C +C KEYWORDS +C +C State-space representation, transfer function. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ORDER + INTEGER INFO, LDD, LDIGD, LDIGN, M, MD, P +C .. Array Arguments .. + DOUBLE PRECISION D(LDD,*), GD(*), GN(*) + INTEGER IGD(LDIGD,*), IGN(LDIGN,*) +C .. Local Scalars .. + LOGICAL ASCEND + INTEGER I, II, J, K, KK, KM, ND, NN + DOUBLE PRECISION DIJ +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar parameters. +C + INFO = 0 + ASCEND = LSAME( ORDER, 'I' ) + IF( .NOT.ASCEND .AND. .NOT.LSAME( ORDER, 'D' ) ) THEN + INFO = -1 + ELSE IF( P.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( MD.LT.1 ) THEN + INFO = -4 + ELSE IF( LDIGN.LT.MAX( 1, P ) ) THEN + INFO = -6 + ELSE IF( LDIGD.LT.MAX( 1, P ) ) THEN + INFO = -8 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB04BW', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( P, M ).EQ.0 ) + $ RETURN +C + K = 1 +C + IF ( ASCEND ) THEN +C +C Polynomial coefficients are stored in increasing order. +C + DO 30 J = 1, M +C + DO 20 I = 1, P + DIJ = D(I,J) + IF ( DIJ.NE.ZERO ) THEN + NN = IGN(I,J) + ND = IGD(I,J) + IF ( NN.EQ.0 .AND. ND.EQ.0 ) THEN + IF ( GN(K).EQ.ZERO ) THEN + GN(K) = DIJ + ELSE + GN(K) = GN(K) + DIJ*GD(K) + ENDIF + ELSE + KM = MIN( NN, ND ) + 1 + CALL DAXPY( KM, DIJ, GD(K), 1, GN(K), 1 ) + IF ( NN.LT.ND ) THEN +C + DO 10 II = K + KM, K + ND + GN(II) = DIJ*GD(II) + 10 CONTINUE +C + IGN(I,J) = ND + ENDIF + ENDIF + ENDIF + K = K + MD + 20 CONTINUE +C + 30 CONTINUE +C + ELSE +C +C Polynomial coefficients are stored in decreasing order. +C + DO 60 J = 1, M +C + DO 50 I = 1, P + DIJ = D(I,J) + IF ( DIJ.NE.ZERO ) THEN + NN = IGN(I,J) + ND = IGD(I,J) + IF ( NN.EQ.0 .AND. ND.EQ.0 ) THEN + IF ( GN(K).EQ.ZERO ) THEN + GN(K) = DIJ + ELSE + GN(K) = GN(K) + DIJ*GD(K) + ENDIF + ELSE + KM = MIN( NN, ND ) + 1 + IF ( NN.LT.ND ) THEN + KK = K + ND - NN +C + DO 35 II = K + NN, K, -1 + GN(II+ND-NN) = GN(II) + 35 CONTINUE +C + DO 40 II = K, KK - 1 + GN(II) = DIJ*GD(II) + 40 CONTINUE +C + IGN(I,J) = ND + CALL DAXPY( KM, DIJ, GD(KK), 1, GN(KK), 1 ) + ELSE + KK = K + NN - ND + CALL DAXPY( KM, DIJ, GD(K), 1, GN(KK), 1 ) + ENDIF + ENDIF + ENDIF + K = K + MD + 50 CONTINUE +C + 60 CONTINUE +C + ENDIF +C + RETURN +C *** Last line of TB04BW *** + END diff --git a/mex/sources/libslicot/TB04BX.f b/mex/sources/libslicot/TB04BX.f new file mode 100644 index 000000000..ff0e004f1 --- /dev/null +++ b/mex/sources/libslicot/TB04BX.f @@ -0,0 +1,246 @@ + SUBROUTINE TB04BX( IP, IZ, A, LDA, B, C, D, PR, PI, ZR, ZI, GAIN, + $ IWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the gain of a single-input single-output linear system, +C given its state-space representation (A,b,c,d), and its poles and +C zeros. The matrix A is assumed to be in an upper Hessenberg form. +C The gain is computed using the formula +C +C -1 IP IZ +C g = (c*( S0*I - A ) *b + d)*Prod( S0 - Pi )/Prod( S0 - Zi ) , +C i=1 i=1 (1) +C +C where Pi, i = 1 : IP, and Zj, j = 1 : IZ, are the poles and zeros, +C respectively, and S0 is a real scalar different from all poles and +C zeros. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C IP (input) INTEGER +C The number of the system poles. IP >= 0. +C +C IZ (input) INTEGER +C The number of the system zeros. IZ >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,IP) +C On entry, the leading IP-by-IP part of this array must +C contain the state dynamics matrix A in an upper Hessenberg +C form. The elements below the second diagonal are not +C referenced. +C On exit, the leading IP-by-IP upper Hessenberg part of +C this array contains the LU factorization of the matrix +C A - S0*I, as computed by SLICOT Library routine MB02SD. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= max(1,IP). +C +C B (input/output) DOUBLE PRECISION array, dimension (IP) +C On entry, this array must contain the system input +C vector b. +C On exit, this array contains the solution of the linear +C system ( A - S0*I )x = b . +C +C C (input) DOUBLE PRECISION array, dimension (IP) +C This array must contain the system output vector c. +C +C D (input) DOUBLE PRECISION +C The variable must contain the system feedthrough scalar d. +C +C PR (input) DOUBLE PRECISION array, dimension (IP) +C This array must contain the real parts of the system +C poles. Pairs of complex conjugate poles must be stored in +C consecutive memory locations. +C +C PI (input) DOUBLE PRECISION array, dimension (IP) +C This array must contain the imaginary parts of the system +C poles. +C +C ZR (input) DOUBLE PRECISION array, dimension (IZ) +C This array must contain the real parts of the system +C zeros. Pairs of complex conjugate zeros must be stored in +C consecutive memory locations. +C +C ZI (input) DOUBLE PRECISION array, dimension (IZ) +C This array must contain the imaginary parts of the system +C zeros. +C +C GAIN (output) DOUBLE PRECISION +C The gain of the linear system (A,b,c,d), given by (1). +C +C Workspace +C +C IWORK INTEGER array, dimension (IP) +C On exit, it contains the pivot indices; for 1 <= i <= IP, +C row i of the matrix A - S0*I was interchanged with +C row IWORK(i). +C +C METHOD +C +C The routine implements the method presented in [1]. A suitable +C value of S0 is chosen based on the system poles and zeros. +C Then, the LU factorization of the upper Hessenberg, nonsingular +C matrix A - S0*I is computed and used to solve the linear system +C in (1). +C +C REFERENCES +C +C [1] Varga, A. and Sima, V. +C Numerically Stable Algorithm for Transfer Function Matrix +C Evaluation. +C Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable in practice and requires +C O(IP*IP) floating point operations. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2002. +C Partly based on the BIMASC Library routine GAIN by A. Varga. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalue, state-space representation, transfer function, zeros. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, P1, ONEP1 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ P1 = 0.1D0, ONEP1 = 1.1D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION D, GAIN + INTEGER IP, IZ, LDA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(*), C(*), PI(*), PR(*), ZI(*), + $ ZR(*) + INTEGER IWORK(*) +C .. Local Scalars .. + INTEGER I, INFO + DOUBLE PRECISION S0, S +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL MB02RD, MB02SD +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. +C .. Executable Statements .. +C +C For efficiency, the input scalar parameters are not checked. +C +C Quick return if possible. +C + IF( IP.EQ.0 ) THEN + GAIN = ZERO + RETURN + END IF +C +C Compute a suitable value for S0 . +C + S0 = ZERO +C + DO 10 I = 1, IP + S = ABS( PR(I) ) + IF ( PI(I).NE.ZERO ) + $ S = S + ABS( PI(I) ) + S0 = MAX( S0, S ) + 10 CONTINUE +C + DO 20 I = 1, IZ + S = ABS( ZR(I) ) + IF ( ZI(I).NE.ZERO ) + $ S = S + ABS( ZI(I) ) + S0 = MAX( S0, S ) + 20 CONTINUE +C + S0 = TWO*S0 + P1 + IF ( S0.LE.ONE ) + $ S0 = ONEP1 +C +C Form A - S0*I . +C + DO 30 I = 1, IP + A(I,I) = A(I,I) - S0 + 30 CONTINUE +C +C Compute the LU factorization of the matrix A - S0*I +C (guaranteed to be nonsingular). +C + CALL MB02SD( IP, A, LDA, IWORK, INFO ) +C +C Solve the linear system (A - S0*I)*x = b . +C + CALL MB02RD( 'No Transpose', IP, 1, A, LDA, IWORK, B, IP, INFO ) +C -1 +C Compute c*(S0*I - A) *b + d . +C + GAIN = D - DDOT( IP, C, 1, B, 1 ) +C +C Multiply by the products in terms of poles and zeros in (1). +C + I = 1 +C +C WHILE ( I <= IP ) DO +C + 40 IF ( I.LE.IP ) THEN + IF ( PI(I).EQ.ZERO ) THEN + GAIN = GAIN*( S0 - PR(I) ) + I = I + 1 + ELSE + GAIN = GAIN*( S0*( S0 - TWO*PR(I) ) + PR(I)**2 + PI(I)**2 ) + I = I + 2 + END IF + GO TO 40 + END IF +C +C END WHILE 40 +C + I = 1 +C +C WHILE ( I <= IZ ) DO +C + 50 IF ( I.LE.IZ ) THEN + IF ( ZI(I).EQ.ZERO ) THEN + GAIN = GAIN/( S0 - ZR(I) ) + I = I + 1 + ELSE + GAIN = GAIN/( S0*( S0 - TWO*ZR(I) ) + ZR(I)**2 + ZI(I)**2 ) + I = I + 2 + END IF + GO TO 50 + END IF +C +C END WHILE 50 +C + RETURN +C *** Last line of TB04BX *** + END diff --git a/mex/sources/libslicot/TB04CD.f b/mex/sources/libslicot/TB04CD.f new file mode 100644 index 000000000..012548bec --- /dev/null +++ b/mex/sources/libslicot/TB04CD.f @@ -0,0 +1,568 @@ + SUBROUTINE TB04CD( JOBD, EQUIL, N, M, P, NPZ, A, LDA, B, LDB, C, + $ LDC, D, LDD, NZ, LDNZ, NP, LDNP, ZEROSR, + $ ZEROSI, POLESR, POLESI, GAINS, LDGAIN, TOL, + $ IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the transfer function matrix G of a state-space +C representation (A,B,C,D) of a linear time-invariant multivariable +C system, using the pole-zeros method. The transfer function matrix +C is returned in a minimal pole-zero-gain form. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears in +C the given state-space model: +C = 'D': D is present; +C = 'Z': D is assumed to be a zero matrix. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system (A,B,C,D). N >= 0. +C +C M (input) INTEGER +C The number of the system inputs. M >= 0. +C +C P (input) INTEGER +C The number of the system outputs. P >= 0. +C +C NPZ (input) INTEGER +C The maximum number of poles or zeros of the single-input +C single-output channels in the system. An upper bound +C for NPZ is N. NPZ >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, if EQUIL = 'S', the leading N-by-N part of this +C array contains the balanced matrix inv(S)*A*S, as returned +C by SLICOT Library routine TB01ID. +C If EQUIL = 'N', this array is unchanged on exit. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B. +C On exit, the contents of B are destroyed: all elements but +C those in the first row are set to zero. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C. +C On exit, if EQUIL = 'S', the leading P-by-N part of this +C array contains the balanced matrix C*S, as returned by +C SLICOT Library routine TB01ID. +C If EQUIL = 'N', this array is unchanged on exit. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C If JOBD = 'D', the leading P-by-M part of this array must +C contain the matrix D. +C If JOBD = 'Z', the array D is not referenced. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P), if JOBD = 'D'; +C LDD >= 1, if JOBD = 'Z'. +C +C NZ (output) INTEGER array, dimension (LDNZ,M) +C The leading P-by-M part of this array contains the numbers +C of zeros of the elements of the transfer function +C matrix G. Specifically, the (i,j) element of NZ contains +C the number of zeros of the transfer function G(i,j) from +C the j-th input to the i-th output. +C +C LDNZ INTEGER +C The leading dimension of array NZ. LDNZ >= max(1,P). +C +C NP (output) INTEGER array, dimension (LDNP,M) +C The leading P-by-M part of this array contains the numbers +C of poles of the elements of the transfer function +C matrix G. Specifically, the (i,j) element of NP contains +C the number of poles of the transfer function G(i,j). +C +C LDNP INTEGER +C The leading dimension of array NP. LDNP >= max(1,P). +C +C ZEROSR (output) DOUBLE PRECISION array, dimension (P*M*NPZ) +C This array contains the real parts of the zeros of the +C transfer function matrix G. The real parts of the zeros +C are stored in a column-wise order, i.e., for the transfer +C functions (1,1), (2,1), ..., (P,1), (1,2), (2,2), ..., +C (P,2), ..., (1,M), (2,M), ..., (P,M); NPZ memory locations +C are reserved for each transfer function, hence, the real +C parts of the zeros for the (i,j) transfer function +C are stored starting from the location ((j-1)*P+i-1)*NPZ+1. +C Pairs of complex conjugate zeros are stored in consecutive +C memory locations. Note that only the first NZ(i,j) entries +C are initialized for the (i,j) transfer function. +C +C ZEROSI (output) DOUBLE PRECISION array, dimension (P*M*NPZ) +C This array contains the imaginary parts of the zeros of +C the transfer function matrix G, stored in a similar way +C as the real parts of the zeros. +C +C POLESR (output) DOUBLE PRECISION array, dimension (P*M*NPZ) +C This array contains the real parts of the poles of the +C transfer function matrix G, stored in the same way as +C the zeros. Note that only the first NP(i,j) entries are +C initialized for the (i,j) transfer function. +C +C POLESI (output) DOUBLE PRECISION array, dimension (P*M*NPZ) +C This array contains the imaginary parts of the poles of +C the transfer function matrix G, stored in the same way as +C the poles. +C +C GAINS (output) DOUBLE PRECISION array, dimension (LDGAIN,M) +C The leading P-by-M part of this array contains the gains +C of the transfer function matrix G. Specifically, +C GAINS(i,j) contains the gain of the transfer function +C G(i,j). +C +C LDGAIN INTEGER +C The leading dimension of array GAINS. LDGAIN >= max(1,P). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the +C controllability of a single-input system (A,b) or (A',c'), +C where b and c' are columns in B and C' (C transposed). If +C the user sets TOL > 0, then the given value of TOL is used +C as an absolute tolerance; elements with absolute value +C less than TOL are considered neglijible. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*EPS*MAX( NORM(A), NORM(bc) ) is used +C instead, where EPS is the machine precision (see LAPACK +C Library routine DLAMCH), and bc denotes the currently used +C column in B or C' (see METHOD). +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N*(N+P) + +C MAX( N + MAX( N,P ), N*(2*N+3))) +C If N >= P, N >= 1, the formula above can be written as +C LDWORK >= N*(3*N + P + 3). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the QR algorithm failed to converge when trying to +C compute the zeros of a transfer function; +C = 2: the QR algorithm failed to converge when trying to +C compute the poles of a transfer function. +C The errors INFO = 1 or 2 are unlikely to appear. +C +C METHOD +C +C The routine implements the pole-zero method proposed in [1]. +C This method is based on an algorithm for computing the transfer +C function of a single-input single-output (SISO) system. +C Let (A,b,c,d) be a SISO system. Its transfer function is computed +C as follows: +C +C 1) Find a controllable realization (Ac,bc,cc) of (A,b,c). +C 2) Find an observable realization (Ao,bo,co) of (Ac,bc,cc). +C 3) Compute the r eigenvalues of Ao (the poles of (Ao,bo,co)). +C 4) Compute the zeros of (Ao,bo,co,d). +C 5) Compute the gain of (Ao,bo,co,d). +C +C This algorithm can be implemented using only orthogonal +C transformations [1]. However, for better efficiency, the +C implementation in TB04CD uses one elementary transformation +C in Step 4 and r elementary transformations in Step 5 (to reduce +C an upper Hessenberg matrix to upper triangular form). These +C special elementary transformations are numerically stable +C in practice. +C +C In the multi-input multi-output (MIMO) case, the algorithm +C computes each element (i,j) of the transfer function matrix G, +C for i = 1 : P, and for j = 1 : M. For efficiency reasons, Step 1 +C is performed once for each value of j (each column of B). The +C matrices Ac and Ao result in Hessenberg form. +C +C REFERENCES +C +C [1] Varga, A. and Sima, V. +C Numerically Stable Algorithm for Transfer Function Matrix +C Evaluation. +C Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable in practice and requires about +C 20*N**3 floating point operations at most, but usually much less. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2002. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalue, state-space representation, transfer function, zeros. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, C100 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL, JOBD + DOUBLE PRECISION TOL + INTEGER INFO, LDA, LDB, LDC, LDD, LDGAIN, LDNP, LDNZ, + $ LDWORK, M, N, NPZ, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), GAINS(LDGAIN,*), POLESI(*), + $ POLESR(*), ZEROSI(*), ZEROSR(*) + INTEGER IWORK(*), NP(LDNP,*), NZ(LDNZ,*) +C .. Local Scalars .. + DOUBLE PRECISION ANORM, DIJ, EPSN, MAXRED, TOLDEF + INTEGER I, IA, IAC, IAS, IB, IC, ICC, IERR, IM, IP, + $ IPM1, ITAU, ITAU1, IZ, J, JWK, JWORK, JWORK1, + $ K, NCONT, WRKOPT + LOGICAL DIJNZ, FNDEIG, WITHD +C .. Local Arrays .. + DOUBLE PRECISION Z(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DHSEQR, DLACPY, MA02AD, TB01ID, + $ TB01ZD, TB04BX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar parameters. +C + INFO = 0 + WITHD = LSAME( JOBD, 'D' ) + IF( .NOT.WITHD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( NPZ.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN + INFO = -14 + ELSE IF( LDNZ.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( LDNP.LT.MAX( 1, P ) ) THEN + INFO = -18 + ELSE IF( LDGAIN.LT.MAX( 1, P ) ) THEN + INFO = -24 + ELSE IF( LDWORK.LT.MAX( 1, N*( N + P ) + + $ MAX( N + MAX( N, P ), N*( 2*N + 3 ) ) ) + $ ) THEN + INFO = -28 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB04CD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + DIJ = ZERO + IF( MIN( N, P, M ).EQ.0 ) THEN + IF( MIN( P, M ).GT.0 ) THEN +C + DO 20 J = 1, M +C + DO 10 I = 1, P + NZ(I,J) = 0 + NP(I,J) = 0 + IF ( WITHD ) + $ DIJ = D(I,J) + GAINS(I,J) = DIJ + 10 CONTINUE +C + 20 CONTINUE +C + END IF + DWORK(1) = ONE + RETURN + END IF +C +C Prepare the computation of the default tolerance. +C + TOLDEF = TOL + IF( TOLDEF.LE.ZERO ) THEN + EPSN = DBLE( N )*DLAMCH( 'Epsilon' ) + ANORM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) + END IF +C +C Initializations. +C + IA = 1 + IC = IA + N*N + ITAU = IC + P*N + JWORK = ITAU + N + IAC = ITAU +C + K = 1 +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(S)*A*S, B <- inv(S)*B and C <- C*S, where S is a +C diagonal scaling matrix. +C Workspace: need N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, IERR ) + END IF +C +C Compute the transfer function matrix of the system (A,B,C,D), +C in the pole-zero-gain form. +C + DO 80 J = 1, M +C +C Save A and C. +C Workspace: need W1 = N*(N+P). +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), N ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(IC), P ) +C +C Remove the uncontrollable part of the system (A,B(J),C). +C Workspace: need W1+N+MAX(N,P); +C prefer larger. +C + CALL TB01ZD( 'No Z', N, P, DWORK(IA), N, B(1,J), DWORK(IC), P, + $ NCONT, Z, 1, DWORK(ITAU), TOL, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + IF ( J.EQ.1 ) + $ WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 +C + IB = IAC + NCONT*NCONT + ICC = IB + NCONT + ITAU1 = ICC + NCONT + JWK = ITAU1 + NCONT + IAS = ITAU1 + JWORK1 = IAS + NCONT*NCONT +C + DO 70 I = 1, P + IF ( NCONT.GT.0 ) THEN + IF ( WITHD ) + $ DIJ = D(I,J) +C +C Form the matrices of the state-space representation of +C the dual system for the controllable part. +C Workspace: need W2 = W1+N*(N+2). +C + CALL MA02AD( 'Full', NCONT, NCONT, DWORK(IA), N, + $ DWORK(IAC), NCONT ) + CALL DCOPY( NCONT, B(1,J), 1, DWORK(IB), 1 ) + CALL DCOPY( NCONT, DWORK(IC+I-1), P, DWORK(ICC), 1 ) +C +C Remove the unobservable part of the system (A,B(J),C(I)). +C Workspace: need W2+2*N; +C prefer larger. +C + CALL TB01ZD( 'No Z', NCONT, 1, DWORK(IAC), NCONT, + $ DWORK(ICC), DWORK(IB), 1, IP, Z, 1, + $ DWORK(ITAU1), TOL, DWORK(JWK), LDWORK-JWK+1, + $ IERR ) + IF ( I.EQ.1 ) + $ WRKOPT = MAX( WRKOPT, INT( DWORK(JWK) ) + JWK - 1 ) +C + IF ( IP.GT.0 ) THEN +C +C Save the state matrix of the minimal part. +C Workspace: need W3 = W2+N*N. +C + CALL DLACPY( 'Full', IP, IP, DWORK(IAC), NCONT, + $ DWORK(IAS), IP ) +C +C Compute the poles of the transfer function. +C Workspace: need W3+N; +C prefer larger. +C + CALL DHSEQR( 'Eigenvalues', 'No vectors', IP, 1, IP, + $ DWORK(IAC), NCONT, POLESR(K), POLESI(K), + $ Z, 1, DWORK(JWORK1), LDWORK-JWORK1+1, + $ IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + WRKOPT = MAX( WRKOPT, + $ INT( DWORK(JWORK1) ) + JWORK1 - 1 ) +C +C Compute the zeros of the transfer function. +C + IPM1 = IP - 1 + DIJNZ = WITHD .AND. DIJ.NE.ZERO + FNDEIG = DIJNZ .OR. IPM1.GT.0 + IF ( .NOT.FNDEIG ) THEN + IZ = 0 + ELSE IF ( DIJNZ ) THEN +C +C Add the contribution due to D(i,j). +C Note that the matrix whose eigenvalues have to +C be computed remains in an upper Hessenberg form. +C + IZ = IP + CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS), IP, + $ DWORK(IAC), NCONT ) + CALL DAXPY( IZ, -DWORK(ICC)/DIJ, DWORK(IB), 1, + $ DWORK(IAC), NCONT ) + ELSE + IF( TOL.LE.ZERO ) + $ TOLDEF = EPSN*MAX( ANORM, + $ DLANGE( 'Frobenius', IP, 1, + $ DWORK(IB), 1, DWORK ) + $ ) +C + DO 30 IM = 1, IPM1 + IF ( ABS( DWORK(IB+IM-1) ).GT.TOLDEF ) GO TO 40 + 30 CONTINUE +C + IZ = 0 + GO TO 50 +C + 40 CONTINUE +C +C Restore (part of) the saved state matrix. +C + IZ = IP - IM + CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS+IM*(IP+1)), + $ IP, DWORK(IAC), NCONT ) +C +C Apply the output injection. +C + CALL DAXPY( IZ, -DWORK(IAS+IM*(IP+1)-IP)/ + $ DWORK(IB+IM-1), DWORK(IB+IM), 1, + $ DWORK(IAC), NCONT ) + END IF +C + IF ( FNDEIG ) THEN +C +C Find the zeros. +C Workspace: need W3+N; +C prefer larger. +C + CALL DHSEQR( 'Eigenvalues', 'No vectors', IZ, 1, + $ IZ, DWORK(IAC), NCONT, ZEROSR(K), + $ ZEROSI(K), Z, 1, DWORK(JWORK1), + $ LDWORK-JWORK1+1, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + END IF +C +C Compute the gain. +C + 50 CONTINUE + IF ( DIJNZ ) THEN + GAINS(I,J) = DIJ + ELSE + CALL TB04BX( IP, IZ, DWORK(IAS), IP, DWORK(ICC), + $ DWORK(IB), DIJ, POLESR(K), POLESI(K), + $ ZEROSR(K), ZEROSI(K), GAINS(I,J), + $ IWORK ) + END IF + NZ(I,J) = IZ + NP(I,J) = IP + ELSE +C +C Null element. +C + NZ(I,J) = 0 + NP(I,J) = 0 + END IF +C + ELSE +C +C Null element. +C + NZ(I,J) = 0 + NP(I,J) = 0 + END IF +C + K = K + NPZ + 70 CONTINUE +C + 80 CONTINUE +C + RETURN +C *** Last line of TB04CD *** + END diff --git a/mex/sources/libslicot/TB05AD.f b/mex/sources/libslicot/TB05AD.f new file mode 100644 index 000000000..c7b93e918 --- /dev/null +++ b/mex/sources/libslicot/TB05AD.f @@ -0,0 +1,545 @@ + SUBROUTINE TB05AD( BALEIG, INITA, N, M, P, FREQ, A, LDA, B, LDB, + $ C, LDC, RCOND, G, LDG, EVRE, EVIM, HINVB, + $ LDHINV, IWORK, DWORK, LDWORK, ZWORK, LZWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find the complex frequency response matrix (transfer matrix) +C G(freq) of the state-space representation (A,B,C) given by +C -1 +C G(freq) = C * ((freq*I - A) ) * B +C +C where A, B and C are real N-by-N, N-by-M and P-by-N matrices +C respectively and freq is a complex scalar. +C +C ARGUMENTS +C +C Mode Parameters +C +C BALEIG CHARACTER*1 +C Determines whether the user wishes to balance matrix A +C and/or compute its eigenvalues and/or estimate the +C condition number of the problem as follows: +C = 'N': The matrix A should not be balanced and neither +C the eigenvalues of A nor the condition number +C estimate of the problem are to be calculated; +C = 'C': The matrix A should not be balanced and only an +C estimate of the condition number of the problem +C is to be calculated; +C = 'B' or 'E' and INITA = 'G': The matrix A is to be +C balanced and its eigenvalues calculated; +C = 'A' and INITA = 'G': The matrix A is to be balanced, +C and its eigenvalues and an estimate of the +C condition number of the problem are to be +C calculated. +C +C INITA CHARACTER*1 +C Specifies whether or not the matrix A is already in upper +C Hessenberg form as follows: +C = 'G': The matrix A is a general matrix; +C = 'H': The matrix A is in upper Hessenberg form and +C neither balancing nor the eigenvalues of A are +C required. +C INITA must be set to 'G' for the first call to the +C routine, unless the matrix A is already in upper +C Hessenberg form and neither balancing nor the eigenvalues +C of A are required. Thereafter, it must be set to 'H' for +C all subsequent calls. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of states, i.e. the order of the state +C transition matrix A. N >= 0. +C +C M (input) INTEGER +C The number of inputs, i.e. the number of columns in the +C matrix B. M >= 0. +C +C P (input) INTEGER +C The number of outputs, i.e. the number of rows in the +C matrix C. P >= 0. +C +C FREQ (input) COMPLEX*16 +C The frequency freq at which the frequency response matrix +C (transfer matrix) is to be evaluated. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state transition matrix A. +C If INITA = 'G', then, on exit, the leading N-by-N part of +C this array contains an upper Hessenberg matrix similar to +C (via an orthogonal matrix consisting of a sequence of +C Householder transformations) the original state transition +C matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix B. +C If INITA = 'G', then, on exit, the leading N-by-M part of +C this array contains the product of the transpose of the +C orthogonal transformation matrix used to reduce A to upper +C Hessenberg form and the original input/state matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C If INITA = 'G', then, on exit, the leading P-by-N part of +C this array contains the product of the original output/ +C state matrix C and the orthogonal transformation matrix +C used to reduce A to upper Hessenberg form. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C RCOND (output) DOUBLE PRECISION +C If BALEIG = 'C' or BALEIG = 'A', then RCOND contains an +C estimate of the reciprocal of the condition number of +C matrix H with respect to inversion (see METHOD). +C +C G (output) COMPLEX*16 array, dimension (LDG,M) +C The leading P-by-M part of this array contains the +C frequency response matrix G(freq). +C +C LDG INTEGER +C The leading dimension of array G. LDG >= MAX(1,P). +C +C EVRE, (output) DOUBLE PRECISION arrays, dimension (N) +C EVIM If INITA = 'G' and BALEIG = 'B' or 'E' or BALEIG = 'A', +C then these arrays contain the real and imaginary parts, +C respectively, of the eigenvalues of the matrix A. +C Otherwise, these arrays are not referenced. +C +C HINVB (output) COMPLEX*16 array, dimension (LDHINV,M) +C The leading N-by-M part of this array contains the +C -1 +C product H B. +C +C LDHINV INTEGER +C The leading dimension of array HINVB. LDHINV >= MAX(1,N). +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N - 1 + MAX(N,M,P)), +C if INITA = 'G' and BALEIG = 'N', or 'B', or 'E'; +C LDWORK >= MAX(1, N + MAX(N,M-1,P-1)), +C if INITA = 'G' and BALEIG = 'C', or 'A'; +C LDWORK >= MAX(1, 2*N), +C if INITA = 'H' and BALEIG = 'C', or 'A'; +C LDWORK >= 1, otherwise. +C For optimum performance when INITA = 'G' LDWORK should be +C larger. +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK >= MAX(1,N*N+2*N), if BALEIG = 'C', or 'A'; +C LZWORK >= MAX(1,N*N), otherwise. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if more than 30*N iterations are required to +C isolate all the eigenvalues of the matrix A; the +C computations are continued; +C = 2: if either FREQ is too near to an eigenvalue of the +C matrix A, or RCOND is less than EPS, where EPS is +C the machine precision (see LAPACK Library routine +C DLAMCH). +C +C METHOD +C +C The matrix A is first balanced (if BALEIG = 'B' or 'E', or +C BALEIG = 'A') and then reduced to upper Hessenberg form; the same +C transformations are applied to the matrix B and the matrix C. +C The complex Hessenberg matrix H = (freq*I - A) is then used +C -1 +C to solve for C * H * B. +C +C Depending on the input values of parameters BALEIG and INITA, +C the eigenvalues of matrix A and the condition number of +C matrix H with respect to inversion are also calculated. +C +C REFERENCES +C +C [1] Laub, A.J. +C Efficient Calculation of Frequency Response Matrices from +C State-Space Models. +C ACM TOMS, 12, pp. 26-33, 1986. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TB01FD by A.J.Laub, University of +C Southern California, Los Angeles, CA 90089, United States of +C America, June 1982. +C +C REVISIONS +C +C V. Sima, February 22, 1998 (changed the name of TB01RD). +C V. Sima, February 12, 1999, August 7, 2003. +C A. Markovski, Technical University of Sofia, September 30, 2003. +C V. Sima, October 1, 2003. +C +C KEYWORDS +C +C Frequency response, Hessenberg form, matrix algebra, input output +C description, multivariable system, orthogonal transformation, +C similarity transformation, state-space representation, transfer +C matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ) ) +C .. Scalar Arguments .. + CHARACTER BALEIG, INITA + INTEGER INFO, LDA, LDB, LDC, LDG, LDHINV, LDWORK, + $ LZWORK, M, N, P + DOUBLE PRECISION RCOND + COMPLEX*16 FREQ +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), EVIM(*), + $ EVRE(*) + COMPLEX*16 ZWORK(*), G(LDG,*), HINVB(LDHINV,*) +C .. Local Scalars .. + CHARACTER BALANC + LOGICAL LBALBA, LBALEA, LBALEB, LBALEC, LINITA + INTEGER I, IGH, IJ, ITAU, J, JJ, JP, JWORK, K, LOW, + $ WRKOPT + DOUBLE PRECISION HNORM, T +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DASUM, DLAMCH + EXTERNAL DASUM, DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DGEBAL, DGEHRD, DHSEQR, DORMHR, DSCAL, DSWAP, + $ MB02RZ, MB02SZ, MB02TZ, XERBLA, ZLASET +C .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LBALEC = LSAME( BALEIG, 'C' ) + LBALEB = LSAME( BALEIG, 'B' ) .OR. LSAME( BALEIG, 'E' ) + LBALEA = LSAME( BALEIG, 'A' ) + LBALBA = LBALEB.OR.LBALEA + LINITA = LSAME( INITA, 'G' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LBALEC .AND. .NOT.LBALBA .AND. + $ .NOT.LSAME( BALEIG, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LINITA .AND. .NOT.LSAME( INITA, 'H' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDG.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDHINV.LT.MAX( 1, N ) ) THEN + INFO = -19 + ELSE IF( ( LINITA .AND. .NOT.LBALEC .AND. .NOT.LBALEA .AND. + $ LDWORK.LT.N - 1 + MAX( N, M, P ) ) .OR. + $ ( LINITA .AND. ( LBALEC .OR. LBALEA ) .AND. + $ LDWORK.LT.N + MAX( N, M-1, P-1 ) ) .OR. + $ ( .NOT.LINITA .AND. ( LBALEC .OR. LBALEA ) .AND. + $ LDWORK.LT.2*N ) .OR. ( LDWORK.LT.1 ) ) THEN + INFO = -22 + ELSE IF( ( ( LBALEC .OR. LBALEA ) .AND. LZWORK.LT.N*( N + 2 ) ) + $ .OR. ( LZWORK.LT.MAX( 1, N*N ) ) ) THEN + INFO = -24 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return +C + CALL XERBLA( 'TB05AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + IF ( MIN( M, P ).GT.0 ) + $ CALL ZLASET( 'Full', P, M, CZERO, CZERO, G, LDG ) + RCOND = ONE + DWORK(1) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + WRKOPT = 1 +C + IF ( LINITA ) THEN + BALANC = 'N' + IF ( LBALBA ) BALANC = 'B' +C +C Workspace: need N. +C + CALL DGEBAL( BALANC, N, A, LDA, LOW, IGH, DWORK, INFO ) + IF ( LBALBA ) THEN +C +C Adjust B and C matrices based on information in the +C vector DWORK which describes the balancing of A and is +C defined in the subroutine DGEBAL. +C + DO 10 J = 1, N + JJ = J + IF ( JJ.LT.LOW .OR. JJ.GT.IGH ) THEN + IF ( JJ.LT.LOW ) JJ = LOW - JJ + JP = DWORK(JJ) + IF ( JP.NE.JJ ) THEN +C +C Permute rows of B. +C + IF ( M.GT.0 ) + $ CALL DSWAP( M, B(JJ,1), LDB, B(JP,1), LDB ) +C +C Permute columns of C. +C + IF ( P.GT.0 ) + $ CALL DSWAP( P, C(1,JJ), 1, C(1,JP), 1 ) + END IF + END IF + 10 CONTINUE +C + IF ( IGH.NE.LOW ) THEN +C + DO 20 J = LOW, IGH + T = DWORK(J) +C +C Scale rows of permuted B. +C + IF ( M.GT.0 ) + $ CALL DSCAL( M, ONE/T, B(J,1), LDB ) +C +C Scale columns of permuted C. +C + IF ( P.GT.0 ) + $ CALL DSCAL( P, T, C(1,J), 1 ) + 20 CONTINUE +C + END IF + END IF +C +C Reduce A to Hessenberg form by orthogonal similarities and +C accumulate the orthogonal transformations into B and C. +C Workspace: need 2*N - 1; prefer N - 1 + N*NB. +C + ITAU = 1 + JWORK = ITAU + N - 1 + CALL DGEHRD( N, LOW, IGH, A, LDA, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Workspace: need N - 1 + M; prefer N - 1 + M*NB. +C + CALL DORMHR( 'Left', 'Transpose', N, M, LOW, IGH, A, LDA, + $ DWORK(ITAU), B, LDB, DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Workspace: need N - 1 + P; prefer N - 1 + P*NB. +C + CALL DORMHR( 'Right', 'No transpose', P, N, LOW, IGH, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) + IF ( LBALBA ) THEN +C +C Temporarily store Hessenberg form of A in array ZWORK. +C + IJ = 0 + DO 40 J = 1, N +C + DO 30 I = 1, N + IJ = IJ + 1 + ZWORK(IJ) = DCMPLX( A(I,J), ZERO ) + 30 CONTINUE +C + 40 CONTINUE +C +C Compute the eigenvalues of A if that option is requested. +C Workspace: need N. +C + CALL DHSEQR( 'Eigenvalues', 'No Schur', N, LOW, IGH, A, LDA, + $ EVRE, EVIM, DWORK, 1, DWORK, LDWORK, INFO ) +C +C Restore upper Hessenberg form of A. +C + IJ = 0 + DO 60 J = 1, N +C + DO 50 I = 1, N + IJ = IJ + 1 + A(I,J) = DBLE( ZWORK(IJ) ) + 50 CONTINUE +C + 60 CONTINUE +C + IF ( INFO.GT.0 ) THEN +C +C DHSEQR could not evaluate the eigenvalues of A. +C + INFO = 1 + END IF + END IF + END IF +C +C Update H := (FREQ * I) - A with appropriate value of FREQ. +C + IJ = 0 + JJ = 1 + DO 80 J = 1, N +C + DO 70 I = 1, N + IJ = IJ + 1 + ZWORK(IJ) = -DCMPLX( A(I,J), ZERO ) + 70 CONTINUE +C + ZWORK(JJ) = FREQ + ZWORK(JJ) + JJ = JJ + N + 1 + 80 CONTINUE +C + IF ( LBALEC .OR. LBALEA ) THEN +C +C Efficiently compute the 1-norm of the matrix for condition +C estimation. +C + HNORM = ZERO + JJ = 1 +C + DO 90 J = 1, N + T = ABS( ZWORK(JJ) ) + DASUM( J-1, A(1,J), 1 ) + IF ( J.LT.N ) T = T + ABS( A(J+1,J) ) + HNORM = MAX( HNORM, T ) + JJ = JJ + N + 1 + 90 CONTINUE +C + END IF +C +C Factor the complex Hessenberg matrix. +C + CALL MB02SZ( N, ZWORK, N, IWORK, INFO ) + IF ( INFO.NE.0 ) INFO = 2 +C + IF ( LBALEC .OR. LBALEA ) THEN +C +C Estimate the condition of the matrix. +C +C Workspace: need 2*N. +C + CALL MB02TZ( '1-norm', N, HNORM, ZWORK, N, IWORK, RCOND, DWORK, + $ ZWORK(N*N+1), INFO ) + WRKOPT = MAX( WRKOPT, 2*N ) + IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) INFO = 2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return: Linear system is numerically or exactly singular. +C + RETURN + END IF +C +C Compute (H-INVERSE)*B. +C + DO 110 J = 1, M +C + DO 100 I = 1, N + HINVB(I,J) = DCMPLX( B(I,J), ZERO ) + 100 CONTINUE +C + 110 CONTINUE +C + CALL MB02RZ( 'No transpose', N, M, ZWORK, N, IWORK, HINVB, LDHINV, + $ INFO ) +C +C Compute C*(H-INVERSE)*B. +C + DO 150 J = 1, M +C + DO 120 I = 1, P + G(I,J) = CZERO + 120 CONTINUE +C + DO 140 K = 1, N +C + DO 130 I = 1, P + G(I,J) = G(I,J) + DCMPLX( C(I,K), ZERO )*HINVB(K,J) + 130 CONTINUE +C + 140 CONTINUE +C + 150 CONTINUE +C +C G now contains the desired frequency response matrix. +C Set the optimal workspace. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of TB05AD *** + END diff --git a/mex/sources/libslicot/TC01OD.f b/mex/sources/libslicot/TC01OD.f new file mode 100644 index 000000000..3e7bd25ad --- /dev/null +++ b/mex/sources/libslicot/TC01OD.f @@ -0,0 +1,236 @@ + SUBROUTINE TC01OD( LERI, M, P, INDLIM, PCOEFF, LDPCO1, LDPCO2, + $ QCOEFF, LDQCO1, LDQCO2, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find the dual right (left) polynomial matrix representation of +C a given left (right) polynomial matrix representation, where the +C right and left polynomial matrix representations are of the form +C Q(s)*inv(P(s)) and inv(P(s))*Q(s) respectively. +C +C ARGUMENTS +C +C Mode Parameters +C +C LERI CHARACTER*1 +C Indicates whether a left or right matrix fraction is input +C as follows: +C = 'L': A left matrix fraction is input; +C = 'R': A right matrix fraction is input. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C INDLIM (input) INTEGER +C The highest value of K for which PCOEFF(.,.,K) and +C QCOEFF(.,.,K) are to be transposed. +C K = kpcoef + 1, where kpcoef is the maximum degree of the +C polynomials in P(s). INDLIM >= 1. +C +C PCOEFF (input/output) DOUBLE PRECISION array, dimension +C (LDPCO1,LDPCO2,INDLIM) +C If LERI = 'L' then porm = P, otherwise porm = M. +C On entry, the leading porm-by-porm-by-INDLIM part of this +C array must contain the coefficients of the denominator +C matrix P(s). +C PCOEFF(I,J,K) is the coefficient in s**(INDLIM-K) of +C polynomial (I,J) of P(s), where K = 1,2,...,INDLIM. +C On exit, the leading porm-by-porm-by-INDLIM part of this +C array contains the coefficients of the denominator matrix +C P'(s) of the dual system. +C +C LDPCO1 INTEGER +C The leading dimension of array PCOEFF. +C LDPCO1 >= MAX(1,P) if LERI = 'L', +C LDPCO1 >= MAX(1,M) if LERI = 'R'. +C +C LDPCO2 INTEGER +C The second dimension of array PCOEFF. +C LDPCO2 >= MAX(1,P) if LERI = 'L', +C LDPCO2 >= MAX(1,M) if LERI = 'R'. +C +C QCOEFF (input/output) DOUBLE PRECISION array, dimension +C (LDQCO1,LDQCO2,INDLIM) +C On entry, the leading P-by-M-by-INDLIM part of this array +C must contain the coefficients of the numerator matrix +C Q(s). +C QCOEFF(I,J,K) is the coefficient in s**(INDLIM-K) of +C polynomial (I,J) of Q(s), where K = 1,2,...,INDLIM. +C On exit, the leading M-by-P-by-INDLIM part of the array +C contains the coefficients of the numerator matrix Q'(s) +C of the dual system. +C +C LDQCO1 INTEGER +C The leading dimension of array QCOEFF. +C LDQCO1 >= MAX(1,M,P). +C +C LDQCO2 INTEGER +C The second dimension of array QCOEFF. +C LDQCO2 >= MAX(1,M,P). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C If the given M-input/P-output left (right) polynomial matrix +C representation has numerator matrix Q(s) and denominator matrix +C P(s), its dual P-input/M-output right (left) polynomial matrix +C representation simply has numerator matrix Q'(s) and denominator +C matrix P'(s). +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TC01CD by T.W.C.Williams, Kingston +C Polytechnic, United Kingdom, March 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Coprime matrix fraction, elementary polynomial operations, +C polynomial matrix, state-space representation, transfer matrix. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER LERI + INTEGER INFO, INDLIM, LDPCO1, LDPCO2, LDQCO1, LDQCO2, M, + $ P +C .. Array Arguments .. + DOUBLE PRECISION PCOEFF(LDPCO1,LDPCO2,*), QCOEFF(LDQCO1,LDQCO2,*) +C .. Local Scalars .. + LOGICAL LLERI + INTEGER J, K, MINMP, MPLIM, PORM +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LLERI = LSAME( LERI, 'L' ) + MPLIM = MAX( M, P ) + MINMP = MIN( M, P ) +C +C Test the input scalar arguments. +C + IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( INDLIM.LT.1 ) THEN + INFO = -4 + ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN + INFO = -6 + ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN + INFO = -7 + ELSE IF( LDQCO1.LT.MAX( 1, MPLIM ) ) THEN + INFO = -9 + ELSE IF( LDQCO2.LT.MAX( 1, MPLIM ) ) THEN + INFO = -10 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TC01OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( M.EQ.0 .OR. P.EQ.0 ) + $ RETURN +C + IF ( MPLIM.NE.1 ) THEN +C +C Non-scalar system: transpose numerator matrix Q(s). +C + DO 20 K = 1, INDLIM +C + DO 10 J = 1, MPLIM + IF ( J.LT.MINMP ) THEN + CALL DSWAP( MINMP-J, QCOEFF(J+1,J,K), 1, + $ QCOEFF(J,J+1,K), LDQCO1 ) + ELSE IF ( J.GT.P ) THEN + CALL DCOPY( P, QCOEFF(1,J,K), 1, QCOEFF(J,1,K), + $ LDQCO1 ) + ELSE IF ( J.GT.M ) THEN + CALL DCOPY( M, QCOEFF(J,1,K), LDQCO1, QCOEFF(1,J,K), + $ 1 ) + END IF + 10 CONTINUE +C + 20 CONTINUE +C +C Find dimension of denominator matrix P(s): M (P) for +C right (left) polynomial matrix representation. +C + PORM = M + IF ( LLERI ) PORM = P + IF ( PORM.NE.1 ) THEN +C +C Non-scalar P(s): transpose it. +C + DO 40 K = 1, INDLIM +C + DO 30 J = 1, PORM - 1 + CALL DSWAP( PORM-J, PCOEFF(J+1,J,K), 1, + $ PCOEFF(J,J+1,K), LDPCO1 ) + 30 CONTINUE +C + 40 CONTINUE +C + END IF + END IF +C + RETURN +C *** Last line of TC01OD *** + END diff --git a/mex/sources/libslicot/TC04AD.f b/mex/sources/libslicot/TC04AD.f new file mode 100644 index 000000000..d0ce99d13 --- /dev/null +++ b/mex/sources/libslicot/TC04AD.f @@ -0,0 +1,483 @@ + SUBROUTINE TC04AD( LERI, M, P, INDEX, PCOEFF, LDPCO1, LDPCO2, + $ QCOEFF, LDQCO1, LDQCO2, N, RCOND, A, LDA, B, + $ LDB, C, LDC, D, LDD, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a state-space representation (A,B,C,D) with the same +C transfer matrix T(s) as that of a given left or right polynomial +C matrix representation, i.e. +C +C C*inv(sI-A)*B + D = T(s) = inv(P(s))*Q(s) = Q(s)*inv(P(s)). +C +C ARGUMENTS +C +C Mode Parameters +C +C LERI CHARACTER*1 +C Indicates whether a left polynomial matrix representation +C or a right polynomial matrix representation is input as +C follows: +C = 'L': A left matrix fraction is input; +C = 'R': A right matrix fraction is input. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C INDEX (input) INTEGER array, dimension (MAX(M,P)) +C If LERI = 'L', INDEX(I), I = 1,2,...,P, must contain the +C maximum degree of the polynomials in the I-th row of the +C denominator matrix P(s) of the given left polynomial +C matrix representation. +C If LERI = 'R', INDEX(I), I = 1,2,...,M, must contain the +C maximum degree of the polynomials in the I-th column of +C the denominator matrix P(s) of the given right polynomial +C matrix representation. +C +C PCOEFF (input) DOUBLE PRECISION array, dimension +C (LDPCO1,LDPCO2,kpcoef), where kpcoef = MAX(INDEX(I)) + 1. +C If LERI = 'L' then porm = P, otherwise porm = M. +C The leading porm-by-porm-by-kpcoef part of this array must +C contain the coefficients of the denominator matrix P(s). +C PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) +C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if +C LERI = 'L' then iorj = I, otherwise iorj = J. +C Thus for LERI = 'L', P(s) = +C diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). +C If LERI = 'R', PCOEFF is modified by the routine but +C restored on exit. +C +C LDPCO1 INTEGER +C The leading dimension of array PCOEFF. +C LDPCO1 >= MAX(1,P) if LERI = 'L', +C LDPCO1 >= MAX(1,M) if LERI = 'R'. +C +C LDPCO2 INTEGER +C The second dimension of array PCOEFF. +C LDPCO2 >= MAX(1,P) if LERI = 'L', +C LDPCO2 >= MAX(1,M) if LERI = 'R'. +C +C QCOEFF (input) DOUBLE PRECISION array, dimension +C (LDQCO1,LDQCO2,kpcoef) +C If LERI = 'L' then porp = M, otherwise porp = P. +C The leading porm-by-porp-by-kpcoef part of this array must +C contain the coefficients of the numerator matrix Q(s). +C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). +C If LERI = 'R', QCOEFF is modified by the routine but +C restored on exit. +C +C LDQCO1 INTEGER +C The leading dimension of array QCOEFF. +C LDQCO1 >= MAX(1,P) if LERI = 'L', +C LDQCO1 >= MAX(1,M,P) if LERI = 'R'. +C +C LDQCO2 INTEGER +C The second dimension of array QCOEFF. +C LDQCO2 >= MAX(1,M) if LERI = 'L', +C LDQCO2 >= MAX(1,M,P) if LERI = 'R'. +C +C N (output) INTEGER +C The order of the resulting state-space representation. +C porm +C That is, N = SUM INDEX(I). +C I=1 +C +C RCOND (output) DOUBLE PRECISION +C The estimated reciprocal of the condition number of the +C leading row (if LERI = 'L') or the leading column (if +C LERI = 'R') coefficient matrix of P(s). +C If RCOND is nearly zero, P(s) is nearly row or column +C non-proper. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the state +C dynamics matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P)) +C The leading N-by-M part of this array contains the +C input/state matrix B; the remainder of the leading +C N-by-MAX(M,P) part is used as internal workspace. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array contains the +C state/output matrix C; the remainder of the leading +C MAX(M,P)-by-N part is used as internal workspace. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M,P). +C +C D (output) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) +C The leading P-by-M part of this array contains the direct +C transmission matrix D; the remainder of the leading +C MAX(M,P)-by-MAX(M,P) part is used as internal workspace. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,M,P). +C +C Workspace +C +C IWORK INTEGER array, dimension (2*MAX(M,P)) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,MAX(M,P)*(MAX(M,P)+4)). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if P(s) is not row (if LERI = 'L') or column +C (if LERI = 'R') proper. Consequently, no state-space +C representation is calculated. +C +C METHOD +C +C The method for a left matrix fraction will be described here; +C right matrix fractions are dealt with by obtaining the dual left +C polynomial matrix representation and constructing an equivalent +C state-space representation for this. The first step is to check +C if the denominator matrix P(s) is row proper; if it is not then +C the routine returns with the Error Indicator (INFO) set to 1. +C Otherwise, Wolovich's Observable Structure Theorem is used to +C construct a state-space representation (A,B,C,D) in observable +C companion form. The sizes of the blocks of matrix A and matrix C +C here are precisely the row degrees of P(s), while their +C 'non-trivial' columns are given easily from its coefficients. +C Similarly, the matrix D is obtained from the leading coefficients +C of P(s) and of the numerator matrix Q(s), while matrix B is given +C by the relation Sbar(s)B = Q(s) - P(s)D, where Sbar(s) is a +C polynomial matrix whose (j,k)(th) element is given by +C +C j-u(k-1)-1 +C ( s , j = u(k-1)+1,u(k-1)+2,....,u(k) +C Sbar = ( +C j,k ( 0 , otherwise +C +C k +C u(k) = SUM d , k = 1,2,...,M and d ,d ,...,d are the +C i=1 i 1 2 M +C controllability indices. For convenience in solving this, C' and B +C are initially set up to contain the coefficients of P(s) and Q(s), +C respectively, stored by rows. +C +C REFERENCES +C +C [1] Wolovich, W.A. +C Linear Multivariate Systems, (Theorem 4.3.3). +C Springer-Verlag, 1974. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TC01BD by T.W.C.Williams, Kingston +C Polytechnic, United Kingdom, March 1982. +C +C REVISIONS +C +C February 22, 1998 (changed the name of TC01ND). +C May 12, 1998. +C +C KEYWORDS +C +C Coprime matrix fraction, elementary polynomial operations, +C polynomial matrix, state-space representation, transfer matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER LERI + INTEGER INFO, LDA, LDB, LDC, LDD, LDPCO1, LDPCO2, + $ LDQCO1, LDQCO2, LDWORK, M, N, P + DOUBLE PRECISION RCOND +C .. Array Arguments .. + INTEGER INDEX(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), PCOEFF(LDPCO1,LDPCO2,*), + $ QCOEFF(LDQCO1,LDQCO2,*) +C .. Local Scalars .. + LOGICAL LLERI + INTEGER I, IA, IBIAS, J, JA, JC, JW, JWORK, LDW, K, + $ KPCOEF, KSTOP, MAXIND, MINDEX, MWORK, PWORK, + $ WRKOPT + DOUBLE PRECISION DWNORM +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL LSAME, DLAMCH, DLANGE +C .. External Subroutines .. + EXTERNAL AB07MD, DCOPY, DGECON, DGEMM, DGETRF, DGETRI, + $ DGETRS, DLACPY, DLASET, TC01OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + INFO = 0 + LLERI = LSAME( LERI, 'L' ) + MINDEX = MAX( M, P ) +C +C Test the input scalar arguments. +C + IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN + INFO = -6 + ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN + INFO = -7 + ELSE IF( ( LLERI .AND. LDQCO1.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDQCO1.LT.MAX( 1, MINDEX ) ) ) THEN + INFO = -9 + ELSE IF( ( LLERI .AND. LDQCO2.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.LLERI .AND. LDQCO2.LT.MAX( 1, MINDEX ) ) ) THEN + INFO = -10 + END IF +C + N = 0 + IF ( INFO.EQ.0 ) THEN + IF ( LLERI ) THEN + PWORK = P + MWORK = M + ELSE + PWORK = M + MWORK = P + END IF +C + MAXIND = 0 + DO 10 I = 1, PWORK + N = N + INDEX(I) + IF ( INDEX(I).GT.MAXIND ) MAXIND = INDEX(I) + 10 CONTINUE + KPCOEF = MAXIND + 1 + END IF +C + IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDC.LT.MAX( 1, MINDEX ) ) THEN + INFO = -18 + ELSE IF( LDD.LT.MAX( 1, MINDEX ) ) THEN + INFO = -20 + ELSE IF( LDWORK.LT.MAX( 1, MINDEX*( MINDEX + 4 ) ) ) THEN + INFO = -23 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TC04AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( M.EQ.0 .OR. P.EQ.0 ) THEN + N = 0 + RCOND = ONE + DWORK(1) = ONE + RETURN + END IF +C + IF ( .NOT.LLERI ) THEN +C +C Initialization for right matrix fraction: obtain the dual +C system. +C + CALL TC01OD( 'R', M, P, KPCOEF, PCOEFF, LDPCO1, LDPCO2, + $ QCOEFF, LDQCO1, LDQCO2, INFO ) + END IF +C +C Store leading row coefficient matrix of P(s). +C + LDW = MAX( 1, PWORK ) + CALL DLACPY( 'Full', PWORK, PWORK, PCOEFF, LDPCO1, DWORK, LDW ) +C +C Check if P(s) is row proper: if not, exit. +C + DWNORM = DLANGE( '1-norm', PWORK, PWORK, DWORK, LDW, DWORK ) +C + CALL DGETRF( PWORK, PWORK, DWORK, LDW, IWORK, INFO ) +C +C Workspace: need PWORK*(PWORK + 4). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + JWORK = LDW*PWORK + 1 +C + CALL DGECON( '1-norm', PWORK, DWORK, LDW, DWNORM, RCOND, + $ DWORK(JWORK), IWORK(PWORK+1), INFO ) +C + WRKOPT = MAX( 1, PWORK*(PWORK + 4) ) +C + IF ( RCOND.LE.DLAMCH( 'Epsilon' ) ) THEN +C +C Error return: P(s) is not row proper. +C + INFO = 1 + RETURN + ELSE +C +C Calculate the order of equivalent state-space representation, +C and initialize A. +C + CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA ) +C + DWORK(JWORK) = ONE + IF ( N.GT.1 ) CALL DCOPY( N-1, DWORK(JWORK), 0, A(2,1), LDA+1 ) +C +C Find the PWORK ordered 'non-trivial' columns row by row, +C in PWORK row blocks, the I-th having INDEX(I) rows. +C + IBIAS = 2 +C + DO 50 I = 1, PWORK + KSTOP = INDEX(I) + 1 + IF ( KSTOP.NE.1 ) THEN + IBIAS = IBIAS + INDEX(I) +C +C These rows given from the lower coefficients of row I +C of P(s). +C + DO 40 K = 2, KSTOP + IA = IBIAS - K +C + DO 20 J = 1, PWORK + DWORK(JWORK+J-1) = -PCOEFF(I,J,K) + 20 CONTINUE +C + CALL DGETRS( 'Transpose', PWORK, 1, DWORK, LDW, + $ IWORK, DWORK(JWORK), LDW, INFO ) +C + JA = 0 +C + DO 30 J = 1, PWORK + IF ( INDEX(J).NE.0 ) THEN + JA = JA + INDEX(J) + A(IA,JA) = DWORK(JWORK+J-1) + END IF + 30 CONTINUE +C +C Also, set up B and C (temporarily) for use when +C finding B. +C + CALL DCOPY( MWORK, QCOEFF(I,1,K), LDQCO1, B(IA,1), + $ LDB ) + CALL DCOPY( PWORK, PCOEFF(I,1,K), LDPCO1, C(1,IA), 1 ) + 40 CONTINUE +C + END IF + 50 CONTINUE +C +C Calculate D from the leading coefficients of P and Q. +C + CALL DLACPY( 'Full', PWORK, MWORK, QCOEFF, LDQCO1, D, LDD ) +C + CALL DGETRS( 'No transpose', PWORK, MWORK, DWORK, LDW, IWORK, + $ D, LDD, INFO ) +C +C For B and C as set up above, desired B = B - (C' * D). +C + CALL DGEMM( 'Transpose', 'No transpose', N, MWORK, PWORK, -ONE, + $ C, LDC, D, LDD, ONE, B, LDB ) +C +C Finally, calculate C: zero, apart from ... +C + CALL DLASET( 'Full', PWORK, N, ZERO, ZERO, C, LDC ) +C +C PWORK ordered 'non-trivial' columns, equal to those +C of inv(DWORK). +C +C Workspace: need PWORK*(PWORK + 1); +C prefer PWORK*PWORK + PWORK*NB. +C + CALL DGETRI( PWORK, DWORK, LDW, IWORK, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) + JC = 0 + JW = 1 +C + DO 60 J = 1, PWORK + IF ( INDEX(J).NE.0 ) THEN + JC = JC + INDEX(J) + CALL DCOPY( PWORK, DWORK(JW), 1, C(1,JC), 1 ) + END IF + JW = JW + LDW + 60 CONTINUE +C + END IF +C +C For right matrix fraction, return to original (dual of dual) +C system. +C + IF ( .NOT.LLERI ) THEN + CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, + $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO ) +C +C Also, obtain dual of state-space representation. +C + CALL AB07MD( 'D', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, + $ LDD, INFO ) + END IF +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of TC04AD *** + END diff --git a/mex/sources/libslicot/TC05AD.f b/mex/sources/libslicot/TC05AD.f new file mode 100644 index 000000000..fc9f65ab0 --- /dev/null +++ b/mex/sources/libslicot/TC05AD.f @@ -0,0 +1,403 @@ + SUBROUTINE TC05AD( LERI, M, P, SVAL, INDEX, PCOEFF, LDPCO1, + $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, RCOND, CFREQR, + $ LDCFRE, IWORK, DWORK, ZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To evaluate the transfer matrix T(s) of a left polynomial matrix +C representation [T(s) = inv(P(s))*Q(s)] or a right polynomial +C matrix representation [T(s) = Q(s)*inv(P(s))] at any specified +C complex frequency s = SVAL. +C +C This routine will calculate the standard frequency response +C matrix at frequency omega if SVAL is supplied as (0.0,omega). +C +C ARGUMENTS +C +C Mode Parameters +C +C LERI CHARACTER*1 +C Indicates whether a left polynomial matrix representation +C or a right polynomial matrix representation is to be used +C to evaluate the transfer matrix as follows: +C = 'L': A left matrix fraction is input; +C = 'R': A right matrix fraction is input. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C SVAL (input) COMPLEX*16 +C The frequency at which the transfer matrix or the +C frequency respose matrix is to be evaluated. +C For a standard frequency response set the real part +C of SVAL to zero. +C +C INDEX (input) INTEGER array, dimension (MAX(M,P)) +C If LERI = 'L', INDEX(I), I = 1,2,...,P, must contain the +C maximum degree of the polynomials in the I-th row of the +C denominator matrix P(s) of the given left polynomial +C matrix representation. +C If LERI = 'R', INDEX(I), I = 1,2,...,M, must contain the +C maximum degree of the polynomials in the I-th column of +C the denominator matrix P(s) of the given right polynomial +C matrix representation. +C +C PCOEFF (input) DOUBLE PRECISION array, dimension +C (LDPCO1,LDPCO2,kpcoef), where kpcoef = MAX(INDEX(I)) + 1. +C If LERI = 'L' then porm = P, otherwise porm = M. +C The leading porm-by-porm-by-kpcoef part of this array must +C contain the coefficients of the denominator matrix P(s). +C PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) +C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if +C LERI = 'L' then iorj = I, otherwise iorj = J. +C Thus for LERI = 'L', P(s) = +C diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). +C If LERI = 'R', PCOEFF is modified by the routine but +C restored on exit. +C +C LDPCO1 INTEGER +C The leading dimension of array PCOEFF. +C LDPCO1 >= MAX(1,P) if LERI = 'L', +C LDPCO1 >= MAX(1,M) if LERI = 'R'. +C +C LDPCO2 INTEGER +C The second dimension of array PCOEFF. +C LDPCO2 >= MAX(1,P) if LERI = 'L', +C LDPCO2 >= MAX(1,M) if LERI = 'R'. +C +C QCOEFF (input) DOUBLE PRECISION array, dimension +C (LDQCO1,LDQCO2,kpcoef) +C If LERI = 'L' then porp = M, otherwise porp = P. +C The leading porm-by-porp-by-kpcoef part of this array must +C contain the coefficients of the numerator matrix Q(s). +C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). +C If LERI = 'R', QCOEFF is modified by the routine but +C restored on exit. +C +C LDQCO1 INTEGER +C The leading dimension of array QCOEFF. +C LDQCO1 >= MAX(1,P) if LERI = 'L', +C LDQCO1 >= MAX(1,M,P) if LERI = 'R'. +C +C LDQCO2 INTEGER +C The second dimension of array QCOEFF. +C LDQCO2 >= MAX(1,M) if LERI = 'L', +C LDQCO2 >= MAX(1,M,P) if LERI = 'R'. +C +C RCOND (output) DOUBLE PRECISION +C The estimated reciprocal of the condition number of the +C denominator matrix P(SVAL). +C If RCOND is nearly zero, SVAL is approximately a system +C pole. +C +C CFREQR (output) COMPLEX*16 array, dimension (LDCFRE,MAX(M,P)) +C The leading porm-by-porp part of this array contains the +C frequency response matrix T(SVAL). +C +C LDCFRE INTEGER +C The leading dimension of array CFREQR. +C LDCFRE >= MAX(1,P) if LERI = 'L', +C LDCFRE >= MAX(1,M,P) if LERI = 'R'. +C +C Workspace +C +C IWORK INTEGER array, dimension (liwork) +C where liwork = P, if LERI = 'L', +C liwork = M, if LERI = 'R'. +C +C DWORK DOUBLE PRECISION array, dimension (ldwork) +C where ldwork = 2*P, if LERI = 'L', +C ldwork = 2*M, if LERI = 'R'. +C +C ZWORK COMPLEX*16 array, dimension (lzwork), +C where lzwork = P*(P+2), if LERI = 'L', +C lzwork = M*(M+2), if LERI = 'R'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if P(SVAL) is exactly or nearly singular; +C no frequency response is calculated. +C +C METHOD +C +C The method for a left matrix fraction will be described here; +C right matrix fractions are dealt with by obtaining the dual left +C fraction and calculating its frequency response (see SLICOT +C Library routine TC01OD). The first step is to calculate the +C complex value P(SVAL) of the denominator matrix P(s) at the +C desired frequency SVAL. If P(SVAL) is approximately singular, +C SVAL is approximately a pole of this system and so the frequency +C response matrix T(SVAL) is not calculated; in this case, the +C routine returns with the Error Indicator (INFO) set to 1. +C Otherwise, the complex value Q(SVAL) of the numerator matrix Q(s) +C at frequency SVAL is calculated in a similar way to P(SVAL), and +C the desired response matrix T(SVAL) = inv(P(SVAL))*Q(SVAL) is +C found by solving the corresponding system of complex linear +C equations. +C +C REFERENCES +C +C None +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TC01AD by T.W.C.Williams, Kingston +C Polytechnic, United Kingdom, March 1982. +C +C REVISIONS +C +C February 22, 1998 (changed the name of TC01MD). +C +C KEYWORDS +C +C Coprime matrix fraction, elementary polynomial operations, +C polynomial matrix, state-space representation, transfer matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER LERI + INTEGER INFO, LDCFRE, LDPCO1, LDPCO2, LDQCO1, LDQCO2, M, + $ P + DOUBLE PRECISION RCOND + COMPLEX*16 SVAL +C .. Array Arguments .. + INTEGER INDEX(*), IWORK(*) + DOUBLE PRECISION DWORK(*), PCOEFF(LDPCO1,LDPCO2,*), + $ QCOEFF(LDQCO1,LDQCO2,*) + COMPLEX*16 CFREQR(LDCFRE,*), ZWORK(*) +C .. Local Scalars .. + LOGICAL LLERI + INTEGER I, IZWORK, IJ, INFO1, J, K, KPCOEF, LDZWOR, + $ MAXIND, MINMP, MPLIM, MWORK, PWORK + DOUBLE PRECISION CNORM +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL DLAMCH, LSAME, ZLANGE +C .. External Subroutines .. + EXTERNAL TC01OD, XERBLA, ZCOPY, ZGECON, ZGETRF, ZGETRS, + $ ZSWAP +C .. Intrinsic Functions .. + INTRINSIC DCMPLX, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LLERI = LSAME( LERI, 'L' ) + MPLIM = MAX( M, P ) +C +C Test the input scalar arguments. +C + IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN + INFO = -7 + ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN + INFO = -8 + ELSE IF( ( LLERI .AND. LDQCO1.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDQCO1.LT.MAX( 1, M, P ) ) ) THEN + INFO = -10 + ELSE IF( ( LLERI .AND. LDQCO2.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.LLERI .AND. LDQCO2.LT.MAX( 1, MPLIM ) ) ) THEN + INFO = -11 + ELSE IF( ( LLERI .AND. LDCFRE.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDCFRE.LT.MAX( 1, MPLIM ) ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TC05AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( M.EQ.0 .OR. P.EQ.0 ) THEN + RCOND = ONE + RETURN + END IF +C + IF ( LLERI ) THEN +C +C Initialization for left matrix fraction. +C + PWORK = P + MWORK = M + ELSE +C +C Initialization for right matrix fraction: obtain dual system. +C + PWORK = M + MWORK = P + IF ( MPLIM.GT.1 ) + $ CALL TC01OD( 'R', M, P, KPCOEF, PCOEFF, LDPCO1, LDPCO2, + $ QCOEFF, LDQCO1, LDQCO2, INFO ) + END IF +C + LDZWOR = PWORK + IZWORK = LDZWOR*LDZWOR + 1 + MAXIND = 0 +C + DO 10 I = 1, PWORK + IF ( INDEX(I).GT.MAXIND ) MAXIND = INDEX(I) + 10 CONTINUE +C + KPCOEF = MAXIND + 1 +C +C Calculate the complex denominator matrix P(SVAL), row by row. +C + DO 50 I = 1, PWORK + IJ = I +C + DO 20 J = 1, PWORK + ZWORK(IJ) = DCMPLX( PCOEFF(I,J,1), ZERO ) + IJ = IJ + PWORK + 20 CONTINUE +C +C Possibly non-constant row: finish evaluating it. +C + DO 40 K = 2, INDEX(I) + 1 +C + IJ = I +C + DO 30 J = 1, PWORK + ZWORK(IJ) = ( SVAL*ZWORK(IJ) ) + + $ DCMPLX( PCOEFF(I,J,K), ZERO ) + IJ = IJ + PWORK + 30 CONTINUE +C + 40 CONTINUE +C + 50 CONTINUE +C +C Check if this P(SVAL) is singular: if so, don't compute T(SVAL). +C Note that DWORK is not actually referenced in ZLANGE routine. +C + CNORM = ZLANGE( '1-norm', PWORK, PWORK, ZWORK, LDZWOR, DWORK ) +C + CALL ZGETRF( PWORK, PWORK, ZWORK, LDZWOR, IWORK, INFO ) +C + IF ( INFO.GT.0 ) THEN +C +C Singular matrix. Set INFO and RCOND for error return. +C + INFO = 1 + RCOND = ZERO + ELSE +C +C Estimate the reciprocal condition of P(SVAL). +C Workspace: ZWORK: PWORK*PWORK + 2*PWORK, DWORK: 2*PWORK. +C + CALL ZGECON( '1-norm', PWORK, ZWORK, LDZWOR, CNORM, RCOND, + $ ZWORK(IZWORK), DWORK, INFO ) +C + IF ( RCOND.LE.DLAMCH( 'Epsilon' ) ) THEN +C +C Nearly singular matrix. Set INFO for error return. +C + INFO = 1 + ELSE +C +C Calculate the complex numerator matrix Q(SVAL), row by row. +C + DO 90 I = 1, PWORK +C + DO 60 J = 1, MWORK + CFREQR(I,J) = DCMPLX( QCOEFF(I,J,1), ZERO ) + 60 CONTINUE +C +C Possibly non-constant row: finish evaluating it. +C + DO 80 K = 2, INDEX(I) + 1 +C + DO 70 J = 1, MWORK + CFREQR(I,J) = ( SVAL*CFREQR(I,J) ) + + $ DCMPLX( QCOEFF(I,J,K), ZERO ) + 70 CONTINUE +C + 80 CONTINUE +C + 90 CONTINUE +C +C Now calculate frequency response T(SVAL). +C + CALL ZGETRS( 'No transpose', PWORK, MWORK, ZWORK, LDZWOR, + $ IWORK, CFREQR, LDCFRE, INFO ) + END IF + END IF +C +C For right matrix fraction, return to original (dual of the dual) +C system. +C + IF ( ( .NOT.LLERI ) .AND. ( MPLIM.NE.1 ) ) THEN + CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, + $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO1 ) +C + IF ( INFO.EQ.0 ) THEN +C +C Also, transpose T(SVAL) here if this was successfully +C calculated. +C + MINMP = MIN( M, P ) +C + DO 100 J = 1, MPLIM + IF ( J.LT.MINMP ) THEN + CALL ZSWAP( MINMP-J, CFREQR(J+1,J), 1, CFREQR(J,J+1), + $ LDCFRE ) + ELSE IF ( J.GT.P ) THEN + CALL ZCOPY( P, CFREQR(1,J), 1, CFREQR(J,1), LDCFRE ) + ELSE IF ( J.GT.M ) THEN + CALL ZCOPY( M, CFREQR(J,1), LDCFRE, CFREQR(1,J), 1 ) + END IF + 100 CONTINUE +C + END IF + END IF +C + RETURN +C *** Last line of TC05AD *** + END diff --git a/mex/sources/libslicot/TD03AD.f b/mex/sources/libslicot/TD03AD.f new file mode 100644 index 000000000..b06678a78 --- /dev/null +++ b/mex/sources/libslicot/TD03AD.f @@ -0,0 +1,581 @@ + SUBROUTINE TD03AD( ROWCOL, LERI, EQUIL, M, P, INDEXD, DCOEFF, + $ LDDCOE, UCOEFF, LDUCO1, LDUCO2, NR, A, LDA, B, + $ LDB, C, LDC, D, LDD, INDEXP, PCOEFF, LDPCO1, + $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, VCOEFF, LDVCO1, + $ LDVCO2, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a relatively prime left or right polynomial matrix +C representation for a proper transfer matrix T(s) given as either +C row or column polynomial vectors over common denominator +C polynomials, possibly with uncancelled common terms. +C +C ARGUMENTS +C +C Mode Parameters +C +C ROWCOL CHARACTER*1 +C Indicates whether T(s) is to be factorized by rows or by +C columns as follows: +C = 'R': T(s) is factorized by rows; +C = 'C': T(s) is factorized by columns. +C +C LERI CHARACTER*1 +C Indicates whether a left or a right polynomial matrix +C representation is required as follows: +C = 'L': A left polynomial matrix representation +C inv(P(s))*Q(s) is required; +C = 'R': A right polynomial matrix representation +C Q(s)*inv(P(s)) is required. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to balance the triplet +C (A,B,C), before computing a minimal state-space +C representation, as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C INDEXD (input) INTEGER array, dimension (P), if ROWCOL = 'R', or +C dimension (M), if ROWCOL = 'C'. +C The leading pormd elements of this array must contain the +C row degrees of the denominator polynomials in D(s). +C pormd = P if the transfer matrix T(s) is given as row +C polynomial vectors over denominator polynomials; +C pormd = M if the transfer matrix T(s) is given as column +C polynomial vectors over denominator polynomials. +C +C DCOEFF (input) DOUBLE PRECISION array, dimension (LDDCOE,kdcoef), +C where kdcoef = MAX(INDEXD(I)) + 1. +C The leading pormd-by-kdcoef part of this array must +C contain the coefficients of each denominator polynomial. +C DCOEFF(I,K) is the coefficient in s**(INDEXD(I)-K+1) of +C the I-th denominator polynomial in D(s), where K = 1,2, +C ...,kdcoef. +C +C LDDCOE INTEGER +C The leading dimension of array DCOEFF. +C LDDCOE >= MAX(1,P), if ROWCOL = 'R'; +C LDDCOE >= MAX(1,M), if ROWCOL = 'C'. +C +C UCOEFF (input) DOUBLE PRECISION array, dimension +C (LDUCO1,LDUCO2,kdcoef) +C The leading P-by-M-by-kdcoef part of this array must +C contain the coefficients of the numerator matrix U(s); +C if ROWCOL = 'C', this array is modified internally but +C restored on exit, and the remainder of the leading +C MAX(M,P)-by-MAX(M,P)-by-kdcoef part is used as internal +C workspace. +C UCOEFF(I,J,K) is the coefficient in s**(INDEXD(iorj)-K+1) +C of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef; +C iorj = I if T(s) is given as row polynomial vectors over +C denominator polynomials; iorj = J if T(s) is given as +C column polynomial vectors over denominator polynomials. +C Thus for ROWCOL = 'R', U(s) = +C diag(s**INDEXD(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...). +C +C LDUCO1 INTEGER +C The leading dimension of array UCOEFF. +C LDUCO1 >= MAX(1,P), if ROWCOL = 'R'; +C LDUCO1 >= MAX(1,M,P), if ROWCOL = 'C'. +C +C LDUCO2 INTEGER +C The second dimension of array UCOEFF. +C LDUCO2 >= MAX(1,M), if ROWCOL = 'R'; +C LDUCO2 >= MAX(1,M,P), if ROWCOL = 'C'. +C +C NR (output) INTEGER +C The order of the resulting minimal realization, i.e. the +C order of the state dynamics matrix A. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N), +C pormd +C where N = SUM INDEXD(I) +C I=1 +C The leading NR-by-NR part of this array contains the upper +C block Hessenberg state dynamics matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P)) +C The leading NR-by-M part of this array contains the +C input/state matrix B; the remainder of the leading +C N-by-MAX(M,P) part is used as internal workspace. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-NR part of this array contains the +C state/output matrix C; the remainder of the leading +C MAX(M,P)-by-N part is used as internal workspace. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M,P). +C +C D (output) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) +C The leading P-by-M part of this array contains the direct +C transmission matrix D; the remainder of the leading +C MAX(M,P)-by-MAX(M,P) part is used as internal workspace. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,M,P). +C +C INDEXP (output) INTEGER array, dimension (P), if ROWCOL = 'R', or +C dimension (M), if ROWCOL = 'C'. +C The leading pormp elements of this array contain the +C row (column if ROWCOL = 'C') degrees of the denominator +C matrix P(s). +C pormp = P if a left polynomial matrix representation +C is requested; pormp = M if a right polynomial matrix +C representation is requested. +C These elements are ordered so that +C INDEXP(1) >= INDEXP(2) >= ... >= INDEXP(pormp). +C +C PCOEFF (output) DOUBLE PRECISION array, dimension +C (LDPCO1,LDPCO2,N+1) +C The leading pormp-by-pormp-by-kpcoef part of this array +C contains the coefficients of the denominator matrix P(s), +C where kpcoef = MAX(INDEXP(I)) + 1. +C PCOEFF(I,J,K) is the coefficient in s**(INDEXP(iorj)-K+1) +C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; +C iorj = I if a left polynomial matrix representation is +C requested; iorj = J if a right polynomial matrix +C representation is requested. +C Thus for a left polynomial matrix representation, P(s) = +C diag(s**INDEXP(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). +C +C LDPCO1 INTEGER +C The leading dimension of array PCOEFF. +C LDPCO1 >= MAX(1,P), if ROWCOL = 'R'; +C LDPCO1 >= MAX(1,M), if ROWCOL = 'C'. +C +C LDPCO2 INTEGER +C The second dimension of array PCOEFF. +C LDPCO2 >= MAX(1,P), if ROWCOL = 'R'; +C LDPCO2 >= MAX(1,M), if ROWCOL = 'C'. +C +C QCOEFF (output) DOUBLE PRECISION array, dimension +C (LDQCO1,LDQCO2,N+1) +C The leading pormp-by-pormd-by-kpcoef part of this array +C contains the coefficients of the numerator matrix Q(s). +C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). +C +C LDQCO1 INTEGER +C The leading dimension of array QCOEFF. +C If LERI = 'L', LDQCO1 >= MAX(1,PM), +C where PM = P, if ROWCOL = 'R'; +C PM = M, if ROWCOL = 'C'. +C If LERI = 'R', LDQCO1 >= MAX(1,M,P). +C +C LDQCO2 INTEGER +C The second dimension of array QCOEFF. +C If LERI = 'L', LDQCO2 >= MAX(1,MP), +C where MP = M, if ROWCOL = 'R'; +C MP = P, if ROWCOL = 'C'. +C If LERI = 'R', LDQCO2 >= MAX(1,M,P). +C +C VCOEFF (output) DOUBLE PRECISION array, dimension +C (LDVCO1,LDVCO2,N+1) +C The leading pormp-by-NR-by-kpcoef part of this array +C contains the coefficients of the intermediate matrix +C V(s) as produced by SLICOT Library routine TB03AD. +C +C LDVCO1 INTEGER +C The leading dimension of array VCOEFF. +C LDVCO1 >= MAX(1,P), if ROWCOL = 'R'; +C LDVCO1 >= MAX(1,M), if ROWCOL = 'C'. +C +C LDVCO2 INTEGER +C The second dimension of array VCOEFF. LDVCO2 >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determination when +C transforming (A, B, C). If the user sets TOL > 0, then +C the given value of TOL is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance +C (determined by the SLICOT routine TB01UD) is used instead. +C +C Workspace +C +C IWORK INTEGER array, dimension (N+MAX(M,P)) +C On exit, if INFO = 0, the first nonzero elements of +C IWORK(1:N) return the orders of the diagonal blocks of A. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P), PM*(PM + 2)) +C where PM = P, if ROWCOL = 'R'; +C PM = M, if ROWCOL = 'C'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i (i <= k = pormd), then i is the first +C integer I for which ABS( DCOEFF(I,1) ) is so small +C that the calculations would overflow (see SLICOT +C Library routine TD03AY); that is, the leading +C coefficient of a polynomial is nearly zero; no +C state-space representation or polynomial matrix +C representation is calculated; +C = k+1: if a singular matrix was encountered during the +C computation of V(s); +C = k+2: if a singular matrix was encountered during the +C computation of P(s). +C +C METHOD +C +C The method for transfer matrices factorized by rows will be +C described here; T(s) factorized by columns is dealt with by +C operating on the dual T'(s). The description for T(s) is actually +C the left polynomial matrix representation +C +C T(s) = inv(D(s))*U(s), +C +C where D(s) is diagonal with its (I,I)-th polynomial element of +C degree INDEXD(I). The first step is to check whether the leading +C coefficient of any polynomial element of D(s) is approximately +C zero, if so the routine returns with INFO > 0. Otherwise, +C Wolovich's Observable Structure Theorem is used to construct a +C state-space representation in observable companion form which is +C equivalent to the above polynomial matrix representation. The +C method is particularly easy here due to the diagonal form of D(s). +C This state-space representation is not necessarily controllable +C (as D(s) and U(s) are not necessarily relatively left prime), but +C it is in theory completely observable; however, its observability +C matrix may be poorly conditioned, so it is treated as a general +C state-space representation and SLICOT Library routine TB03AD is +C used to separate out a minimal realization for T(s) from it by +C means of orthogonal similarity transformations and then to +C calculate a relatively prime (left or right) polynomial matrix +C representation which is equivalent to this. +C +C REFERENCES +C +C [1] Patel, R.V. +C On Computing Matrix Fraction Descriptions and Canonical +C Forms of Linear Time-Invariant Systems. +C UMIST Control Systems Centre Report 489, 1980. +C +C [2] Wolovich, W.A. +C Linear Multivariable Systems, (Theorem 4.3.3). +C Springer-Verlag, 1974. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998. +C Supersedes Release 3.0 routine TD01ND. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Coprime matrix fraction, elementary polynomial operations, +C polynomial matrix, state-space representation, transfer matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL, LERI, ROWCOL + INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDPCO1, + $ LDPCO2, LDQCO1, LDQCO2, LDUCO1, LDUCO2, LDVCO1, + $ LDVCO2, LDWORK, M, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER INDEXD(*), INDEXP(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DCOEFF(LDDCOE,*), DWORK(*), + $ PCOEFF(LDPCO1,LDPCO2,*), + $ QCOEFF(LDQCO1,LDQCO2,*), + $ UCOEFF(LDUCO1,LDUCO2,*), VCOEFF(LDVCO1,LDVCO2,*) +C .. Local Scalars .. + LOGICAL LEQUIL, LLERI, LROWCO + INTEGER I, IDUAL, ITEMP, J, JSTOP, K, KDCOEF, KPCOEF, + $ MAXMP, MPLIM, MWORK, N, PWORK +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB07MD, DLACPY, DSWAP, TB01XD, TB03AD, TC01OD, + $ TD03AY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 + LROWCO = LSAME( ROWCOL, 'R' ) + LLERI = LSAME( LERI, 'L' ) + LEQUIL = LSAME( EQUIL, 'S' ) +C +C Test the input scalar arguments. +C + MAXMP = MAX( M, P ) + MPLIM = MAX( 1, MAXMP ) + IF ( LROWCO ) THEN +C +C Initialization for T(s) given as rows over common denominators. +C + PWORK = P + MWORK = M + ELSE +C +C Initialization for T(s) given as columns over common +C denominators. +C + PWORK = M + MWORK = P + END IF +C + IF( .NOT.LROWCO .AND. .NOT.LSAME( ROWCOL, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDDCOE.LT.MAX( 1, PWORK ) ) THEN + INFO = -8 + ELSE IF( LDUCO1.LT.MAX( 1, PWORK ) .OR. ( .NOT.LROWCO .AND. + $ LDUCO1.LT.MPLIM ) ) THEN + INFO = -10 + ELSE IF( LDUCO2.LT.MAX( 1, MWORK ) .OR. ( .NOT.LROWCO .AND. + $ LDUCO2.LT.MPLIM ) ) THEN + INFO = -11 + END IF +C + N = 0 + IF ( INFO.EQ.0 ) THEN +C +C Calculate N, the order of the resulting state-space +C representation, and the index kdcoef. +C + KDCOEF = 0 +C + DO 10 I = 1, PWORK + KDCOEF = MAX( KDCOEF, INDEXD(I) ) + N = N + INDEXD(I) + 10 CONTINUE +C + KDCOEF = KDCOEF + 1 +C + IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDC.LT.MPLIM ) THEN + INFO = -18 + ELSE IF( LDD.LT.MPLIM ) THEN + INFO = -20 + ELSE IF( LDPCO1.LT.PWORK ) THEN + INFO = -23 + ELSE IF( LDPCO2.LT.PWORK ) THEN + INFO = -24 + ELSE IF( LDQCO1.LT.MAX( 1, PWORK ) .OR. ( .NOT.LLERI .AND. + $ LDQCO1.LT.MPLIM ) ) THEN + INFO = -26 + ELSE IF( LDQCO2.LT.MAX( 1, MWORK ) .OR. ( .NOT.LLERI .AND. + $ LDQCO2.LT.MPLIM ) ) THEN + INFO = -27 + ELSE IF( LDVCO1.LT.MAX( 1, PWORK ) ) THEN + INFO = -29 + ELSE IF( LDVCO2.LT.MAX( 1, N ) ) THEN + INFO = -30 +C + ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*MAXMP ), + $ PWORK*( PWORK + 2 ) ) ) THEN + INFO = -34 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TD03AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, M, P ).EQ.0 ) THEN + NR = 0 + DWORK(1) = ONE + RETURN + END IF +C +C IDUAL = 1 iff precisely ROWCOL = 'C' or (exclusively) LERI = 'R', +C i.e. iff AB07MD call is required before TB03AD. +C + IDUAL = 0 + IF ( .NOT.LROWCO ) IDUAL = 1 + IF ( .NOT.LLERI ) IDUAL = IDUAL + 1 +C + IF ( .NOT.LROWCO ) THEN +C +C Initialize the remainder of the leading +C MPLIM-by-MPLIM-by-KDCOEF part of U(s) to zero. +C + IF ( P.LT.M ) THEN +C + DO 20 K = 1, KDCOEF + CALL DLACPY( 'Full', M-P, MPLIM, ZERO, ZERO, + $ UCOEFF(P+1,1,K), LDUCO1 ) + 20 CONTINUE +C + ELSE IF ( P.GT.M ) THEN +C + DO 30 K = 1, KDCOEF + CALL DLACPY( 'Full', MPLIM, P-M, ZERO, ZERO, + $ UCOEFF(1,M+1,K), LDUCO1 ) + 30 CONTINUE +C + END IF +C + IF ( MPLIM.NE.1 ) THEN +C +C Non-scalar T(s) factorized by columns: transpose it +C (i.e. U(s)). +C + JSTOP = MPLIM - 1 +C + DO 50 K = 1, KDCOEF +C + DO 40 J = 1, JSTOP + CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, + $ UCOEFF(J,J+1,K), LDUCO1 ) + 40 CONTINUE +C + 50 CONTINUE +C + END IF + END IF +C +C Construct non-minimal state-space representation (by Wolovich's +C Structure Theorem) which has transfer matrix T(s) or T'(s) as +C appropriate, +C + CALL TD03AY( MWORK, PWORK, INDEXD, DCOEFF, LDDCOE, UCOEFF, LDUCO1, + $ LDUCO2, N, A, LDA, B, LDB, C, LDC, D, LDD, INFO ) + IF ( INFO.GT.0 ) + $ RETURN +C + IF ( IDUAL.EQ.1 ) THEN +C +C and then obtain (MWORK x PWORK) dual of this system if +C appropriate. +C + CALL AB07MD( 'D', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, + $ LDD, INFO ) + ITEMP = PWORK + PWORK = MWORK + MWORK = ITEMP + END IF +C +C Find left polynomial matrix representation (and minimal +C state-space representation en route) for the relevant state-space +C representation ... +C + CALL TB03AD( 'Left', EQUIL, N, MWORK, PWORK, A, LDA, B, LDB, C, + $ LDC, D, LDD, NR, INDEXP, PCOEFF, LDPCO1, LDPCO2, + $ QCOEFF, LDQCO1, LDQCO2, VCOEFF, LDVCO1, LDVCO2, TOL, + $ IWORK, DWORK, LDWORK, INFO ) +C + IF ( INFO.GT.0 ) THEN + INFO = PWORK + INFO + RETURN + END IF +C + IF ( .NOT.LLERI ) THEN +C +C and, if a right polynomial matrix representation is required, +C transpose and reorder (to get a block upper Hessenberg +C matrix A). +C + K = IWORK(1) - 1 + IF ( N.GE.2 ) + $ K = K + IWORK(2) + CALL TB01XD( 'D', NR, MWORK, PWORK, K, NR-1, A, LDA, B, LDB, C, + $ LDC, D, LDD, INFO ) +C + KPCOEF = 0 +C + DO 60 I = 1, PWORK + KPCOEF = MAX( KPCOEF, INDEXP(I) ) + 60 CONTINUE +C + KPCOEF = KPCOEF + 1 + CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, LDPCO2, + $ QCOEFF, LDQCO1, LDQCO2, INFO ) + END IF +C + IF ( ( .NOT.LROWCO ) .AND. ( MPLIM.NE.1 ) ) THEN +C +C If non-scalar T(s) originally given by columns, +C retranspose U(s). +C + DO 80 K = 1, KDCOEF +C + DO 70 J = 1, JSTOP + CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, UCOEFF(J,J+1,K), + $ LDUCO1 ) + 70 CONTINUE +C + 80 CONTINUE +C + END IF + RETURN +C *** Last line of TD03AD *** + END diff --git a/mex/sources/libslicot/TD03AY.f b/mex/sources/libslicot/TD03AY.f new file mode 100644 index 000000000..90d53eee2 --- /dev/null +++ b/mex/sources/libslicot/TD03AY.f @@ -0,0 +1,171 @@ + SUBROUTINE TD03AY( MWORK, PWORK, INDEX, DCOEFF, LDDCOE, UCOEFF, + $ LDUCO1, LDUCO2, N, A, LDA, B, LDB, C, LDC, D, + $ LDD, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C Calculates a state-space representation for a (PWORK x MWORK) +C transfer matrix given in the form of polynomial row vectors over +C common denominators (not necessarily lcd's). Such a description +C is simply the polynomial matrix representation +C +C T(s) = inv(D(s)) * U(s), +C +C where D(s) is diagonal with (I,I)-th element D:I(s) of degree +C INDEX(I); applying Wolovich's Observable Structure Theorem to +C this left matrix fraction then yields an equivalent state-space +C representation in observable companion form, of order +C N = sum(INDEX(I)). As D(s) is diagonal, the PWORK ordered +C 'non-trivial' columns of C and A are very simply calculated, these +C submatrices being diagonal and (INDEX(I) x 1) - block diagonal, +C respectively: finding B and D is also somewhat simpler than for +C general P(s) as dealt with in TC04AD. Finally, the state-space +C representation obtained here is not necessarily controllable +C (as D(s) and U(s) are not necessarily relatively left prime), but +C it is theoretically completely observable: however, its +C observability matrix may be poorly conditioned, so it is safer +C not to assume observability either. +C +C REVISIONS +C +C May 13, 1998. +C +C KEYWORDS +C +C Coprime matrix fraction, elementary polynomial operations, +C polynomial matrix, state-space representation, transfer matrix. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, + $ LDUCO2, MWORK, N, PWORK +C .. Array Arguments .. + INTEGER INDEX(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DCOEFF(LDDCOE,*), UCOEFF(LDUCO1,LDUCO2,*) +C .. Local Scalars .. + INTEGER I, IA, IBIAS, INDCUR, JA, JMAX1, K + DOUBLE PRECISION ABSDIA, ABSDMX, BIGNUM, DIAG, SMLNUM, UMAX1, + $ TEMP +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, IDAMAX +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DLASET, DSCAL +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + INFO = 0 +C +C Initialize A and C to be zero, apart from 1's on the subdiagonal +C of A. +C + CALL DLASET( 'Upper', N, N, ZERO, ZERO, A, LDA ) + IF ( N.GT.1 ) CALL DLASET( 'Lower', N-1, N-1, ZERO, ONE, A(2,1), + $ LDA ) +C + CALL DLASET( 'Full', PWORK, N, ZERO, ZERO, C, LDC ) +C +C Calculate B and D, as well as 'non-trivial' elements of A and C. +C Check if any leading coefficient of D(s) nearly zero: if so, exit. +C Caution is taken to avoid overflow. +C + SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM +C + IBIAS = 2 + JA = 0 +C + DO 20 I = 1, PWORK + ABSDIA = ABS( DCOEFF(I,1) ) + JMAX1 = IDAMAX( MWORK, UCOEFF(I,1,1), LDUCO1 ) + UMAX1 = ABS( UCOEFF(I,JMAX1,1) ) + IF ( ( ABSDIA.LT.SMLNUM ) .OR. + $ ( ABSDIA.LT.ONE .AND. UMAX1.GT.ABSDIA*BIGNUM ) ) THEN +C +C Error return. +C + INFO = I + RETURN + END IF + DIAG = ONE/DCOEFF(I,1) + INDCUR = INDEX(I) + IF ( INDCUR.NE.0 ) THEN + IBIAS = IBIAS + INDCUR + JA = JA + INDCUR + IF ( INDCUR.GE.1 ) THEN + JMAX1 = IDAMAX( INDCUR, DCOEFF(I,2), LDDCOE ) + ABSDMX = ABS( DCOEFF(I,JMAX1) ) + IF ( ABSDIA.GE.ONE ) THEN + IF ( UMAX1.GT.ONE ) THEN + IF ( ( ABSDMX/ABSDIA ).GT.( BIGNUM/UMAX1 ) ) THEN +C +C Error return. +C + INFO = I + RETURN + END IF + END IF + ELSE + IF ( UMAX1.GT.ONE ) THEN + IF ( ABSDMX.GT.( BIGNUM*ABSDIA )/UMAX1 ) THEN +C +C Error return. +C + INFO = I + RETURN + END IF + END IF + END IF + END IF +C +C I-th 'non-trivial' sub-vector of A given from coefficients +C of D:I(s), while I-th row block of B given from this and +C row I of U(s). +C + DO 10 K = 2, INDCUR + 1 + IA = IBIAS - K + TEMP = -DIAG*DCOEFF(I,K) + A(IA,JA) = TEMP +C + CALL DCOPY( MWORK, UCOEFF(I,1,K), LDUCO1, B(IA,1), LDB ) + CALL DAXPY( MWORK, TEMP, UCOEFF(I,1,1), LDUCO1, B(IA,1), + $ LDB ) + 10 CONTINUE +C + IF ( JA.LT.N ) A(JA+1,JA) = ZERO +C +C Finally, I-th 'non-trivial' entry of C and row of D obtained +C also. +C + C(I,JA) = DIAG + END IF +C + CALL DCOPY( MWORK, UCOEFF(I,1,1), LDUCO1, D(I,1), LDD ) + CALL DSCAL( MWORK, DIAG, D(I,1), LDD ) + 20 CONTINUE +C + RETURN +C *** Last line of TD03AY *** + END diff --git a/mex/sources/libslicot/TD04AD.f b/mex/sources/libslicot/TD04AD.f new file mode 100644 index 000000000..9297cee09 --- /dev/null +++ b/mex/sources/libslicot/TD04AD.f @@ -0,0 +1,425 @@ + SUBROUTINE TD04AD( ROWCOL, M, P, INDEX, DCOEFF, LDDCOE, UCOEFF, + $ LDUCO1, LDUCO2, NR, A, LDA, B, LDB, C, LDC, D, + $ LDD, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a minimal state-space representation (A,B,C,D) for a +C proper transfer matrix T(s) given as either row or column +C polynomial vectors over denominator polynomials, possibly with +C uncancelled common terms. +C +C ARGUMENTS +C +C Mode Parameters +C +C ROWCOL CHARACTER*1 +C Indicates whether the transfer matrix T(s) is given as +C rows or columns over common denominators as follows: +C = 'R': T(s) is given as rows over common denominators; +C = 'C': T(s) is given as columns over common denominators. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C INDEX (input) INTEGER array, dimension (porm), where porm = P, +C if ROWCOL = 'R', and porm = M, if ROWCOL = 'C'. +C This array must contain the degrees of the denominator +C polynomials in D(s). +C +C DCOEFF (input) DOUBLE PRECISION array, dimension (LDDCOE,kdcoef), +C where kdcoef = MAX(INDEX(I)) + 1. +C The leading porm-by-kdcoef part of this array must contain +C the coefficients of each denominator polynomial. +C DCOEFF(I,K) is the coefficient in s**(INDEX(I)-K+1) of the +C I-th denominator polynomial in D(s), where +C K = 1,2,...,kdcoef. +C +C LDDCOE INTEGER +C The leading dimension of array DCOEFF. +C LDDCOE >= MAX(1,P) if ROWCOL = 'R'; +C LDDCOE >= MAX(1,M) if ROWCOL = 'C'. +C +C UCOEFF (input) DOUBLE PRECISION array, dimension +C (LDUCO1,LDUCO2,kdcoef) +C The leading P-by-M-by-kdcoef part of this array must +C contain the numerator matrix U(s); if ROWCOL = 'C', this +C array is modified internally but restored on exit, and the +C remainder of the leading MAX(M,P)-by-MAX(M,P)-by-kdcoef +C part is used as internal workspace. +C UCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) +C of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef; +C if ROWCOL = 'R' then iorj = I, otherwise iorj = J. +C Thus for ROWCOL = 'R', U(s) = +C diag(s**INDEX(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...). +C +C LDUCO1 INTEGER +C The leading dimension of array UCOEFF. +C LDUCO1 >= MAX(1,P) if ROWCOL = 'R'; +C LDUCO1 >= MAX(1,M,P) if ROWCOL = 'C'. +C +C LDUCO2 INTEGER +C The second dimension of array UCOEFF. +C LDUCO2 >= MAX(1,M) if ROWCOL = 'R'; +C LDUCO2 >= MAX(1,M,P) if ROWCOL = 'C'. +C +C NR (output) INTEGER +C The order of the resulting minimal realization, i.e. the +C order of the state dynamics matrix A. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N), +C porm +C where N = SUM INDEX(I). +C I=1 +C The leading NR-by-NR part of this array contains the upper +C block Hessenberg state dynamics matrix A of a minimal +C realization. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P)) +C The leading NR-by-M part of this array contains the +C input/state matrix B of a minimal realization; the +C remainder of the leading N-by-MAX(M,P) part is used as +C internal workspace. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-NR part of this array contains the +C state/output matrix C of a minimal realization; the +C remainder of the leading MAX(M,P)-by-N part is used as +C internal workspace. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M,P). +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M), +C if ROWCOL = 'R', and (LDD,MAX(M,P)) if ROWCOL = 'C'. +C The leading P-by-M part of this array contains the direct +C transmission matrix D; if ROWCOL = 'C', the remainder of +C the leading MAX(M,P)-by-MAX(M,P) part is used as internal +C workspace. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P) if ROWCOL = 'R'; +C LDD >= MAX(1,M,P) if ROWCOL = 'C'. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determination when +C transforming (A, B, C). If the user sets TOL > 0, then +C the given value of TOL is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance +C (determined by the SLICOT routine TB01UD) is used instead. +C +C Workspace +C +C IWORK INTEGER array, dimension (N+MAX(M,P)) +C On exit, if INFO = 0, the first nonzero elements of +C IWORK(1:N) return the orders of the diagonal blocks of A. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P)). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, then i is the first integer for which +C ABS( DCOEFF(I,1) ) is so small that the calculations +C would overflow (see SLICOT Library routine TD03AY); +C that is, the leading coefficient of a polynomial is +C nearly zero; no state-space representation is +C calculated. +C +C METHOD +C +C The method for transfer matrices factorized by rows will be +C described here: T(s) factorized by columns is dealt with by +C operating on the dual T'(s). This description for T(s) is +C actually the left polynomial matrix representation +C +C T(s) = inv(D(s))*U(s), +C +C where D(s) is diagonal with its (I,I)-th polynomial element of +C degree INDEX(I). The first step is to check whether the leading +C coefficient of any polynomial element of D(s) is approximately +C zero; if so the routine returns with INFO > 0. Otherwise, +C Wolovich's Observable Structure Theorem is used to construct a +C state-space representation in observable companion form which +C is equivalent to the above polynomial matrix representation. +C The method is particularly easy here due to the diagonal form +C of D(s). This state-space representation is not necessarily +C controllable (as D(s) and U(s) are not necessarily relatively +C left prime), but it is in theory completely observable; however, +C its observability matrix may be poorly conditioned, so it is +C treated as a general state-space representation and SLICOT +C Library routine TB01PD is then called to separate out a minimal +C realization from this general state-space representation by means +C of orthogonal similarity transformations. +C +C REFERENCES +C +C [1] Patel, R.V. +C Computation of Minimal-Order State-Space Realizations and +C Observability Indices using Orthogonal Transformations. +C Int. J. Control, 33, pp. 227-246, 1981. +C +C [2] Wolovich, W.A. +C Linear Multivariable Systems, (Theorem 4.3.3). +C Springer-Verlag, 1974. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, March 1998. +C Supersedes Release 3.0 routine TD01OD. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Controllability, elementary polynomial operations, minimal +C realization, polynomial matrix, state-space representation, +C transfer matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER ROWCOL + INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, + $ LDUCO2, LDWORK, M, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER INDEX(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DCOEFF(LDDCOE,*), DWORK(*), + $ UCOEFF(LDUCO1,LDUCO2,*) +C .. Local Scalars .. + LOGICAL LROCOC, LROCOR + INTEGER I, J, JSTOP, K, KDCOEF, MPLIM, MWORK, N, PWORK +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLASET, DSWAP, TB01PD, TB01XD, TD03AY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 + LROCOR = LSAME( ROWCOL, 'R' ) + LROCOC = LSAME( ROWCOL, 'C' ) + MPLIM = MAX( 1, M, P ) +C +C Test the input scalar arguments. +C + IF( .NOT.LROCOR .AND. .NOT.LROCOC ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( ( LROCOR .AND. LDDCOE.LT.MAX( 1, P ) ) .OR. + $ ( LROCOC .AND. LDDCOE.LT.MAX( 1, M ) ) ) THEN + INFO = -6 + ELSE IF( ( LROCOR .AND. LDUCO1.LT.MAX( 1, P ) ) .OR. + $ ( LROCOC .AND. LDUCO1.LT.MPLIM ) ) THEN + INFO = -8 + ELSE IF( ( LROCOR .AND. LDUCO2.LT.MAX( 1, M ) ) .OR. + $ ( LROCOC .AND. LDUCO2.LT.MPLIM ) ) THEN + INFO = -9 + END IF +C + N = 0 + IF ( INFO.EQ.0 ) THEN + IF ( LROCOR ) THEN +C +C Initialization for T(s) given as rows over common +C denominators. +C + PWORK = P + MWORK = M + ELSE +C +C Initialization for T(s) given as columns over common +C denominators. +C + PWORK = M + MWORK = P + END IF +C +C Calculate N, the order of the resulting state-space +C representation. +C + KDCOEF = 0 +C + DO 10 I = 1, PWORK + KDCOEF = MAX( KDCOEF, INDEX(I) ) + N = N + INDEX(I) + 10 CONTINUE +C + KDCOEF = KDCOEF + 1 +C + IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDC.LT.MPLIM ) THEN + INFO = -16 + ELSE IF( ( LROCOR .AND. LDD.LT.MAX( 1, P ) ) .OR. + $ ( LROCOC .AND. LDD.LT.MPLIM ) ) THEN + INFO = -18 + ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*M, 3*P ) ) ) THEN + INFO = -22 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TD04AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, M, P ).EQ.0 ) THEN + NR = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF ( LROCOC ) THEN +C +C Initialize the remainder of the leading +C MPLIM-by-MPLIM-by-KDCOEF part of U(s) to zero. +C + IF ( P.LT.M ) THEN +C + DO 20 K = 1, KDCOEF + CALL DLASET( 'Full', M-P, MPLIM, ZERO, ZERO, + $ UCOEFF(P+1,1,K), LDUCO1 ) + 20 CONTINUE +C + ELSE IF ( P.GT.M ) THEN +C + DO 30 K = 1, KDCOEF + CALL DLASET( 'Full', MPLIM, P-M, ZERO, ZERO, + $ UCOEFF(1,M+1,K), LDUCO1 ) + 30 CONTINUE +C + END IF +C + IF ( MPLIM.NE.1 ) THEN +C +C Non-scalar T(s) factorized by columns: transpose it (i.e. +C U(s)). +C + JSTOP = MPLIM - 1 +C + DO 50 K = 1, KDCOEF +C + DO 40 J = 1, JSTOP + CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, + $ UCOEFF(J,J+1,K), LDUCO1 ) + 40 CONTINUE +C + 50 CONTINUE +C + END IF + END IF +C +C Construct non-minimal state-space representation (by Wolovich's +C Structure Theorem) which has transfer matrix T(s) or T'(s) as +C appropriate ... +C + CALL TD03AY( MWORK, PWORK, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1, + $ LDUCO2, N, A, LDA, B, LDB, C, LDC, D, LDD, INFO ) + IF ( INFO.GT.0 ) + $ RETURN +C +C and then separate out a minimal realization from this. +C +C Workspace: need N + MAX(N, 3*MWORK, 3*PWORK). +C + CALL TB01PD( 'Minimal', 'Scale', N, MWORK, PWORK, A, LDA, B, LDB, + $ C, LDC, NR, TOL, IWORK, DWORK, LDWORK, INFO ) +C + IF ( LROCOC ) THEN +C +C If T(s) originally factorized by columns, find dual of minimal +C state-space representation, and reorder the rows and columns +C to get an upper block Hessenberg state dynamics matrix. +C + K = IWORK(1)+IWORK(2)-1 + CALL TB01XD( 'D', NR, MWORK, PWORK, K, NR-1, A, LDA, B, LDB, + $ C, LDC, D, LDD, INFO ) + IF ( MPLIM.NE.1 ) THEN +C +C Also, retranspose U(s) if this is non-scalar. +C + DO 70 K = 1, KDCOEF +C + DO 60 J = 1, JSTOP + CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, + $ UCOEFF(J,J+1,K), LDUCO1 ) + 60 CONTINUE +C + 70 CONTINUE +C + END IF + END IF +C + RETURN +C *** Last line of TD04AD *** + END diff --git a/mex/sources/libslicot/TD05AD.f b/mex/sources/libslicot/TD05AD.f new file mode 100644 index 000000000..0b527c4aa --- /dev/null +++ b/mex/sources/libslicot/TD05AD.f @@ -0,0 +1,314 @@ + SUBROUTINE TD05AD( UNITF, OUTPUT, NP1, MP1, W, A, B, VALR, VALI, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C Given a complex valued rational function of frequency (transfer +C function) G(jW) this routine will calculate its complex value or +C its magnitude and phase for a specified frequency value. +C +C ARGUMENTS +C +C Mode Parameters +C +C UNITF CHARACTER*1 +C Indicates the choice of frequency unit as follows: +C = 'R': Input frequency W in radians/second; +C = 'H': Input frequency W in hertz. +C +C OUTPUT CHARACTER*1 +C Indicates the choice of co-ordinates for output as folows: +C = 'C': Cartesian co-ordinates (output real and imaginary +C parts of G(jW)); +C = 'P': Polar co-ordinates (output magnitude and phase +C of G(jW)). +C +C Input/Output Parameters +C +C NP1 (input) INTEGER +C The order of the denominator + 1, i.e. N + 1. NP1 >= 1. +C +C MP1 (input) INTEGER +C The order of the numerator + 1, i.e. M + 1. MP1 >= 1. +C +C W (input) DOUBLE PRECISION +C The frequency value W for which the transfer function is +C to be evaluated. +C +C A (input) DOUBLE PRECISION array, dimension (NP1) +C This array must contain the vector of denominator +C coefficients in ascending order of powers. That is, A(i) +C must contain the coefficient of (jW)**(i-1) for i = 1, +C 2,...,NP1. +C +C B (input) DOUBLE PRECISION array, dimension (MP1) +C This array must contain the vector of numerator +C coefficients in ascending order of powers. That is, B(i) +C must contain the coefficient of (jW)**(i-1) for i = 1, +C 2,...,MP1. +C +C VALR (output) DOUBLE PRECISION +C If OUTPUT = 'C', VALR contains the real part of G(jW). +C If OUTPUT = 'P', VALR contains the magnitude of G(jW) +C in dBs. +C +C VALI (output) DOUBLE PRECISION +C If OUTPUT = 'C', VALI contains the imaginary part of +C G(jW). +C If OUTPUT = 'P', VALI contains the phase of G(jW) in +C degrees. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the frequency value W is a pole of G(jW), or all +C the coefficients of the A polynomial are zero. +C +C METHOD +C +C By substituting the values of A, B and W in the following +C formula: +C +C B(1)+B(2)*(jW)+B(3)*(jW)**2+...+B(MP1)*(jW)**(MP1-1) +C G(jW) = ---------------------------------------------------. +C A(1)+A(2)*(jW)+A(3)*(jW)**2+...+A(NP1)*(jW)**(NP1-1) +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0(N+M) operations. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TD01AD by Control Systems Research +C Group, Kingston Polytechnic, United Kingdom, March 1981. +C +C REVISIONS +C +C February 1997. +C February 22, 1998 (changed the name of TD01MD). +C +C KEYWORDS +C +C Elementary polynomial operations, frequency response, matrix +C fraction, polynomial matrix, state-space representation, transfer +C matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, EIGHT, TWENTY, NINETY, ONE80, THRE60 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, EIGHT=8.0D0, + $ TWENTY=20.0D0, NINETY=90.0D0, ONE80 = 180.0D0, + $ THRE60=360.0D0 ) +C .. Scalar Arguments .. + CHARACTER OUTPUT, UNITF + INTEGER INFO, MP1, NP1 + DOUBLE PRECISION VALI, VALR, W +C .. Array Arguments .. + DOUBLE PRECISION A(*), B(*) +C .. Local Scalars .. + LOGICAL LOUTPU, LUNITF + INTEGER I, IPHASE, M, M2, N, N2, NPZERO, NZZERO + DOUBLE PRECISION BIMAG, BREAL, G, TIMAG, TREAL, TWOPI, W2, WC + COMPLEX*16 ZTEMP +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAPY2 + COMPLEX*16 ZLADIV + EXTERNAL DLAPY2, LSAME, ZLADIV +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, ATAN, DBLE, DCMPLX, DIMAG, LOG10, MAX, MOD, + $ SIGN +C .. Executable Statements .. +C + INFO = 0 + LUNITF = LSAME( UNITF, 'H' ) + LOUTPU = LSAME( OUTPUT, 'P' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LUNITF .AND. .NOT.LSAME( UNITF, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOUTPU .AND. .NOT.LSAME( OUTPUT, 'C' ) ) THEN + INFO = -2 + ELSE IF( NP1.LT.1 ) THEN + INFO = -3 + ELSE IF( MP1.LT.1 ) THEN + INFO = -4 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TD05AD', -INFO ) + RETURN + END IF +C + M = MP1 - 1 + N = NP1 - 1 + WC = W + TWOPI = EIGHT*ATAN( ONE ) + IF ( LUNITF ) WC = WC*TWOPI + W2 = WC**2 +C +C Determine the orders z (NZZERO) and p (NPZERO) of the factors +C (jW)**k in the numerator and denominator polynomials, by counting +C the zero trailing coefficients. The value of G(jW) will then be +C computed as (jW)**(z-p)*m(jW)/n(jW), for appropriate m and n. +C + I = 0 +C + 10 CONTINUE + I = I + 1 + IF ( I.LE.M ) THEN + IF ( B(I).EQ.ZERO ) GO TO 10 + END IF +C + NZZERO = I - 1 + I = 0 +C + 20 CONTINUE + I = I + 1 + IF ( I.LE.N ) THEN + IF ( A(I).EQ.ZERO ) GO TO 20 + END IF +C + NPZERO = I - 1 + IPHASE = NZZERO - NPZERO +C + M2 = MOD( M - NZZERO, 2 ) +C +C Add real parts of the numerator m(jW). +C + TREAL = B(MP1-M2) +C + DO 30 I = M - 1 - M2, NZZERO + 1, -2 + TREAL = B(I) - W2*TREAL + 30 CONTINUE +C +C Add imaginary parts of the numerator m(jW). +C + IF ( M.EQ.0 ) THEN + TIMAG = ZERO + ELSE + TIMAG = B(M+M2) +C + DO 40 I = M + M2 - 2, NZZERO + 2, -2 + TIMAG = B(I) - W2*TIMAG + 40 CONTINUE +C + TIMAG = TIMAG*WC + END IF +C + N2 = MOD( N - NPZERO, 2 ) +C +C Add real parts of the denominator n(jW). +C + BREAL = A(NP1-N2) +C + DO 50 I = N - 1 - N2, NPZERO + 1, -2 + BREAL = A(I) - W2*BREAL + 50 CONTINUE +C +C Add imaginary parts of the denominator n(jW). +C + IF ( N.EQ.0 ) THEN + BIMAG = ZERO + ELSE + BIMAG = A(N+N2) +C + DO 60 I = N + N2 - 2, NPZERO + 2, -2 + BIMAG = A(I) - W2*BIMAG + 60 CONTINUE +C + BIMAG = BIMAG*WC + END IF +C + IF ( ( MAX( ABS( BREAL ), ABS( BIMAG ) ).EQ.ZERO ) .OR. + $ ( W.EQ.ZERO .AND. IPHASE.LT.0 ) ) THEN +C +C Error return: The specified frequency W is a pole of G(jW), +C or all the coefficients of the A polynomial are zero. +C + INFO = 1 + ELSE +C +C Evaluate the complex number W**(z-p)*m(jW)/n(jW). +C + ZTEMP = + $ ZLADIV( DCMPLX( TREAL, TIMAG ), DCMPLX( BREAL, BIMAG ) ) + VALR = DBLE( ZTEMP )*WC**IPHASE + VALI = DIMAG( ZTEMP )*WC**IPHASE +C + IF ( .NOT.LOUTPU ) THEN +C +C Cartesian co-ordinates: Update the result for j**(z-p). +C + I = MOD( ABS( IPHASE ), 4 ) + IF ( ( IPHASE.GT.0 .AND. I.GT.1 ) .OR. + $ ( IPHASE.LT.0 .AND. ( I.EQ.1 .OR. I.EQ.2) ) ) THEN + VALR = -VALR + VALI = -VALI + END IF +C + IF ( MOD( I, 2 ).NE.0 ) THEN + G = VALR + VALR = -VALI + VALI = G + END IF +C + ELSE +C +C Polar co-ordinates: Compute the magnitude and phase. +C + G = DLAPY2( VALR, VALI ) +C + IF ( VALR.EQ.ZERO ) THEN + VALI = SIGN( NINETY, VALI ) + ELSE + VALI = ( ATAN( VALI/VALR )/TWOPI )*THRE60 + IF ( VALI.EQ.ZERO .AND. NZZERO.EQ.M .AND. NPZERO.EQ.N + $ .AND. B(NZZERO+1)*A(NPZERO+1).LT.ZERO ) + $ VALI = ONE80 + END IF +C + VALR = TWENTY*LOG10( G ) +C + IF ( IPHASE.NE.0 ) + $ VALI = VALI + DBLE( NZZERO - NPZERO )*NINETY + END IF +C + END IF +C + RETURN +C *** Last line of TD05AD *** + END diff --git a/mex/sources/libslicot/TF01MD.f b/mex/sources/libslicot/TF01MD.f new file mode 100644 index 000000000..1b33b81ca --- /dev/null +++ b/mex/sources/libslicot/TF01MD.f @@ -0,0 +1,233 @@ + SUBROUTINE TF01MD( N, M, P, NY, A, LDA, B, LDB, C, LDC, D, LDD, + $ U, LDU, X, Y, LDY, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the output sequence of a linear time-invariant +C open-loop system given by its discrete-time state-space model +C (A,B,C,D), where A is an N-by-N general matrix. +C +C The initial state vector x(1) must be supplied by the user. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NY (input) INTEGER +C The number of output vectors y(k) to be computed. +C NY >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input matrix B of the system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C output matrix C of the system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct link matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C U (input) DOUBLE PRECISION array, dimension (LDU,NY) +C The leading M-by-NY part of this array must contain the +C input vector sequence u(k), for k = 1,2,...,NY. +C Specifically, the k-th column of U must contain u(k). +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,M). +C +C X (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the initial state vector +C x(1) which consists of the N initial states of the system. +C On exit, this array contains the final state vector +C x(NY+1) of the N states of the system at instant NY. +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,NY) +C The leading P-by-NY part of this array contains the output +C vector sequence y(1),y(2),...,y(NY) such that the k-th +C column of Y contains y(k) (the outputs at instant k), +C for k = 1,2,...,NY. +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= MAX(1,P). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given an initial state vector x(1), the output vector sequence +C y(1), y(2),..., y(NY) is obtained via the formulae +C +C x(k+1) = A x(k) + B u(k) +C y(k) = C x(k) + D u(k), +C +C where each element y(k) is a vector of length P containing the +C outputs at instant k and k = 1,2,...,NY. +C +C REFERENCES +C +C [1] Luenberger, D.G. +C Introduction to Dynamic Systems: Theory, Models and +C Applications. +C John Wiley & Sons, New York, 1979. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately (N + M) x (N + P) x NY +C multiplications and additions. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TF01AD by S. Van Huffel, Katholieke +C Univ. Leuven, Belgium. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003. +C +C KEYWORDS +C +C Discrete-time system, multivariable system, state-space model, +C state-space representation, time response. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDU, LDY, M, N, NY, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), U(LDU,*), X(*), Y(LDY,*) +C .. Local Scalars .. + INTEGER IK +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( NY.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDU.LT.MAX( 1, M ) ) THEN + INFO = -14 + ELSE IF( LDY.LT.MAX( 1, P ) ) THEN + INFO = -17 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TF01MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( P, NY ).EQ.0 ) THEN + RETURN + ELSE IF ( N.EQ.0 ) THEN +C +C Non-dynamic system: compute the output vectors. +C + IF ( M.EQ.0 ) THEN + CALL DLASET( 'Full', P, NY, ZERO, ZERO, Y, LDY ) + ELSE + CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, + $ D, LDD, U, LDU, ZERO, Y, LDY ) + END IF + RETURN + END IF +C + DO 10 IK = 1, NY + CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, X, 1, ZERO, + $ Y(1,IK), 1 ) +C + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, X, 1, ZERO, + $ DWORK, 1 ) + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, U(1,IK), 1, ONE, + $ DWORK, 1 ) +C + CALL DCOPY( N, DWORK, 1, X, 1 ) + 10 CONTINUE +C + CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, D, LDD, + $ U, LDU, ONE, Y, LDY ) +C + RETURN +C *** Last line of TF01MD *** + END diff --git a/mex/sources/libslicot/TF01MX.f b/mex/sources/libslicot/TF01MX.f new file mode 100644 index 000000000..aaaf7aaff --- /dev/null +++ b/mex/sources/libslicot/TF01MX.f @@ -0,0 +1,457 @@ + SUBROUTINE TF01MX( N, M, P, NY, S, LDS, U, LDU, X, Y, LDY, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the output sequence of a linear time-invariant +C open-loop system given by its discrete-time state-space model +C with an (N+P)-by-(N+M) general system matrix S, +C +C ( A B ) +C S = ( ) . +C ( C D ) +C +C The initial state vector x(1) must be supplied by the user. +C +C The input and output trajectories are stored as in the SLICOT +C Library routine TF01MY. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NY (input) INTEGER +C The number of output vectors y(k) to be computed. +C NY >= 0. +C +C S (input) DOUBLE PRECISION array, dimension (LDS,N+M) +C The leading (N+P)-by-(N+M) part of this array must contain +C the system matrix S. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,N+P). +C +C U (input) DOUBLE PRECISION array, dimension (LDU,M) +C The leading NY-by-M part of this array must contain the +C input vector sequence u(k), for k = 1,2,...,NY. +C Specifically, the k-th row of U must contain u(k)'. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,NY). +C +C X (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the initial state vector +C x(1) which consists of the N initial states of the system. +C On exit, this array contains the final state vector +C x(NY+1) of the N states of the system at instant NY+1. +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,P) +C The leading NY-by-P part of this array contains the output +C vector sequence y(1),y(2),...,y(NY) such that the k-th +C row of Y contains y(k)' (the outputs at instant k), +C for k = 1,2,...,NY. +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= MAX(1,NY). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 0, if MIN(N,P,NY) = 0; otherwise, +C LDWORK >= N+P, if M = 0; +C LDWORK >= 2*N+M+P, if M > 0. +C For better performance, LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given an initial state vector x(1), the output vector sequence +C y(1), y(2),..., y(NY) is obtained via the formulae +C +C ( x(k+1) ) ( x(k) ) +C ( ) = S ( ) , +C ( y(k) ) ( u(k) ) +C +C where each element y(k) is a vector of length P containing the +C outputs at instant k, and k = 1,2,...,NY. +C +C REFERENCES +C +C [1] Luenberger, D.G. +C Introduction to Dynamic Systems: Theory, Models and +C Applications. +C John Wiley & Sons, New York, 1979. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately (N + M) x (N + P) x NY +C multiplications and additions. +C +C FURTHER COMMENTS +C +C The implementation exploits data locality as much as possible, +C given the workspace length. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 2002. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Discrete-time system, multivariable system, state-space model, +C state-space representation, time response. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDS, LDU, LDWORK, LDY, M, N, NY, P +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), S(LDS,*), U(LDU,*), X(*), Y(LDY,*) +C .. Local Scalars .. + INTEGER I, IC, IU, IW, IY, J, JW, K, N2M, N2P, NB, NF, + $ NM, NP, NS +C .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + NP = N + P + NM = N + M + IW = NM + NP + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( NY.LT.0 ) THEN + INFO = -4 + ELSE IF( LDS.LT.MAX( 1, NP ) ) THEN + INFO = -6 + ELSE IF( LDU.LT.MAX( 1, NY ) ) THEN + INFO = -8 + ELSE IF( LDY.LT.MAX( 1, NY ) ) THEN + INFO = -11 + ELSE + IF( MIN( N, P, NY ).EQ.0 ) THEN + JW = 0 + ELSE IF( M.EQ.0 ) THEN + JW = NP + ELSE + JW = IW + END IF + IF( LDWORK.LT.JW ) + $ INFO = -13 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TF01MX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( NY, P ).EQ.0 ) THEN + RETURN + ELSE IF ( N.EQ.0 ) THEN +C +C Non-dynamic system: compute the output vectors. +C + IF ( M.EQ.0 ) THEN + CALL DLASET( 'Full', NY, P, ZERO, ZERO, Y, LDY ) + ELSE + CALL DGEMM( 'No transpose', 'Transpose', NY, P, M, ONE, + $ U, LDU, S, LDS, ZERO, Y, LDY ) + END IF + RETURN + END IF +C +C Determine the block size (taken as for LAPACK routine DGETRF). +C + NB = ILAENV( 1, 'DGETRF', ' ', NY, MAX( M, P ), -1, -1 ) +C +C Find the number of state vectors, extended with inputs (if M > 0) +C and outputs, that can be accommodated in the provided workspace. +C + NS = MIN( LDWORK/JW, NB*NB/JW, NY ) + N2P = N + NP +C + IF ( M.EQ.0 ) THEN +C +C System with no inputs. +C Workspace: need N + P; +C prefer larger. +C + IF( NS.LE.1 .OR. NY*P.LE.NB*NB ) THEN + IY = N + 1 +C +C LDWORK < 2*(N+P), or small problem. +C One row of array Y is computed for each loop index value. +C + DO 10 I = 1, NY +C +C Compute +C +C /x(i+1)\ /A\ +C | | = | | * x(i). +C \ y(i) / \C/ +C + CALL DGEMV( 'NoTranspose', NP, N, ONE, S, LDS, X, 1, + $ ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, X, 1 ) + CALL DCOPY( P, DWORK(IY), 1, Y(I,1), LDY ) + 10 CONTINUE +C + ELSE +C +C LDWORK >= 2*(N+P), and large problem. +C NS rows of array Y are computed before being saved. +C + NF = ( NY/NS )*NS + CALL DCOPY( N, X, 1, DWORK, 1 ) +C + DO 40 I = 1, NF, NS +C +C Compute the current NS extended state vectors in the +C workspace: +C +C /x(i+1)\ /A\ +C | | = | | * x(i), i = 1 : ns - 1. +C \ y(i) / \C/ +C + DO 20 IC = 1, ( NS - 1 )*NP, NP + CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, + $ DWORK(IC), 1, ZERO, DWORK(IC+NP), 1 ) + 20 CONTINUE +C +C Prepare the next iteration. +C + CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, + $ DWORK((NS-1)*NP+1), 1, ZERO, DWORK, 1 ) +C +C Transpose the NS output vectors in the corresponding part +C of Y (column-wise). +C + DO 30 J = 1, P + CALL DCOPY( NS-1, DWORK(N2P+J), NP, Y(I,J), 1 ) + Y(I+NS-1,J) = DWORK(N+J) + 30 CONTINUE +C + 40 CONTINUE +C + NS = NY - NF +C + IF ( NS.GT.1 ) THEN +C +C Compute similarly the last NS output vectors. +C + DO 50 IC = 1, ( NS - 1 )*NP, NP + CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, + $ DWORK(IC), 1, ZERO, DWORK(IC+NP), 1 ) + 50 CONTINUE +C + CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, + $ DWORK((NS-1)*NP+1), 1, ZERO, DWORK, 1 ) +C + DO 60 J = 1, P + CALL DCOPY( NS-1, DWORK(N2P+J), NP, Y(NF+1,J), 1 ) + Y(NF+NS,J) = DWORK(N+J) + 60 CONTINUE +C + ELSE IF ( NS.EQ.1 ) THEN +C +C Compute similarly the last NS = 1 output vectors. +C + CALL DCOPY( N, DWORK, 1, DWORK(NP+1), 1 ) + CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, + $ DWORK(NP+1), 1, ZERO, DWORK, 1 ) + CALL DCOPY( P, DWORK(N+1), 1, Y(NF+1,1), LDY ) +C + END IF +C +C Set the final state vector. +C + CALL DCOPY( N, DWORK, 1, X, 1 ) +C + END IF +C + ELSE +C +C General case. +C Workspace: need 2*N + M + P; +C prefer larger. +C + CALL DCOPY( N, X, 1, DWORK, 1 ) +C + IF( NS.LE.1 .OR. NY*( M + P ).LE.NB*NB ) THEN + IU = N + 1 + JW = IU + M + IY = JW + N +C +C LDWORK < 2*(2*N+M+P), or small problem. +C One row of array Y is computed for each loop index value. +C + DO 70 I = 1, NY +C +C Compute +C +C /x(i+1)\ /A, B\ /x(i)\ +C | | = | | * | | . +C \ y(i) / \C, D/ \u(i)/ +C + CALL DCOPY( M, U(I,1), LDU, DWORK(IU), 1 ) + CALL DGEMV( 'NoTranspose', NP, NM, ONE, S, LDS, DWORK, 1, + $ ZERO, DWORK(JW), 1 ) + CALL DCOPY( N, DWORK(JW), 1, DWORK, 1 ) + CALL DCOPY( P, DWORK(IY), 1, Y(I,1), LDY ) + 70 CONTINUE +C + ELSE +C +C LDWORK >= 2*(2*N+M+P), and large problem. +C NS rows of array Y are computed before being saved. +C + NF = ( NY/NS )*NS + N2M = N + NM +C + DO 110 I = 1, NF, NS + JW = 1 +C +C Compute the current NS extended state vectors in the +C workspace: +C +C /x(i+1)\ /A, B\ /x(i)\ +C | | = | | * | | , i = 1 : ns - 1. +C \ y(i) / \C, D/ \u(i)/ +C + DO 80 J = 1, M + CALL DCOPY( NS, U(I,J), 1, DWORK(N+J), IW ) + 80 CONTINUE +C + DO 90 K = 1, NS - 1 + CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, + $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) + JW = JW + NM + CALL DCOPY( N, DWORK(JW), 1, DWORK(JW+NP), 1 ) + JW = JW + NP + 90 CONTINUE +C +C Prepare the next iteration. +C + CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, + $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) + CALL DCOPY( N, DWORK(JW+NM), 1, DWORK, 1 ) +C +C Transpose the NS output vectors in the corresponding part +C of Y (column-wise). +C + DO 100 J = 1, P + CALL DCOPY( NS, DWORK(N2M+J), IW, Y(I,J), 1 ) + 100 CONTINUE +C + 110 CONTINUE +C + NS = NY - NF +C + IF ( NS.GT.1 ) THEN + JW = 1 +C +C Compute similarly the last NS output vectors. +C + DO 120 J = 1, M + CALL DCOPY( NS, U(NF+1,J), 1, DWORK(N+J), IW ) + 120 CONTINUE +C + DO 130 K = 1, NS - 1 + CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, + $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) + JW = JW + NM + CALL DCOPY( N, DWORK(JW), 1, DWORK(JW+NP), 1 ) + JW = JW + NP + 130 CONTINUE +C + CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, + $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) + CALL DCOPY( N, DWORK(JW+NM), 1, DWORK, 1 ) +C + DO 140 J = 1, P + CALL DCOPY( NS, DWORK(N2M+J), IW, Y(NF+1,J), 1 ) + 140 CONTINUE +C + ELSE IF ( NS.EQ.1 ) THEN +C +C Compute similarly the last NS = 1 output vectors. +C + CALL DCOPY( N, DWORK, 1, DWORK(NP+1), 1 ) + CALL DCOPY( M, U(NF+1,1), LDU, DWORK(N2P+1), 1 ) + CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, + $ DWORK(NP+1), 1, ZERO, DWORK, 1 ) + CALL DCOPY( P, DWORK(N+1), 1, Y(NF+1,1), LDY ) +C + END IF +C + END IF +C +C Set the final state vector. +C + CALL DCOPY( N, DWORK, 1, X, 1 ) +C + END IF +C + RETURN +C *** Last line of TF01MX *** + END diff --git a/mex/sources/libslicot/TF01MY.f b/mex/sources/libslicot/TF01MY.f new file mode 100644 index 000000000..85e31c05b --- /dev/null +++ b/mex/sources/libslicot/TF01MY.f @@ -0,0 +1,358 @@ + SUBROUTINE TF01MY( N, M, P, NY, A, LDA, B, LDB, C, LDC, D, LDD, + $ U, LDU, X, Y, LDY, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the output sequence of a linear time-invariant +C open-loop system given by its discrete-time state-space model +C (A,B,C,D), where A is an N-by-N general matrix. +C +C The initial state vector x(1) must be supplied by the user. +C +C This routine differs from SLICOT Library routine TF01MD in the +C way the input and output trajectories are stored. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NY (input) INTEGER +C The number of output vectors y(k) to be computed. +C NY >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input matrix B of the system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C output matrix C of the system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct link matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C U (input) DOUBLE PRECISION array, dimension (LDU,M) +C The leading NY-by-M part of this array must contain the +C input vector sequence u(k), for k = 1,2,...,NY. +C Specifically, the k-th row of U must contain u(k)'. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,NY). +C +C X (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the initial state vector +C x(1) which consists of the N initial states of the system. +C On exit, this array contains the final state vector +C x(NY+1) of the N states of the system at instant NY+1. +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,P) +C The leading NY-by-P part of this array contains the output +C vector sequence y(1),y(2),...,y(NY) such that the k-th +C row of Y contains y(k)' (the outputs at instant k), +C for k = 1,2,...,NY. +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= MAX(1,NY). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= N. +C For better performance, LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given an initial state vector x(1), the output vector sequence +C y(1), y(2),..., y(NY) is obtained via the formulae +C +C x(k+1) = A x(k) + B u(k) +C y(k) = C x(k) + D u(k), +C +C where each element y(k) is a vector of length P containing the +C outputs at instant k and k = 1,2,...,NY. +C +C REFERENCES +C +C [1] Luenberger, D.G. +C Introduction to Dynamic Systems: Theory, Models and +C Applications. +C John Wiley & Sons, New York, 1979. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately (N + M) x (N + P) x NY +C multiplications and additions. +C +C FURTHER COMMENTS +C +C The implementation exploits data locality and uses BLAS 3 +C operations as much as possible, given the workspace length. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Discrete-time system, multivariable system, state-space model, +C state-space representation, time response. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDU, LDWORK, LDY, M, + $ N, NY, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), U(LDU,*), X(*), Y(LDY,*) +C .. Local Scalars .. + INTEGER IK, IREM, IS, IYL, MAXN, NB, NS + DOUBLE PRECISION UPD +C .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + MAXN = MAX( 1, N ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( NY.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAXN ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAXN ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDU.LT.MAX( 1, NY ) ) THEN + INFO = -14 + ELSE IF( LDY.LT.MAX( 1, NY ) ) THEN + INFO = -17 + ELSE IF( LDWORK.LT.N ) THEN + INFO = -19 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TF01MY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( NY, P ).EQ.0 ) THEN + RETURN + ELSE IF ( N.EQ.0 ) THEN +C +C Non-dynamic system: compute the output vectors. +C + IF ( M.EQ.0 ) THEN + CALL DLASET( 'Full', NY, P, ZERO, ZERO, Y, LDY ) + ELSE + CALL DGEMM( 'No transpose', 'Transpose', NY, P, M, ONE, + $ U, LDU, D, LDD, ZERO, Y, LDY ) + END IF + RETURN + END IF +C +C Determine the block size (taken as for LAPACK routine DGETRF). +C + NB = ILAENV( 1, 'DGETRF', ' ', NY, MAX( M, P ), -1, -1 ) +C +C Find the number of state vectors that can be accommodated in +C the provided workspace and initialize. +C + NS = MIN( LDWORK/N, NB*NB/N, NY ) +C + IF ( NS.LE.1 .OR. NY*MAX( M, P ).LE.NB*NB ) THEN +C +C LDWORK < 2*N or small problem: +C only BLAS 2 calculations are used in the loop +C for computing the output corresponding to D = 0. +C One row of the array Y is computed for each loop index value. +C + DO 10 IK = 1, NY + CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, X, 1, ZERO, + $ Y(IK,1), LDY ) +C + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, X, 1, ZERO, + $ DWORK, 1 ) + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, U(IK,1), LDU, + $ ONE, DWORK, 1 ) +C + CALL DCOPY( N, DWORK, 1, X, 1 ) + 10 CONTINUE +C + ELSE +C +C LDWORK >= 2*N and large problem: +C some BLAS 3 calculations can also be used. +C + IYL = ( NY/NS )*NS + IF ( M.EQ.0 ) THEN + UPD = ZERO + ELSE + UPD = ONE + END IF +C + CALL DCOPY( N, X, 1, DWORK, 1 ) +C + DO 30 IK = 1, IYL, NS +C +C Compute the current NS-1 state vectors in the workspace. +C + CALL DGEMM( 'No transpose', 'Transpose', N, NS-1, M, ONE, + $ B, LDB, U(IK,1), LDU, ZERO, DWORK(N+1), MAXN ) +C + DO 20 IS = 1, NS - 1 + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, + $ DWORK((IS-1)*N+1), 1, UPD, DWORK(IS*N+1), 1 ) + 20 CONTINUE +C +C Initialize the current NS output vectors. +C + CALL DGEMM( 'Transpose', 'Transpose', NS, P, N, ONE, DWORK, + $ MAXN, C, LDC, ZERO, Y(IK,1), LDY ) +C +C Prepare the next iteration. +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ U(IK+NS-1,1), LDU, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, + $ DWORK((NS-1)*N+1), 1, UPD, DWORK, 1 ) + 30 CONTINUE +C + IREM = NY - IYL +C + IF ( IREM.GT.1 ) THEN +C +C Compute the last IREM output vectors. +C First, compute the current IREM-1 state vectors. +C + IK = IYL + 1 + CALL DGEMM( 'No transpose', 'Transpose', N, IREM-1, M, ONE, + $ B, LDB, U(IK,1), LDU, ZERO, DWORK(N+1), MAXN ) +C + DO 40 IS = 1, IREM - 1 + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, + $ DWORK((IS-1)*N+1), 1, UPD, DWORK(IS*N+1), 1 ) + 40 CONTINUE +C +C Initialize the last IREM output vectors. +C + CALL DGEMM( 'Transpose', 'Transpose', IREM, P, N, ONE, + $ DWORK, MAXN, C, LDC, ZERO, Y(IK,1), LDY ) +C +C Prepare the final state vector. +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ U(IK+IREM-1,1), LDU, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, + $ DWORK((IREM-1)*N+1), 1, UPD, DWORK, 1 ) +C + ELSE IF ( IREM.EQ.1 ) THEN +C +C Compute the last 1 output vectors. +C + CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, DWORK, 1, + $ ZERO, Y(IK,1), LDY ) +C +C Prepare the final state vector. +C + CALL DCOPY( N, DWORK, 1, DWORK(N+1), 1 ) + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ U(IK,1), LDU, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, + $ DWORK(N+1), 1, UPD, DWORK, 1 ) + END IF +C +C Set the final state vector. +C + CALL DCOPY( N, DWORK, 1, X, 1 ) +C + END IF +C +C Add the direct contribution of the input to the output vectors. +C + CALL DGEMM( 'No transpose', 'Transpose', NY, P, M, ONE, U, LDU, + $ D, LDD, ONE, Y, LDY ) +C + RETURN +C *** Last line of TF01MY *** + END diff --git a/mex/sources/libslicot/TF01ND.f b/mex/sources/libslicot/TF01ND.f new file mode 100644 index 000000000..04676e7e5 --- /dev/null +++ b/mex/sources/libslicot/TF01ND.f @@ -0,0 +1,278 @@ + SUBROUTINE TF01ND( UPLO, N, M, P, NY, A, LDA, B, LDB, C, LDC, D, + $ LDD, U, LDU, X, Y, LDY, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the output sequence of a linear time-invariant +C open-loop system given by its discrete-time state-space model +C (A,B,C,D), where A is an N-by-N upper or lower Hessenberg matrix. +C +C The initial state vector x(1) must be supplied by the user. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Indicates whether the user wishes to use an upper or lower +C Hessenberg matrix as follows: +C = 'U': Upper Hessenberg matrix; +C = 'L': Lower Hessenberg matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NY (input) INTEGER +C The number of output vectors y(k) to be computed. +C NY >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C If UPLO = 'U', the leading N-by-N upper Hessenberg part +C of this array must contain the state matrix A of the +C system. +C If UPLO = 'L', the leading N-by-N lower Hessenberg part +C of this array must contain the state matrix A of the +C system. +C The remainder of the leading N-by-N part is not +C referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input matrix B of the system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C output matrix C of the system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct link matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C U (input) DOUBLE PRECISION array, dimension (LDU,NY) +C The leading M-by-NY part of this array must contain the +C input vector sequence u(k), for k = 1,2,...,NY. +C Specifically, the k-th column of U must contain u(k). +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,M). +C +C X (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the initial state vector +C x(1) which consists of the N initial states of the system. +C On exit, this array contains the final state vector +C x(NY+1) of the N states of the system at instant NY. +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,NY) +C The leading P-by-NY part of this array contains the output +C vector sequence y(1),y(2),...,y(NY) such that the k-th +C column of Y contains y(k) (the outputs at instant k), +C for k = 1,2,...,NY. +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= MAX(1,P). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given an initial state vector x(1), the output vector sequence +C y(1), y(2),..., y(NY) is obtained via the formulae +C +C x(k+1) = A x(k) + B u(k) +C y(k) = C x(k) + D u(k), +C +C where each element y(k) is a vector of length P containing the +C outputs at instant k and k = 1,2,...,NY. +C +C REFERENCES +C +C [1] Luenberger, D.G. +C Introduction to Dynamic Systems: Theory, Models and +C Applications. +C John Wiley & Sons, New York, 1979. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately ((N+M)xP + (N/2+M)xN) x NY +C multiplications and additions. +C +C FURTHER COMMENTS +C +C The processing time required by this routine will be approximately +C half that required by the SLICOT Library routine TF01MD, which +C treats A as a general matrix. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TF01BD by S. Van Huffel, Katholieke +C Univ. Leuven, Belgium. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003. +C +C KEYWORDS +C +C Discrete-time system, Hessenberg form, multivariable system, +C state-space model, state-space representation, time response. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LDC, LDD, LDU, LDY, M, N, NY, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), U(LDU,*), X(*), Y(LDY,*) +C .. Local Scalars .. + LOGICAL LUPLO + INTEGER I, IK +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, DTRMV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LUPLO = LSAME( UPLO, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( NY.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDU.LT.MAX( 1, M ) ) THEN + INFO = -15 + ELSE IF( LDY.LT.MAX( 1, P ) ) THEN + INFO = -18 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TF01ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( P, NY ).EQ.0 ) THEN + RETURN + ELSE IF ( N.EQ.0 ) THEN +C +C Non-dynamic system: compute the output vectors. +C + IF ( M.EQ.0 ) THEN + CALL DLASET( 'Full', P, NY, ZERO, ZERO, Y, LDY ) + ELSE + CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, + $ D, LDD, U, LDU, ZERO, Y, LDY ) + END IF + RETURN + END IF +C + CALL DCOPY( N, X, 1, DWORK, 1 ) +C + DO 30 IK = 1, NY + CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, DWORK, 1, ZERO, + $ Y(1,IK), 1 ) +C + CALL DTRMV( UPLO, 'No transpose', 'Non-unit', N, A, LDA, + $ DWORK, 1 ) +C + IF ( LUPLO ) THEN +C + DO 10 I = 2, N + DWORK(I) = DWORK(I) + A(I,I-1)*X(I-1) + 10 CONTINUE +C + ELSE +C + DO 20 I = 1, N - 1 + DWORK(I) = DWORK(I) + A(I,I+1)*X(I+1) + 20 CONTINUE +C + END IF +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, U(1,IK), 1, ONE, + $ DWORK, 1 ) +C + CALL DCOPY( N, DWORK, 1, X, 1 ) + 30 CONTINUE +C + CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, D, LDD, + $ U, LDU, ONE, Y, LDY ) +C + RETURN +C *** Last line of TF01ND *** + END diff --git a/mex/sources/libslicot/TF01OD.f b/mex/sources/libslicot/TF01OD.f new file mode 100644 index 000000000..656d86c9d --- /dev/null +++ b/mex/sources/libslicot/TF01OD.f @@ -0,0 +1,179 @@ + SUBROUTINE TF01OD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the block Hankel expansion T of a multivariable +C parameter sequence M(1),...,M(NR+NC-1), where each parameter M(k) +C is an NH1-by-NH2 block matrix and k = 1,2,...,(NR+NC-1). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NH1 (input) INTEGER +C The number of rows in each parameter M(k). NH1 >= 0. +C +C NH2 (input) INTEGER +C The number of columns in each parameter M(k). NH2 >= 0. +C +C NR (input) INTEGER +C The number of parameters required in each column of the +C block Hankel expansion matrix T. NR >= 0. +C +C NC (input) INTEGER +C The number of parameters required in each row of the +C block Hankel expansion matrix T. NC >= 0. +C +C H (input) DOUBLE PRECISION array, dimension +C (LDH,(NR+NC-1)*NH2) +C The leading NH1-by-(NR+NC-1)*NH2 part of this array must +C contain the multivariable sequence M(k), where k = 1,2, +C ...,(NR+NC-1). Specifically, each parameter M(k) is an +C NH1-by-NH2 matrix whose (i,j)-th element must be stored in +C H(i,(k-1)*NH2+j) for i = 1,2,...,NH1 and j = 1,2,...,NH2. +C +C LDH INTEGER +C The leading dimension of array H. LDH >= MAX(1,NH1). +C +C T (output) DOUBLE PRECISION array, dimension (LDT,NH2*NC) +C The leading NH1*NR-by-NH2*NC part of this array contains +C the block Hankel expansion of the multivariable sequence +C M(k). +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,NH1*NR). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The NH1-by-NH2 dimensional parameters M(k) of a multivariable +C sequence are arranged into a matrix T in Hankel form such that +C +C +C | M(1) M(2) M(3) . . . M(NC) | +C | | +C | M(2) M(3) M(4) . . . M(NC+1) | +C T = | . . . . |. +C | . . . . | +C | . . . . | +C | | +C | M(NR) M(NR+1) M(NR+2) . . . M(NR+NC-1)| +C +C REFERENCES +C +C [1] Johvidov, J.S. +C Hankel and Toeplitz Matrices and Forms: Algebraic Theory, +C (translated by G.P.A. Thijsse, I. Gohberg, ed.). +C Birkhaeuser, Boston, 1982. +C +C NUMERICAL ASPECTS +C +C The time taken is approximately proportional to +C NH1 x NH2 x NR x NC. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TF01CD by S. Van Huffel, Katholieke +C Univ. Leuven, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hankel matrix, multivariable system. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INFO, LDH, LDT, NC, NH1, NH2, NR +C .. Array Arguments .. + DOUBLE PRECISION H(LDH,*), T(LDT,*) +C .. Local Scalars .. + INTEGER IH, IT, JT, NROW +C .. External Subroutines .. + EXTERNAL DLACPY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( NH1.LT.0 ) THEN + INFO = -1 + ELSE IF( NH2.LT.0 ) THEN + INFO = -2 + ELSE IF( NR.LT.0 ) THEN + INFO = -3 + ELSE IF( NC.LT.0 ) THEN + INFO = -4 + ELSE IF( LDH.LT.MAX( 1, NH1 ) ) THEN + INFO = -6 + ELSE IF( LDT.LT.MAX( 1, NH1*NR ) ) THEN + INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TF01OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( NH1, NH2, NR, NC ).EQ.0 ) + $ RETURN +C +C Construct the first block column of T. +C + IH = 1 + NROW = (NR-1)*NH1 +C + DO 10 IT = 1, NROW+NH1, NH1 + CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(IT,1), LDT ) + IH = IH + NH2 + 10 CONTINUE +C +C Construct the remaining block columns of T. +C + DO 20 JT = NH2+1, NC*NH2, NH2 + CALL DLACPY( 'Full', NROW, NH2, T(NH1+1,JT-NH2), LDT, T(1,JT), + $ LDT ) + CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(NROW+1,JT), + $ LDT ) + IH = IH + NH2 + 20 CONTINUE +C + RETURN +C *** Last line of TF01OD *** + END diff --git a/mex/sources/libslicot/TF01PD.f b/mex/sources/libslicot/TF01PD.f new file mode 100644 index 000000000..e45f078b6 --- /dev/null +++ b/mex/sources/libslicot/TF01PD.f @@ -0,0 +1,178 @@ + SUBROUTINE TF01PD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the block Toeplitz expansion T of a multivariable +C parameter sequence M(1),...,M(NR+NC-1), where each parameter M(k) +C is an NH1-by-NH2 block matrix and k = 1,2,...,(NR+NC-1). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NH1 (input) INTEGER +C The number of rows in each parameter M(k). NH1 >= 0. +C +C NH2 (input) INTEGER +C The number of columns in each parameter M(k). NH2 >= 0. +C +C NR (input) INTEGER +C The number of parameters required in each column of the +C block Toeplitz expansion matrix T. NR >= 0. +C +C NC (input) INTEGER +C The number of parameters required in each row of the +C block Toeplitz expansion matrix T. NC >= 0. +C +C H (input) DOUBLE PRECISION array, dimension +C (LDH,(NR+NC-1)*NH2) +C The leading NH1-by-(NR+NC-1)*NH2 part of this array must +C contain the multivariable sequence M(k), where k = 1,2, +C ...,(NR+NC-1). Specifically, each parameter M(k) is an +C NH1-by-NH2 matrix whose (i,j)-th element must be stored in +C H(i,(k-1)*NH2+j) for i = 1,2,...,NH1 and j = 1,2,...,NH2. +C +C LDH INTEGER +C The leading dimension of array H. LDH >= MAX(1,NH1). +C +C T (output) DOUBLE PRECISION array, dimension (LDT,NH2*NC) +C The leading NH1*NR-by-NH2*NC part of this array contains +C the block Toeplitz expansion of the multivariable sequence +C M(k). +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,NH1*NR). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The NH1-by-NH2 dimensional parameters M(k) of a multivariable +C sequence are arranged into a matrix T in Toeplitz form such that +C +C | M(NC) M(NC-1) M(NC-2) . . . M(1) | +C | | +C | M(NC+1) M(NC) M(NC-1) . . . M(2) | +C T = | . . . . |. +C | . . . . | +C | . . . . | +C | | +C | M(NR+NC-1) M(NR+NC-2) M(NR+NC-3) . . . M(NR) | +C +C REFERENCES +C +C [1] Johvidov, J.S. +C Hankel and Toeplitz Matrices and Forms: Algebraic Theory, +C (translated by G.P.A. Thijsse, I. Gohberg, ed.). +C Birkhaeuser, Boston, 1982. +C +C NUMERICAL ASPECTS +C +C The time taken is approximately proportional to +C NH1 x NH2 x NR x NC. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TF01DD by S. Van Huffel, Katholieke +C Univ. Leuven, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Multivariable system, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INFO, LDH, LDT, NC, NH1, NH2, NR +C .. Array Arguments .. + DOUBLE PRECISION H(LDH,*), T(LDT,*) +C .. Local Scalars .. + INTEGER IH, IT, JT, NCOL, NROW +C .. External Subroutines .. + EXTERNAL DLACPY, XERBLA +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( NH1.LT.0 ) THEN + INFO = -1 + ELSE IF( NH2.LT.0 ) THEN + INFO = -2 + ELSE IF( NR.LT.0 ) THEN + INFO = -3 + ELSE IF( NC.LT.0 ) THEN + INFO = -4 + ELSE IF( LDH.LT.MAX( 1, NH1 ) ) THEN + INFO = -6 + ELSE IF( LDT.LT.MAX( 1, NH1*NR ) ) THEN + INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TF01PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( NH1, NH2, NR, NC ).EQ.0 ) + $ RETURN +C +C Construct the last block column of T. +C + IH = 1 + NROW = (NR-1)*NH1 + NCOL = (NC-1)*NH2 + 1 +C + DO 10 IT = 1, NROW+NH1, NH1 + CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(IT,NCOL), + $ LDT ) + IH = IH + NH2 + 10 CONTINUE +C +C Construct the remaining block columns of T in backward order. +C + DO 20 JT = NCOL-NH2, 1, -NH2 + CALL DLACPY( 'Full', NROW, NH2, T(NH1+1,JT+NH2), LDT, T(1,JT), + $ LDT ) + CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(NROW+1,JT), + $ LDT ) + IH = IH + NH2 + 20 CONTINUE +C + RETURN +C *** Last line of TF01PD *** + END diff --git a/mex/sources/libslicot/TF01QD.f b/mex/sources/libslicot/TF01QD.f new file mode 100644 index 000000000..a2d3696ce --- /dev/null +++ b/mex/sources/libslicot/TF01QD.f @@ -0,0 +1,234 @@ + SUBROUTINE TF01QD( NC, NB, N, IORD, AR, MA, H, LDH, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute N Markov parameters M(1), M(2),..., M(N) from a +C multivariable system whose transfer function matrix G(z) is given. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NC (input) INTEGER +C The number of system outputs, i.e. the number of rows in +C the transfer function matrix G(z). NC >= 0. +C +C NB (input) INTEGER +C The number of system inputs, i.e. the number of columns in +C the transfer function matrix G(z). NB >= 0. +C +C N (input) INTEGER +C The number of Markov parameters M(k) to be computed. +C N >= 0. +C +C IORD (input) INTEGER array, dimension (NC*NB) +C This array must contain the order r of the elements of the +C transfer function matrix G(z), stored row by row. +C For example, the order of the (i,j)-th element of G(z) is +C given by IORD((i-1)xNB+j). +C +C AR (input) DOUBLE PRECISION array, dimension (NA), where +C NA = IORD(1) + IORD(2) + ... + IORD(NC*NB). +C The leading NA elements of this array must contain the +C denominator coefficients AR(1),...,AR(r) in equation (1) +C of the (i,j)-th element of the transfer function matrix +C G(z), stored row by row, i.e. in the order +C (1,1),(1,2),...,(1,NB), (2,1),(2,2),...,(2,NB), ..., +C (NC,1),(NC,2),...,(NC,NB). The coefficients must be given +C in decreasing order of powers of z; the coefficient of the +C highest order term is assumed to be equal to 1. +C +C MA (input) DOUBLE PRECISION array, dimension (NA) +C The leading NA elements of this array must contain the +C numerator coefficients MA(1),...,MA(r) in equation (1) +C of the (i,j)-th element of the transfer function matrix +C G(z), stored row by row, i.e. in the order +C (1,1),(1,2),...,(1,NB), (2,1),(2,2),...,(2,NB), ..., +C (NC,1),(NC,2),...,(NC,NB). The coefficients must be given +C in decreasing order of powers of z. +C +C H (output) DOUBLE PRECISION array, dimension (LDH,N*NB) +C The leading NC-by-N*NB part of this array contains the +C multivariable Markov parameter sequence M(k), where each +C parameter M(k) is an NC-by-NB matrix and k = 1,2,...,N. +C The Markov parameters are stored such that H(i,(k-1)xNB+j) +C contains the (i,j)-th element of M(k) for i = 1,2,...,NC +C and j = 1,2,...,NB. +C +C LDH INTEGER +C The leading dimension of array H. LDH >= MAX(1,NC). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The (i,j)-th element of G(z), defining the particular I/O transfer +C between output i and input j, has the following form: +C +C -1 -2 -r +C MA(1)z + MA(2)z + ... + MA(r)z +C G (z) = ----------------------------------------. (1) +C ij -1 -2 -r +C 1 + AR(1)z + AR(2)z + ... + AR(r)z +C +C The (i,j)-th element of G(z) is defined by its order r, its r +C moving average coefficients (= numerator) MA(1),...,MA(r) and its +C r autoregressive coefficients (= denominator) AR(1),...,AR(r). The +C coefficient of the constant term in the denominator is assumed to +C be equal to 1. +C +C The relationship between the (i,j)-th element of the Markov +C parameters M(1),M(2),...,M(N) and the corresponding element of the +C transfer function matrix G(z) is given by: +C +C -1 -2 -k +C G (z) = M (0) + M (1)z + M (2)z + ... + M (k)z + ...(2) +C ij ij ij ij ij +C +C Equating (1) and (2), we find that the relationship between the +C (i,j)-th element of the Markov parameters M(k) and the ARMA +C parameters AR(1),...,AR(r) and MA(1),...,MA(r) of the (i,j)-th +C element of the transfer function matrix G(z) is as follows: +C +C M (1) = MA(1), +C ij +C k-1 +C M (k) = MA(k) - SUM AR(p) x M (k-p) for 1 < k <= r and +C ij p=1 ij +C r +C M (k+r) = - SUM AR(p) x M (k+r-p) for k > 0. +C ij p=1 ij +C +C From these expressions the Markov parameters M(k) are computed +C element by element. +C +C REFERENCES +C +C [1] Luenberger, D.G. +C Introduction to Dynamic Systems: Theory, Models and +C Applications. +C John Wiley & Sons, New York, 1979. +C +C NUMERICAL ASPECTS +C +C The computation of the (i,j)-th element of M(k) requires: +C (k-1) multiplications and k additions if k <= r; +C r multiplications and r additions if k > r. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TF01ED by S. Van Huffel, Katholieke +C Univ. Leuven, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Markov parameters, multivariable system, transfer function, +C transfer matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDH, N, NB, NC +C .. Array Arguments .. + INTEGER IORD(*) + DOUBLE PRECISION AR(*), H(LDH,*), MA(*) +C .. Local Scalars .. + INTEGER I, J, JJ, JK, K, KI, LDHNB, NL, NORD +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( NC.LT.0 ) THEN + INFO = -1 + ELSE IF( NB.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDH.LT.MAX( 1, NC ) ) THEN + INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TF01QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( NC, NB, N ).EQ.0 ) + $ RETURN +C + LDHNB = LDH*NB + NL = 1 + K = 1 +C + DO 60 I = 1, NC +C + DO 50 J = 1, NB + NORD = IORD(K) + H(I,J) = MA(NL) + JK = J +C + DO 20 KI = 1, NORD - 1 + JK = JK + NB + H(I,JK) = MA(NL+KI) - DDOT( KI, AR(NL), 1, H(I,J), + $ -LDHNB ) + 20 CONTINUE +C + DO 40 JJ = J, J + (N - NORD - 1)*NB, NB + JK = JK + NB + H(I,JK) = -DDOT( NORD, AR(NL), 1, H(I,JJ), -LDHNB ) + 40 CONTINUE +C + NL = NL + NORD + K = K + 1 + 50 CONTINUE +C + 60 CONTINUE +C + RETURN +C *** Last line of TF01QD *** + END diff --git a/mex/sources/libslicot/TF01RD.f b/mex/sources/libslicot/TF01RD.f new file mode 100644 index 000000000..d28a6ed98 --- /dev/null +++ b/mex/sources/libslicot/TF01RD.f @@ -0,0 +1,230 @@ + SUBROUTINE TF01RD( NA, NB, NC, N, A, LDA, B, LDB, C, LDC, H, LDH, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute N Markov parameters M(1), M(2),..., M(N) from the +C parameters (A,B,C) of a linear time-invariant system, where each +C M(k) is an NC-by-NB matrix and k = 1,2,...,N. +C +C All matrices are treated as dense, and hence TF01RD is not +C intended for large sparse problems. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NA (input) INTEGER +C The order of the matrix A. NA >= 0. +C +C NB (input) INTEGER +C The number of system inputs. NB >= 0. +C +C NC (input) INTEGER +C The number of system outputs. NC >= 0. +C +C N (input) INTEGER +C The number of Markov parameters M(k) to be computed. +C N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,NA) +C The leading NA-by-NA part of this array must contain the +C state matrix A of the system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,NA). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,NB) +C The leading NA-by-NB part of this array must contain the +C input matrix B of the system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,NA). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,NA) +C The leading NC-by-NA part of this array must contain the +C output matrix C of the system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,NC). +C +C H (output) DOUBLE PRECISION array, dimension (LDH,N*NB) +C The leading NC-by-N*NB part of this array contains the +C multivariable parameters M(k), where each parameter M(k) +C is an NC-by-NB matrix and k = 1,2,...,N. The Markov +C parameters are stored such that H(i,(k-1)xNB+j) contains +C the (i,j)-th element of M(k) for i = 1,2,...,NC and +C j = 1,2,...,NB. +C +C LDH INTEGER +C The leading dimension of array H. LDH >= MAX(1,NC). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, 2*NA*NC). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C For the linear time-invariant discrete-time system +C +C x(k+1) = A x(k) + B u(k) +C y(k) = C x(k) + D u(k), +C +C the transfer function matrix G(z) is given by +C -1 +C G(z) = C(zI-A) B + D +C -1 -2 2 -3 +C = D + CB z + CAB z + CA B z + ... (1) +C +C Using Markov parameters, G(z) can also be written as +C -1 -2 -3 +C G(z) = M(0) + M(1)z + M(2)z + M(3)z + ... (2) +C +C k-1 +C Equating (1) and (2), we find that M(0) = D and M(k) = C A B +C for k > 0, from which the Markov parameters M(1),M(2)...,M(N) are +C computed. +C +C REFERENCES +C +C [1] Chen, C.T. +C Introduction to Linear System Theory. +C H.R.W. Series in Electrical Engineering, Electronics and +C Systems, Holt, Rinehart and Winston Inc., London, 1970. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately (NA + NB) x NA x NC x N +C multiplications and additions. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TF01FD by S. Van Huffel, Katholieke +C Univ. Leuven, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Markov parameters, multivariable system, time-invariant system, +C transfer function, transfer matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDH, LDWORK, N, NA, NB, NC +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), H(LDH,*) +C .. Local Scalars .. + INTEGER I, JWORK, K, LDW +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( NA.LT.0 ) THEN + INFO = -1 + ELSE IF( NB.LT.0 ) THEN + INFO = -2 + ELSE IF( NC.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, NA ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, NA ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, NC ) ) THEN + INFO = -10 + ELSE IF( LDH.LT.MAX( 1, NC ) ) THEN + INFO = -12 + ELSE IF( LDWORK.LT.MAX( 1, 2*NA*NC ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TF01RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( NA, NB, NC, N ).EQ.0 ) + $ RETURN +C + JWORK = 1 + NC*NA + LDW = MAX( 1, NC ) + I = 1 +C +C Copy C in the workspace beginning from the position JWORK. +C This workspace will contain the product C*A**(K-1), K = 1,2,...,N. +C + CALL DLACPY( 'Full', NC, NA, C, LDC, DWORK(JWORK), LDW ) +C +C Form M(1), M(2), ..., M(N). +C + DO 10 K = 1, N + CALL DLACPY( 'Full', NC, NA, DWORK(JWORK), LDW, DWORK, LDW ) +C +C Form (C * A**(K-1)) * B = M(K). +C + CALL DGEMM( 'No transpose', 'No transpose', NC, NB, NA, ONE, + $ DWORK, LDW, B, LDB, ZERO, H(1,I), LDH ) +C + IF ( K.NE.N ) THEN +C +C Form C * A**K. +C + CALL DGEMM( 'No transpose', 'No transpose', NC, NA, NA, ONE, + $ DWORK, LDW, A, LDA, ZERO, DWORK(JWORK), LDW ) +C + I = I + NB + END IF + 10 CONTINUE +C + RETURN +C *** Last line of TF01RD *** + END diff --git a/mex/sources/libslicot/TG01AD.f b/mex/sources/libslicot/TG01AD.f new file mode 100644 index 000000000..5bae2d7bf --- /dev/null +++ b/mex/sources/libslicot/TG01AD.f @@ -0,0 +1,513 @@ + SUBROUTINE TG01AD( JOB, L, N, M, P, THRESH, A, LDA, E, LDE, + $ B, LDB, C, LDC, LSCALE, RSCALE, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To balance the matrices of the system pencil +C +C S = ( A B ) - lambda ( E 0 ) := Q - lambda Z, +C ( C 0 ) ( 0 0 ) +C +C corresponding to the descriptor triple (A-lambda E,B,C), +C by balancing. This involves diagonal similarity transformations +C (Dl*A*Dr - lambda Dl*E*Dr, Dl*B, C*Dr) applied to the system +C (A-lambda E,B,C) to make the rows and columns of system pencil +C matrices +C +C diag(Dl,I) * S * diag(Dr,I) +C +C as close in norm as possible. Balancing may reduce the 1-norms +C of the matrices of the system pencil S. +C +C The balancing can be performed optionally on the following +C particular system pencils +C +C S = A-lambda E, +C +C S = ( A-lambda E B ), or +C +C S = ( A-lambda E ). +C ( C ) +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Indicates which matrices are involved in balancing, as +C follows: +C = 'A': All matrices are involved in balancing; +C = 'B': B, A and E matrices are involved in balancing; +C = 'C': C, A and E matrices are involved in balancing; +C = 'N': B and C matrices are not involved in balancing. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A, B, and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A, E, and C. N >= 0. +C +C M (input) INTEGER +C The number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The number of rows of matrix C. P >= 0. +C +C THRESH (input) DOUBLE PRECISION +C Threshold value for magnitude of elements: +C elements with magnitude less than or equal to +C THRESH are ignored for balancing. THRESH >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading L-by-N part of this array contains +C the balanced matrix Dl*A*Dr. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E. +C On exit, the leading L-by-N part of this array contains +C the balanced matrix Dl*E*Dr. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the input/state matrix B. +C On exit, if M > 0, the leading L-by-M part of this array +C contains the balanced matrix Dl*B. +C The array B is not referenced if M = 0. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, if P > 0, the leading P-by-N part of this array +C contains the balanced matrix C*Dr. +C The array C is not referenced if P = 0. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C LSCALE (output) DOUBLE PRECISION array, dimension (L) +C The scaling factors applied to S from left. If Dl(j) is +C the scaling factor applied to row j, then +C SCALE(j) = Dl(j), for j = 1,...,L. +C +C RSCALE (output) DOUBLE PRECISION array, dimension (N) +C The scaling factors applied to S from right. If Dr(j) is +C the scaling factor applied to column j, then +C SCALE(j) = Dr(j), for j = 1,...,N. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (3*(L+N)) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Balancing consists of applying a diagonal similarity +C transformation +C -1 +C diag(Dl,I) * S * diag(Dr,I) +C +C to make the 1-norms of each row of the first L rows of S and its +C corresponding N columns nearly equal. +C +C Information about the diagonal matrices Dl and Dr are returned in +C the vectors LSCALE and RSCALE, respectively. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C [2] R.C. Ward, R. C. +C Balancing the generalized eigenvalue problem. +C SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. Based on the LAPACK routine DGGBAL. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 1999, +C May 2003, March 2004, Jan. 2009. +C +C KEYWORDS +C +C Balancing, eigenvalue, matrix algebra, matrix operations, +C similarity transformation. +C +C ********************************************************************* +C +C .. Parameters .. + DOUBLE PRECISION HALF, ONE, ZERO + PARAMETER ( HALF = 0.5D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) + DOUBLE PRECISION SCLFAC, THREE + PARAMETER ( SCLFAC = 1.0D+1, THREE = 3.0D+0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, L, LDA, LDB, LDC, LDE, M, N, P + DOUBLE PRECISION THRESH +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), E( LDE, * ), LSCALE( * ), + $ RSCALE( * ) +C .. Local Scalars .. + LOGICAL WITHB, WITHC + INTEGER I, ICAB, IR, IRAB, IT, J, JC, KOUNT, KW1, KW2, + $ KW3, KW4, KW5, LCAB, LRAB, LSFMAX, LSFMIN, + $ NRP2 + DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, + $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, + $ SFMIN, SUM, T, TA, TB, TC, TE +C .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ) +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DDOT, DLAMCH + EXTERNAL DDOT, DLAMCH, IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG10, MAX, MIN, SIGN +C +C .. Executable Statements .. +C +C Test the input parameters. +C + INFO = 0 + WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) + WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) +C + IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) + $ THEN + INFO = -1 + ELSE IF( L.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( THRESH.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -8 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -14 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( L.EQ.0 .OR. N.EQ.0 ) THEN + DUM( 1 ) = ONE + IF( L.GT.0 ) THEN + CALL DCOPY( L, DUM, 0, LSCALE, 1 ) + ELSE IF( N.GT.0 ) THEN + CALL DCOPY( N, DUM, 0, RSCALE, 1 ) + END IF + RETURN + END IF +C +C Initialize balancing and allocate work storage. +C + KW1 = N + KW2 = KW1 + L + KW3 = KW2 + L + KW4 = KW3 + N + KW5 = KW4 + L + DUM( 1 ) = ZERO + CALL DCOPY( L, DUM, 0, LSCALE, 1 ) + CALL DCOPY( N, DUM, 0, RSCALE, 1 ) + CALL DCOPY( 3*(L+N), DUM, 0, DWORK, 1 ) +C +C Compute right side vector in resulting linear equations. +C + BASL = LOG10( SCLFAC ) + DO 20 I = 1, L + DO 10 J = 1, N + TE = ABS( E( I, J ) ) + TA = ABS( A( I, J ) ) + IF( TA.GT.THRESH ) THEN + TA = LOG10( TA ) / BASL + ELSE + TA = ZERO + END IF + IF( TE.GT.THRESH ) THEN + TE = LOG10( TE ) / BASL + ELSE + TE = ZERO + END IF + DWORK( I+KW4 ) = DWORK( I+KW4 ) - TA - TE + DWORK( J+KW5 ) = DWORK( J+KW5 ) - TA - TE + 10 CONTINUE + 20 CONTINUE +C + IF( M.EQ.0 ) THEN + WITHB = .FALSE. + TB = ZERO + END IF + IF( P.EQ.0 ) THEN + WITHC = .FALSE. + TC = ZERO + END IF +C + IF( WITHB ) THEN + DO 30 I = 1, L + J = IDAMAX( M, B( I, 1 ), LDB ) + TB = ABS( B( I, J ) ) + IF( TB.GT.THRESH ) THEN + TB = LOG10( TB ) / BASL + DWORK( I+KW4 ) = DWORK( I+KW4 ) - TB + END IF + 30 CONTINUE + END IF +C + IF( WITHC ) THEN + DO 40 J = 1, N + I = IDAMAX( P, C( 1, J ), 1 ) + TC = ABS( C( I, J ) ) + IF( TC.GT.THRESH ) THEN + TC = LOG10( TC ) / BASL + DWORK( J+KW5 ) = DWORK( J+KW5 ) - TC + END IF + 40 CONTINUE + END IF +C + COEF = ONE / DBLE( L+N ) + COEF2 = COEF*COEF + COEF5 = HALF*COEF2 + NRP2 = MAX( L, N ) + 2 + BETA = ZERO + IT = 1 +C +C Start generalized conjugate gradient iteration. +C + 50 CONTINUE +C + GAMMA = DDOT( L, DWORK( 1+KW4 ), 1, DWORK( 1+KW4 ), 1 ) + + $ DDOT( N, DWORK( 1+KW5 ), 1, DWORK( 1+KW5 ), 1 ) +C + EW = ZERO + DO 60 I = 1, L + EW = EW + DWORK( I+KW4 ) + 60 CONTINUE +C + EWC = ZERO + DO 70 I = 1, N + EWC = EWC + DWORK( I+KW5 ) + 70 CONTINUE +C + GAMMA = COEF*GAMMA - COEF2*( EW**2 + EWC**2 ) - + $ COEF5*( EW - EWC )**2 + IF( GAMMA.EQ.ZERO ) + $ GO TO 160 + IF( IT.NE.1 ) + $ BETA = GAMMA / PGAMMA + T = COEF5*( EWC - THREE*EW ) + TC = COEF5*( EW - THREE*EWC ) +C + CALL DSCAL( N+L, BETA, DWORK, 1 ) +C + CALL DAXPY( L, COEF, DWORK( 1+KW4 ), 1, DWORK( 1+KW1 ), 1 ) + CALL DAXPY( N, COEF, DWORK( 1+KW5 ), 1, DWORK, 1 ) +C + DO 80 J = 1, N + DWORK( J ) = DWORK( J ) + TC + 80 CONTINUE +C + DO 90 I = 1, L + DWORK( I+KW1 ) = DWORK( I+KW1 ) + T + 90 CONTINUE +C +C Apply matrix to vector. +C + DO 110 I = 1, L + KOUNT = 0 + SUM = ZERO + DO 100 J = 1, N + IF( ABS( A( I, J ) ).GT.THRESH ) THEN + KOUNT = KOUNT + 1 + SUM = SUM + DWORK( J ) + END IF + IF( ABS( E( I, J ) ).GT.THRESH ) THEN + KOUNT = KOUNT + 1 + SUM = SUM + DWORK( J ) + END IF + 100 CONTINUE + IF( WITHB ) THEN + J = IDAMAX( M, B( I, 1 ), LDB ) + IF( ABS( B( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 + END IF + DWORK( I+KW2 ) = DBLE( KOUNT )*DWORK( I+KW1 ) + SUM + 110 CONTINUE +C + DO 130 J = 1, N + KOUNT = 0 + SUM = ZERO + DO 120 I = 1, L + IF( ABS( A( I, J ) ).GT.THRESH ) THEN + KOUNT = KOUNT + 1 + SUM = SUM + DWORK( I+KW1 ) + END IF + IF( ABS( E( I, J ) ).GT.THRESH ) THEN + KOUNT = KOUNT + 1 + SUM = SUM + DWORK( I+KW1 ) + END IF + 120 CONTINUE + IF( WITHC ) THEN + I = IDAMAX( P, C( 1, J ), 1 ) + IF( ABS( C( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 + END IF + DWORK( J+KW3 ) = DBLE( KOUNT )*DWORK( J ) + SUM + 130 CONTINUE +C + SUM = DDOT( L, DWORK( 1+KW1 ), 1, DWORK( 1+KW2 ), 1 ) + + $ DDOT( N, DWORK, 1, DWORK( 1+KW3 ), 1 ) + ALPHA = GAMMA / SUM +C +C Determine correction to current iteration. +C + CMAX = ZERO + DO 140 I = 1, L + COR = ALPHA*DWORK( I+KW1 ) + IF( ABS( COR ).GT.CMAX ) + $ CMAX = ABS( COR ) + LSCALE( I ) = LSCALE( I ) + COR + 140 CONTINUE +C + DO 150 J = 1, N + COR = ALPHA*DWORK( J ) + IF( ABS( COR ).GT.CMAX ) + $ CMAX = ABS( COR ) + RSCALE( J ) = RSCALE( J ) + COR + 150 CONTINUE + IF( CMAX.LT.HALF ) + $ GO TO 160 +C + CALL DAXPY( L, -ALPHA, DWORK( 1+KW2 ), 1, DWORK( 1+KW4 ), 1 ) + CALL DAXPY( N, -ALPHA, DWORK( 1+KW3 ), 1, DWORK( 1+KW5 ), 1 ) +C + PGAMMA = GAMMA + IT = IT + 1 + IF( IT.LE.NRP2 ) + $ GO TO 50 +C +C End generalized conjugate gradient iteration. +C + 160 CONTINUE + SFMIN = DLAMCH( 'Safe minimum' ) + SFMAX = ONE / SFMIN + LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE ) + LSFMAX = INT( LOG10( SFMAX ) / BASL ) +C +C Compute left diagonal scaling matrix. +C + DO 170 I = 1, L + IRAB = IDAMAX( N, A( I, 1 ), LDA ) + RAB = ABS( A( I, IRAB ) ) + IRAB = IDAMAX( N, E( I, 1 ), LDE ) + RAB = MAX( RAB, ABS( E( I, IRAB ) ) ) + IF( WITHB ) THEN + IRAB = IDAMAX( M, B( I, 1 ), LDB ) + RAB = MAX( RAB, ABS( B( I, IRAB ) ) ) + END IF + LRAB = INT( LOG10( RAB+SFMIN ) / BASL + ONE ) + IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) + IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) + LSCALE( I ) = SCLFAC**IR + 170 CONTINUE +C +C Compute right diagonal scaling matrix. +C + DO 180 J = 1, N + ICAB = IDAMAX( L, A( 1, J ), 1 ) + CAB = ABS( A( ICAB, J ) ) + ICAB = IDAMAX( L, E( 1, J ), 1 ) + CAB = MAX( CAB, ABS( E( ICAB, J ) ) ) + IF( WITHC ) THEN + ICAB = IDAMAX( P, C( 1, J ), 1 ) + CAB = MAX( CAB, ABS( C( ICAB, J ) ) ) + END IF + LCAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE ) + JC = RSCALE( J ) + SIGN( HALF, RSCALE( J ) ) + JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) + RSCALE( J ) = SCLFAC**JC + 180 CONTINUE +C +C Row scaling of matrices A, E and B. +C + DO 190 I = 1, L + CALL DSCAL( N, LSCALE( I ), A( I, 1 ), LDA ) + CALL DSCAL( N, LSCALE( I ), E( I, 1 ), LDE ) + IF( WITHB ) + $ CALL DSCAL( M, LSCALE( I ), B( I, 1 ), LDB ) + 190 CONTINUE +C +C Column scaling of matrices A, E and C. +C + DO 200 J = 1, N + CALL DSCAL( L, RSCALE( J ), A( 1, J ), 1 ) + CALL DSCAL( L, RSCALE( J ), E( 1, J ), 1 ) + IF( WITHC ) + $ CALL DSCAL( P, RSCALE( J ), C( 1, J ), 1 ) + 200 CONTINUE +C + RETURN +C *** Last line of TG01AD *** + END diff --git a/mex/sources/libslicot/TG01AZ.f b/mex/sources/libslicot/TG01AZ.f new file mode 100644 index 000000000..2c0bb3bcf --- /dev/null +++ b/mex/sources/libslicot/TG01AZ.f @@ -0,0 +1,523 @@ + SUBROUTINE TG01AZ( JOB, L, N, M, P, THRESH, A, LDA, E, LDE, + $ B, LDB, C, LDC, LSCALE, RSCALE, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To balance the matrices of the system pencil +C +C S = ( A B ) - lambda ( E 0 ) := Q - lambda Z, +C ( C 0 ) ( 0 0 ) +C +C corresponding to the descriptor triple (A-lambda E,B,C), +C by balancing. This involves diagonal similarity transformations +C (Dl*A*Dr - lambda Dl*E*Dr, Dl*B, C*Dr) applied to the system +C (A-lambda E,B,C) to make the rows and columns of system pencil +C matrices +C +C diag(Dl,I) * S * diag(Dr,I) +C +C as close in norm as possible. Balancing may reduce the 1-norms +C of the matrices of the system pencil S. +C +C The balancing can be performed optionally on the following +C particular system pencils +C +C S = A-lambda E, +C +C S = ( A-lambda E B ), or +C +C S = ( A-lambda E ). +C ( C ) +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Indicates which matrices are involved in balancing, as +C follows: +C = 'A': All matrices are involved in balancing; +C = 'B': B, A and E matrices are involved in balancing; +C = 'C': C, A and E matrices are involved in balancing; +C = 'N': B and C matrices are not involved in balancing. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A, B, and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A, E, and C. N >= 0. +C +C M (input) INTEGER +C The number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The number of rows of matrix C. P >= 0. +C +C THRESH (input) DOUBLE PRECISION +C Threshold value for magnitude of elements: +C elements with magnitude less than or equal to +C THRESH are ignored for balancing. THRESH >= 0. +C The magnitude is computed as the sum of the absolute +C values of the real and imaginary parts. +C +C A (input/output) COMPLEX*16 array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading L-by-N part of this array contains +C the balanced matrix Dl*A*Dr. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) COMPLEX*16 array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E. +C On exit, the leading L-by-N part of this array contains +C the balanced matrix Dl*E*Dr. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) COMPLEX*16 array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the input/state matrix B. +C On exit, if M > 0, the leading L-by-M part of this array +C contains the balanced matrix Dl*B. +C The array B is not referenced if M = 0. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. +C +C C (input/output) COMPLEX*16 array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, if P > 0, the leading P-by-N part of this array +C contains the balanced matrix C*Dr. +C The array C is not referenced if P = 0. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C LSCALE (output) DOUBLE PRECISION array, dimension (L) +C The scaling factors applied to S from left. If Dl(j) is +C the scaling factor applied to row j, then +C SCALE(j) = Dl(j), for j = 1,...,L. +C +C RSCALE (output) DOUBLE PRECISION array, dimension (N) +C The scaling factors applied to S from right. If Dr(j) is +C the scaling factor applied to column j, then +C SCALE(j) = Dr(j), for j = 1,...,N. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (3*(L+N)) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Balancing consists of applying a diagonal similarity +C transformation +C -1 +C diag(Dl,I) * S * diag(Dr,I) +C +C to make the 1-norms of each row of the first L rows of S and its +C corresponding N columns nearly equal. +C +C Information about the diagonal matrices Dl and Dr are returned in +C the vectors LSCALE and RSCALE, respectively. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C [2] R.C. Ward, R. C. +C Balancing the generalized eigenvalue problem. +C SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Balancing, eigenvalue, matrix algebra, matrix operations, +C similarity transformation. +C +C ********************************************************************* +C +C .. Parameters .. + DOUBLE PRECISION HALF, ONE, ZERO + PARAMETER ( HALF = 0.5D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) + DOUBLE PRECISION SCLFAC, THREE + PARAMETER ( SCLFAC = 1.0D+1, THREE = 3.0D+0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, L, LDA, LDB, LDC, LDE, M, N, P + DOUBLE PRECISION THRESH +C .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ E( LDE, * ) + DOUBLE PRECISION DWORK( * ), LSCALE( * ), RSCALE( * ) +C .. Local Scalars .. + LOGICAL WITHB, WITHC + INTEGER I, ICAB, IR, IRAB, IT, J, JC, KOUNT, KW1, KW2, + $ KW3, KW4, KW5, LCAB, LRAB, LSFMAX, LSFMIN, + $ NRP2 + DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, + $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, + $ SFMIN, SUM, T, TA, TB, TC, TE + COMPLEX*16 CDUM +C .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ) +C .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DDOT, DLAMCH + EXTERNAL DDOT, DLAMCH, IZAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSCAL, XERBLA, ZDSCAL +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG, INT, LOG10, MAX, MIN, SIGN +C .. +C .. Statement Functions .. + DOUBLE PRECISION CABS1 +C .. +C .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +C +C .. Executable Statements .. +C +C Test the input parameters. +C + INFO = 0 + WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) + WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) +C + IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) + $ THEN + INFO = -1 + ELSE IF( L.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( THRESH.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -8 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -14 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01AZ', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( L.EQ.0 .OR. N.EQ.0 ) THEN + DUM( 1 ) = ONE + IF( L.GT.0 ) THEN + CALL DCOPY( L, DUM, 0, LSCALE, 1 ) + ELSE IF( N.GT.0 ) THEN + CALL DCOPY( N, DUM, 0, RSCALE, 1 ) + END IF + RETURN + END IF +C +C Initialize balancing and allocate work storage. +C + KW1 = N + KW2 = KW1 + L + KW3 = KW2 + L + KW4 = KW3 + N + KW5 = KW4 + L + DUM( 1 ) = ZERO + CALL DCOPY( L, DUM, 0, LSCALE, 1 ) + CALL DCOPY( N, DUM, 0, RSCALE, 1 ) + CALL DCOPY( 3*(L+N), DUM, 0, DWORK, 1 ) +C +C Compute right side vector in resulting linear equations. +C + BASL = LOG10( SCLFAC ) + DO 20 I = 1, L + DO 10 J = 1, N + TE = CABS1( E( I, J ) ) + TA = CABS1( A( I, J ) ) + IF( TA.GT.THRESH ) THEN + TA = LOG10( TA ) / BASL + ELSE + TA = ZERO + END IF + IF( TE.GT.THRESH ) THEN + TE = LOG10( TE ) / BASL + ELSE + TE = ZERO + END IF + DWORK( I+KW4 ) = DWORK( I+KW4 ) - TA - TE + DWORK( J+KW5 ) = DWORK( J+KW5 ) - TA - TE + 10 CONTINUE + 20 CONTINUE +C + IF( M.EQ.0 ) THEN + WITHB = .FALSE. + TB = ZERO + END IF + IF( P.EQ.0 ) THEN + WITHC = .FALSE. + TC = ZERO + END IF +C + IF( WITHB ) THEN + DO 30 I = 1, L + J = IZAMAX( M, B( I, 1 ), LDB ) + TB = CABS1( B( I, J ) ) + IF( TB.GT.THRESH ) THEN + TB = LOG10( TB ) / BASL + DWORK( I+KW4 ) = DWORK( I+KW4 ) - TB + END IF + 30 CONTINUE + END IF +C + IF( WITHC ) THEN + DO 40 J = 1, N + I = IZAMAX( P, C( 1, J ), 1 ) + TC = CABS1( C( I, J ) ) + IF( TC.GT.THRESH ) THEN + TC = LOG10( TC ) / BASL + DWORK( J+KW5 ) = DWORK( J+KW5 ) - TC + END IF + 40 CONTINUE + END IF +C + COEF = ONE / DBLE( L+N ) + COEF2 = COEF*COEF + COEF5 = HALF*COEF2 + NRP2 = MAX( L, N ) + 2 + BETA = ZERO + IT = 1 +C +C Start generalized conjugate gradient iteration. +C + 50 CONTINUE +C + GAMMA = DDOT( L, DWORK( 1+KW4 ), 1, DWORK( 1+KW4 ), 1 ) + + $ DDOT( N, DWORK( 1+KW5 ), 1, DWORK( 1+KW5 ), 1 ) +C + EW = ZERO + DO 60 I = 1, L + EW = EW + DWORK( I+KW4 ) + 60 CONTINUE +C + EWC = ZERO + DO 70 I = 1, N + EWC = EWC + DWORK( I+KW5 ) + 70 CONTINUE +C + GAMMA = COEF*GAMMA - COEF2*( EW**2 + EWC**2 ) - + $ COEF5*( EW - EWC )**2 + IF( GAMMA.EQ.ZERO ) + $ GO TO 160 + IF( IT.NE.1 ) + $ BETA = GAMMA / PGAMMA + T = COEF5*( EWC - THREE*EW ) + TC = COEF5*( EW - THREE*EWC ) +C + CALL DSCAL( N+L, BETA, DWORK, 1 ) +C + CALL DAXPY( L, COEF, DWORK( 1+KW4 ), 1, DWORK( 1+KW1 ), 1 ) + CALL DAXPY( N, COEF, DWORK( 1+KW5 ), 1, DWORK, 1 ) +C + DO 80 J = 1, N + DWORK( J ) = DWORK( J ) + TC + 80 CONTINUE +C + DO 90 I = 1, L + DWORK( I+KW1 ) = DWORK( I+KW1 ) + T + 90 CONTINUE +C +C Apply matrix to vector. +C + DO 110 I = 1, L + KOUNT = 0 + SUM = ZERO + DO 100 J = 1, N + IF( CABS1( A( I, J ) ).GT.THRESH ) THEN + KOUNT = KOUNT + 1 + SUM = SUM + DWORK( J ) + END IF + IF( CABS1( E( I, J ) ).GT.THRESH ) THEN + KOUNT = KOUNT + 1 + SUM = SUM + DWORK( J ) + END IF + 100 CONTINUE + IF( WITHB ) THEN + J = IZAMAX( M, B( I, 1 ), LDB ) + IF( CABS1( B( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 + END IF + DWORK( I+KW2 ) = DBLE( KOUNT )*DWORK( I+KW1 ) + SUM + 110 CONTINUE +C + DO 130 J = 1, N + KOUNT = 0 + SUM = ZERO + DO 120 I = 1, L + IF( CABS1( A( I, J ) ).GT.THRESH ) THEN + KOUNT = KOUNT + 1 + SUM = SUM + DWORK( I+KW1 ) + END IF + IF( CABS1( E( I, J ) ).GT.THRESH ) THEN + KOUNT = KOUNT + 1 + SUM = SUM + DWORK( I+KW1 ) + END IF + 120 CONTINUE + IF( WITHC ) THEN + I = IZAMAX( P, C( 1, J ), 1 ) + IF( CABS1( C( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 + END IF + DWORK( J+KW3 ) = DBLE( KOUNT )*DWORK( J ) + SUM + 130 CONTINUE +C + SUM = DDOT( L, DWORK( 1+KW1 ), 1, DWORK( 1+KW2 ), 1 ) + + $ DDOT( N, DWORK, 1, DWORK( 1+KW3 ), 1 ) + ALPHA = GAMMA / SUM +C +C Determine correction to current iteration. +C + CMAX = ZERO + DO 140 I = 1, L + COR = ALPHA*DWORK( I+KW1 ) + IF( ABS( COR ).GT.CMAX ) + $ CMAX = ABS( COR ) + LSCALE( I ) = LSCALE( I ) + COR + 140 CONTINUE +C + DO 150 J = 1, N + COR = ALPHA*DWORK( J ) + IF( ABS( COR ).GT.CMAX ) + $ CMAX = ABS( COR ) + RSCALE( J ) = RSCALE( J ) + COR + 150 CONTINUE + IF( CMAX.LT.HALF ) + $ GO TO 160 +C + CALL DAXPY( L, -ALPHA, DWORK( 1+KW2 ), 1, DWORK( 1+KW4 ), 1 ) + CALL DAXPY( N, -ALPHA, DWORK( 1+KW3 ), 1, DWORK( 1+KW5 ), 1 ) +C + PGAMMA = GAMMA + IT = IT + 1 + IF( IT.LE.NRP2 ) + $ GO TO 50 +C +C End generalized conjugate gradient iteration. +C + 160 CONTINUE + SFMIN = DLAMCH( 'Safe minimum' ) + SFMAX = ONE / SFMIN + LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE ) + LSFMAX = INT( LOG10( SFMAX ) / BASL ) +C +C Compute left diagonal scaling matrix. +C + DO 170 I = 1, L + IRAB = IZAMAX( N, A( I, 1 ), LDA ) + RAB = ABS( A( I, IRAB ) ) + IRAB = IZAMAX( N, E( I, 1 ), LDE ) + RAB = MAX( RAB, ABS( E( I, IRAB ) ) ) + IF( WITHB ) THEN + IRAB = IZAMAX( M, B( I, 1 ), LDB ) + RAB = MAX( RAB, ABS( B( I, IRAB ) ) ) + END IF + LRAB = INT( LOG10( RAB+SFMIN ) / BASL + ONE ) + IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) + IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) + LSCALE( I ) = SCLFAC**IR + 170 CONTINUE +C +C Compute right diagonal scaling matrix. +C + DO 180 J = 1, N + ICAB = IZAMAX( L, A( 1, J ), 1 ) + CAB = ABS( A( ICAB, J ) ) + ICAB = IZAMAX( L, E( 1, J ), 1 ) + CAB = MAX( CAB, ABS( E( ICAB, J ) ) ) + IF( WITHC ) THEN + ICAB = IZAMAX( P, C( 1, J ), 1 ) + CAB = MAX( CAB, ABS( C( ICAB, J ) ) ) + END IF + LCAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE ) + JC = RSCALE( J ) + SIGN( HALF, RSCALE( J ) ) + JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) + RSCALE( J ) = SCLFAC**JC + 180 CONTINUE +C +C Row scaling of matrices A, E and B. +C + DO 190 I = 1, L + CALL ZDSCAL( N, LSCALE( I ), A( I, 1 ), LDA ) + CALL ZDSCAL( N, LSCALE( I ), E( I, 1 ), LDE ) + IF( WITHB ) + $ CALL ZDSCAL( M, LSCALE( I ), B( I, 1 ), LDB ) + 190 CONTINUE +C +C Column scaling of matrices A, E and C. +C + DO 200 J = 1, N + CALL ZDSCAL( L, RSCALE( J ), A( 1, J ), 1 ) + CALL ZDSCAL( L, RSCALE( J ), E( 1, J ), 1 ) + IF( WITHC ) + $ CALL ZDSCAL( P, RSCALE( J ), C( 1, J ), 1 ) + 200 CONTINUE +C + RETURN +C *** Last line of TG01AZ *** + END diff --git a/mex/sources/libslicot/TG01BD.f b/mex/sources/libslicot/TG01BD.f new file mode 100644 index 000000000..3a0681e5e --- /dev/null +++ b/mex/sources/libslicot/TG01BD.f @@ -0,0 +1,434 @@ + SUBROUTINE TG01BD( JOBE, COMPQ, COMPZ, N, M, P, ILO, IHI, A, LDA, + $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the matrices A and E of the system pencil +C +C S = ( A B ) - lambda ( E 0 ) , +C ( C 0 ) ( 0 0 ) +C +C corresponding to the descriptor triple (A-lambda E,B,C), +C to generalized upper Hessenberg form using orthogonal +C transformations, +C +C Q' * A * Z = H, Q' * E * Z = T, +C +C where H is upper Hessenberg, T is upper triangular, Q and Z +C are orthogonal, and ' means transpose. The corresponding +C transformations, written compactly as diag(Q',I) * S * diag(Z,I), +C are also applied to B and C, getting Q' * B and C * Z. +C +C The orthogonal matrices Q and Z are determined as products of +C Givens rotations. They may either be formed explicitly, or they +C may be postmultiplied into input matrices Q1 and Z1, so that +C +C Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' +C Q1 * E * Z1' = (Q1*Q) * T * (Z1*Z)'. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBE CHARACTER*1 +C Specifies whether E is a general square or an upper +C triangular matrix, as follows: +C = 'G': E is a general square matrix; +C = 'U': E is an upper triangular matrix. +C +C COMPQ CHARACTER*1 +C Indicates what should be done with matrix Q, as follows: +C = 'N': do not compute Q; +C = 'I': Q is initialized to the unit matrix, and the +C orthogonal matrix Q is returned; +C = 'V': Q must contain an orthogonal matrix Q1 on entry, +C and the product Q1*Q is returned. +C +C COMPZ CHARACTER*1 +C Indicates what should be done with matrix Z, as follows: +C = 'N': do not compute Z; +C = 'I': Z is initialized to the unit matrix, and the +C orthogonal matrix Z is returned; +C = 'V': Z must contain an orthogonal matrix Z1 on entry, +C and the product Z1*Z is returned. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, E, and the number of rows of +C the matrix B. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrix B. M >= 0. +C +C P (input) INTEGER +C The number of rows of the matrix C. P >= 0. +C +C ILO (input) INTEGER +C IHI (input) INTEGER +C It is assumed that A and E are already upper triangular in +C rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI could +C normally be set by a previous call to LAPACK Library +C routine DGGBAL; otherwise they should be set to 1 and N, +C respectively. +C 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +C If JOBE = 'U', the matrix E is assumed upper triangular. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading N-by-N part of this array contains +C the upper Hessenberg matrix H = Q' * A * Z. The elements +C below the first subdiagonal are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the descriptor matrix E. If JOBE = 'U', this +C matrix is assumed upper triangular. +C On exit, the leading N-by-N part of this array contains +C the upper triangular matrix T = Q' * E * Z. The elements +C below the diagonal are set to zero. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix B. +C On exit, if M > 0, the leading N-by-M part of this array +C contains the transformed matrix Q' * B. +C The array B is not referenced if M = 0. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,N) if M > 0; LDB >= 1 if M = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, if P > 0, the leading P-by-N part of this array +C contains the transformed matrix C * Z. +C The array C is not referenced if P = 0. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C If COMPQ = 'N': Q is not referenced; +C If COMPQ = 'I': on entry, Q need not be set, and on exit +C it contains the orthogonal matrix Q, +C where Q' is the product of the Givens +C transformations which are applied to A, +C E, and B on the left; +C If COMPQ = 'V': on entry, Q must contain an orthogonal +C matrix Q1, and on exit this is +C overwritten by Q1*Q. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= 1, if COMPQ = 'N'; +C LDQ >= MAX(1,N), if COMPQ = 'I' or 'V'. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C If COMPZ = 'N': Z is not referenced; +C If COMPZ = 'I': on entry, Z need not be set, and on exit +C it contains the orthogonal matrix Z, +C which is the product of the Givens +C transformations applied to A, E, and C +C on the right; +C If COMPZ = 'V': on entry, Z must contain an orthogonal +C matrix Z1, and on exit this is +C overwritten by Z1*Z. +C +C LDZ INTEGER +C The leading dimension of array Z. +C LDZ >= 1, if COMPZ = 'N'; +C LDZ >= MAX(1,N), if COMPZ = 'I' or 'V'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 1, if JOBE = 'U'; +C LDWORK >= MAX(1,IHI+1-ILO+MAX(NI,M)), if JOBE = 'G', where +C NI = N+1-ILO, if COMPQ = 'N', and NI = N, otherwise. +C For good performance, if JOBE = 'G', LDWORK must generally +C be larger, LDWORK >= MAX(1,IHI+1-ILO+MAX(NI,M)*NB), where +C NB is the optimal block size. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C First, this routine computes the QR factorization of E and applies +C the transformations to A, B, and possibly Q. Then, the routine +C reduces A to upper Hessenberg form, preserving E triangular, by +C an unblocked reduction [1], using two sequences of plane rotations +C applied alternately from the left and from the right. The +C corresponding transformations may be accumulated and/or applied +C to the matrices B and C. If JOBE = 'U', the initial reduction of E +C to upper triangular form is skipped. +C +C This routine is a modification and extension of the LAPACK Library +C routine DGGHRD [2]. +C +C REFERENCES +C +C [1] Golub, G.H. and van Loan, C.F. +C Matrix Computations. Third Edition. +C M. D. Johns Hopkins University Press, Baltimore, 1996. +C +C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C CONTRIBUTOR +C +C D. Sima, University of Bucharest, May 2001. +C V. Sima, Research Institute for Informatics, Bucharest, May 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalue, matrix algebra, matrix operations, similarity +C transformation. +C +C ********************************************************************* +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ, JOBE + INTEGER IHI, ILO, INFO, LDA, LDB, LDC, LDE, LDQ, + $ LDWORK, LDZ, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), + $ Z( LDZ, * ) +C .. Local Scalars .. + LOGICAL ILQ, ILZ, INQ, INZ, UPPER, WITHB, WITHC + INTEGER IERR, ITAU, IWRK, JCOL, JROW, MAXWRK, MINWRK + DOUBLE PRECISION CS, S, TEMP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEQRF, DLARTG, DLASET, DORMQR, DROT, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C +C .. Executable Statements .. +C +C Test the input scalar parameters. +C + UPPER = LSAME( JOBE, 'U' ) + INQ = LSAME( COMPQ, 'I' ) + ILQ = LSAME( COMPQ, 'V' ) .OR. INQ + INZ = LSAME( COMPZ, 'I' ) + ILZ = LSAME( COMPZ, 'V' ) .OR. INZ + WITHB = M.GT.0 + WITHC = P.GT.0 +C + INFO = 0 + IF( .NOT.( UPPER .OR. LSAME( JOBE, 'G' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ILQ .OR. LSAME( COMPQ, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( ILZ .OR. LSAME( COMPZ, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( ILO.LT.1 ) THEN + INFO = -7 + ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( ( WITHB .AND. LDB.LT.N ) .OR. LDB.LT.1 ) THEN + INFO = -14 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN + INFO = -18 + ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -20 + ELSE + JROW = IHI + 1 - ILO + JCOL = N + 1 - ILO + IF( UPPER ) THEN + MINWRK = 1 + MAXWRK = 1 + ELSE + IF( ILQ ) THEN + MINWRK = N + ELSE + MINWRK = JCOL + END IF + MINWRK = MAX( 1, JROW + MAX( MINWRK, M ) ) + END IF + IF( LDWORK.LT.MINWRK ) + $ INFO = -22 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01BD', -INFO ) + RETURN + END IF +C +C Initialize Q and Z if desired. +C + IF( INQ ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) + IF( INZ ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +C +C Quick return if possible. +C + IF( N.LE.1 ) THEN + DWORK( 1 ) = ONE + RETURN + END IF +C + IF( .NOT.UPPER ) THEN +C +C Reduce E to triangular form (QR decomposition of E). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C +C Workspace: need IHI+1-ILO+N+1-ILO; +C prefer IHI+1-ILO+(N+1-ILO)*NB. +C + ITAU = 1 + IWRK = ITAU + JROW + CALL DGEQRF( JROW, JCOL, E( ILO, ILO ), LDE, DWORK( ITAU ), + $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MINWRK ) +C +C Apply the orthogonal transformation to matrices A, B, and Q. +C Workspace: need IHI+1-ILO+N+1-ILO; +C prefer IHI+1-ILO+(N+1-ILO)*NB. +C + CALL DORMQR( 'Left', 'Transpose', JROW, JCOL, JROW, + $ E( ILO, ILO ), LDE, DWORK( ITAU ), A( ILO, ILO ), + $ LDA, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C + IF ( WITHB ) THEN +C +C Workspace: need IHI+1-ILO+M; +C prefer IHI+1-ILO+M*NB. +C + CALL DORMQR( 'Left', 'Transpose', JROW, M, JROW, + $ E( ILO, ILO ), LDE, DWORK( ITAU ), B( ILO, 1 ), + $ LDB, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + END IF +C + IF( ILQ ) THEN +C +C Workspace: need IHI+1-ILO+N; +C prefer IHI+1-ILO+N*NB. +C + CALL DORMQR( 'Right', 'No Transpose', N, JROW, JROW, + $ E( ILO, ILO ), LDE, DWORK( ITAU ), Q( 1, ILO ), + $ LDQ, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + END IF + END IF +C +C Zero out lower triangle of E. +C + IF( JROW.GT.1 ) + $ CALL DLASET( 'Lower', JROW-1, JROW-1, ZERO, ZERO, + $ E( ILO+1, ILO ), LDE ) +C +C Reduce A and E and apply the transformations to B, C, Q and Z. +C + DO 20 JCOL = ILO, IHI - 2 +C + DO 10 JROW = IHI, JCOL + 2, -1 +C +C Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL). +C + TEMP = A( JROW-1, JCOL ) + CALL DLARTG( TEMP, A( JROW, JCOL ), CS, S, + $ A( JROW-1, JCOL ) ) + A( JROW, JCOL ) = ZERO + CALL DROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA, + $ A( JROW, JCOL+1 ), LDA, CS, S ) + CALL DROT( N+2-JROW, E( JROW-1, JROW-1 ), LDE, + $ E( JROW, JROW-1 ), LDE, CS, S ) + IF( WITHB ) + $ CALL DROT( M, B( JROW-1, 1 ), LDB, B( JROW, 1 ), LDB, + $ CS, S ) + IF( ILQ ) + $ CALL DROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, CS, S ) +C +C Step 2: rotate columns JROW, JROW-1 to kill E(JROW,JROW-1). +C + TEMP = E( JROW, JROW ) + CALL DLARTG( TEMP, E( JROW, JROW-1 ), CS, S, + $ E( JROW, JROW ) ) + E( JROW, JROW-1 ) = ZERO + CALL DROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, CS, S ) + CALL DROT( JROW-1, E( 1, JROW ), 1, E( 1, JROW-1 ), 1, CS, + $ S ) + IF( WITHC ) + $ CALL DROT( P, C( 1, JROW ), 1, C( 1, JROW-1 ), 1, CS, S ) + IF( ILZ ) + $ CALL DROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, CS, S ) + 10 CONTINUE +C + 20 CONTINUE +C + DWORK( 1 ) = MAXWRK + RETURN +C *** Last line of TG01BD *** + END diff --git a/mex/sources/libslicot/TG01CD.f b/mex/sources/libslicot/TG01CD.f new file mode 100644 index 000000000..1ce07b1e4 --- /dev/null +++ b/mex/sources/libslicot/TG01CD.f @@ -0,0 +1,292 @@ + SUBROUTINE TG01CD( COMPQ, L, N, M, A, LDA, E, LDE, B, LDB, Q, LDQ, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the descriptor system pair (A-lambda E,B) to the +C QR-coordinate form by computing an orthogonal transformation +C matrix Q such that the transformed descriptor system pair +C (Q'*A-lambda Q'*E, Q'*B) has the descriptor matrix Q'*E +C in an upper trapezoidal form. +C The left orthogonal transformations performed to reduce E +C can be optionally accumulated. +C +C ARGUMENTS +C +C Mode Parameters +C +C COMPQ CHARACTER*1 +C = 'N': do not compute Q; +C = 'I': Q is initialized to the unit matrix, and the +C orthogonal matrix Q is returned; +C = 'U': Q must contain an orthogonal matrix Q1 on entry, +C and the product Q1*Q is returned. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A, B, and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A and E. N >= 0. +C +C M (input) INTEGER +C The number of columns of matrix B. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix Q'*A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix Q'*E in upper trapezoidal form, +C i.e. +C +C ( E11 ) +C Q'*E = ( ) , if L >= N , +C ( 0 ) +C or +C +C Q'*E = ( E11 E12 ), if L < N , +C +C where E11 is an MIN(L,N)-by-MIN(L,N) upper triangular +C matrix. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the input/state matrix B. +C On exit, the leading L-by-M part of this array contains +C the transformed matrix Q'*B. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,L) +C If COMPQ = 'N': Q is not referenced. +C If COMPQ = 'I': on entry, Q need not be set; +C on exit, the leading L-by-L part of this +C array contains the orthogonal matrix Q, +C where Q' is the product of Householder +C transformations which are applied to A, +C E, and B on the left. +C If COMPQ = 'U': on entry, the leading L-by-L part of this +C array must contain an orthogonal matrix +C Q1; +C on exit, the leading L-by-L part of this +C array contains the orthogonal matrix +C Q1*Q. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= 1, if COMPQ = 'N'; +C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, MIN(L,N) + MAX(L,N,M)). +C For optimum performance +C LWORK >= MAX(1, MIN(L,N) + MAX(L,N,M)*NB), +C where NB is the optimal blocksize. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes the QR factorization of E to reduce it +C to the upper trapezoidal form. +C +C The transformations are also applied to the rest of system +C matrices +C +C A <- Q' * A , B <- Q' * B. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( L*L*N ) floating point operations. +C +C CONTRIBUTOR +C +C C. Oara, University "Politehnica" Bucharest. +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. Based on the RASP routine RPDSQR. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 1999, +C May 2003. +C +C KEYWORDS +C +C Descriptor system, matrix algebra, matrix operations, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER COMPQ + INTEGER INFO, L, LDA, LDB, LDE, LDQ, LDWORK, M, N +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), + $ E( LDE, * ), Q( LDQ, * ) +C .. Local Scalars .. + LOGICAL ILQ + INTEGER ICOMPQ, LN, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEQRF, DLASET, DORMQR, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode COMPQ. +C + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'U' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +C +C Test the input parameters. +C + INFO = 0 + WRKOPT = MAX( 1, MIN( L, N ) + MAX( L, N, M ) ) + IF( ICOMPQ.EQ.0 ) THEN + INFO = -1 + ELSE IF( L.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -6 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN + INFO = -10 + ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN + INFO = -12 + ELSE IF( LDWORK.LT.WRKOPT ) THEN + INFO = -14 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01CD', -INFO ) + RETURN + END IF +C +C Initialize Q if necessary. +C + IF( ICOMPQ.EQ.3 ) + $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) +C +C Quick return if possible. +C + IF( L.EQ.0 .OR. N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + LN = MIN( L, N ) +C +C Compute the QR decomposition of E. +C +C Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL DGEQRF( L, N, E, LDE, DWORK, DWORK( LN+1 ), LDWORK-LN, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) +C +C Apply transformation on the rest of matrices. +C +C A <-- Q' * A. +C Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL DORMQR( 'Left', 'Transpose', L, N, LN, E, LDE, DWORK, + $ A, LDA, DWORK( LN+1 ), LDWORK-LN, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) +C +C B <-- Q' * B. +C Workspace: need MIN(L,N) + M; +C prefer MIN(L,N) + M*NB. +C + IF ( M.GT.0 ) THEN + CALL DORMQR( 'Left', 'Transpose', L, M, LN, E, LDE, DWORK, + $ B, LDB, DWORK( LN+1 ), LDWORK-LN, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) + END IF +C +C Q <-- Q1 * Q. +C Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + IF( ILQ ) THEN + CALL DORMQR( 'Right', 'No Transpose', L, L, LN, E, LDE, DWORK, + $ Q, LDQ, DWORK( LN+1 ), LDWORK-LN, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) + END IF +C +C Set lower triangle of E to zero. +C + IF( L.GE.2 ) + $ CALL DLASET( 'Lower', L-1, LN, ZERO, ZERO, E( 2, 1 ), LDE ) +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of TG01CD *** + END diff --git a/mex/sources/libslicot/TG01DD.f b/mex/sources/libslicot/TG01DD.f new file mode 100644 index 000000000..cac8704d8 --- /dev/null +++ b/mex/sources/libslicot/TG01DD.f @@ -0,0 +1,295 @@ + SUBROUTINE TG01DD( COMPZ, L, N, P, A, LDA, E, LDE, C, LDC, Z, LDZ, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the descriptor system pair (C,A-lambda E) to the +C RQ-coordinate form by computing an orthogonal transformation +C matrix Z such that the transformed descriptor system pair +C (C*Z,A*Z-lambda E*Z) has the descriptor matrix E*Z in an upper +C trapezoidal form. +C The right orthogonal transformations performed to reduce E can +C be optionally accumulated. +C +C ARGUMENTS +C +C Mode Parameters +C +C COMPZ CHARACTER*1 +C = 'N': do not compute Z; +C = 'I': Z is initialized to the unit matrix, and the +C orthogonal matrix Z is returned; +C = 'U': Z must contain an orthogonal matrix Z1 on entry, +C and the product Z1*Z is returned. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A, E, and C. N >= 0. +C +C P (input) INTEGER +C The number of rows of matrix C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix A*Z. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix E*Z in upper trapezoidal form, +C i.e. +C +C ( E11 ) +C E*Z = ( ) , if L >= N , +C ( R ) +C or +C +C E*Z = ( 0 R ), if L < N , +C +C where R is an MIN(L,N)-by-MIN(L,N) upper triangular +C matrix. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed matrix C*Z. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C If COMPZ = 'N': Z is not referenced. +C If COMPZ = 'I': on entry, Z need not be set; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix Z, +C which is the product of Householder +C transformations applied to A, E, and C +C on the right. +C If COMPZ = 'U': on entry, the leading N-by-N part of this +C array must contain an orthogonal matrix +C Z1; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix +C Z1*Z. +C +C LDZ INTEGER +C The leading dimension of array Z. +C LDZ >= 1, if COMPZ = 'N'; +C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, MIN(L,N) + MAX(L,N,P)). +C For optimum performance +C LWORK >= MAX(1, MIN(L,N) + MAX(L,N,P)*NB), +C where NB is the optimal blocksize. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes the RQ factorization of E to reduce it +C the upper trapezoidal form. +C +C The transformations are also applied to the rest of system +C matrices +C +C A <- A * Z, C <- C * Z. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( L*N*N ) floating point operations. +C +C CONTRIBUTOR +C +C C. Oara, University "Politehnica" Bucharest. +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. Based on the RASP routine RPDSRQ. +C +C REVISIONS +C +C July 1999, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C Descriptor system, matrix algebra, matrix operations, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER COMPZ + INTEGER INFO, L, LDA, LDC, LDE, LDWORK, LDZ, N, P +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), + $ E( LDE, * ), Z( LDZ, * ) +C .. Local Scalars .. + LOGICAL ILZ + INTEGER ICOMPZ, LN, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGERQF, DLASET, DORMRQ, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode COMPZ. +C + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'U' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF +C +C Test the input parameters. +C + INFO = 0 + WRKOPT = MAX( 1, MIN( L, N ) + MAX( L, N, P ) ) + IF( ICOMPZ.EQ.0 ) THEN + INFO = -1 + ELSE IF( L.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -6 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -12 + ELSE IF( LDWORK.LT.WRKOPT ) THEN + INFO = -14 + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'TG01DD', -INFO ) + RETURN + END IF +C +C Initialize Q if necessary. +C + IF( ICOMPZ.EQ.3 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +C +C Quick return if possible. +C + IF( L.EQ.0 .OR. N.EQ.0 ) THEN + DWORK( 1 ) = ONE + RETURN + END IF +C + LN = MIN( L, N ) +C +C Compute the RQ decomposition of E, E = R*Z. +C +C Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + CALL DGERQF( L, N, E, LDE, DWORK, DWORK( LN+1 ), LDWORK-LN, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) +C +C Apply transformation on the rest of matrices. +C +C A <-- A * Z'. +C Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + CALL DORMRQ( 'Right', 'Transpose', L, N, LN, E( L-LN+1,1 ), LDE, + $ DWORK, A, LDA, DWORK( LN+1 ), LDWORK-LN, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) +C +C C <-- C * Z'. +C Workspace: need MIN(L,N) + P; +C prefer MIN(L,N) + P*NB. +C + CALL DORMRQ( 'Right', 'Transpose', P, N, LN, E( L-LN+1,1 ), LDE, + $ DWORK, C, LDC, DWORK( LN+1 ), LDWORK-LN, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) +C +C Z <-- Z1 * Z'. +C Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + IF( ILZ ) THEN + CALL DORMRQ( 'Right', 'Transpose', N, N, LN, E( L-LN+1,1 ), + $ LDE, DWORK, Z, LDZ, DWORK( LN+1 ), LDWORK-LN, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) + END IF +C +C Set lower triangle of E to zero. +C + IF( L.LT.N ) THEN + CALL DLASET( 'Full', L, N-L, ZERO, ZERO, E, LDE ) + IF( L.GE.2 ) CALL DLASET( 'Lower', L-1, L, ZERO, ZERO, + $ E( 2, N-L+1 ), LDE ) + ELSE + IF( N.GE.2 ) CALL DLASET( 'Lower', N-1, N, ZERO, ZERO, + $ E( L-N+2, 1 ), LDE ) + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of TG01DD *** + END diff --git a/mex/sources/libslicot/TG01ED.f b/mex/sources/libslicot/TG01ED.f new file mode 100644 index 000000000..1fe8e8bba --- /dev/null +++ b/mex/sources/libslicot/TG01ED.f @@ -0,0 +1,793 @@ + SUBROUTINE TG01ED( JOBA, L, N, M, P, A, LDA, E, LDE, B, LDB, + $ C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, TOL, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute for the descriptor system (A-lambda E,B,C) +C the orthogonal transformation matrices Q and Z such that the +C transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is in an +C SVD (singular value decomposition) coordinate form with +C the system matrices Q'*A*Z and Q'*E*Z in the form +C +C ( A11 A12 ) ( Er 0 ) +C Q'*A*Z = ( ) , Q'*E*Z = ( ) , +C ( A21 A22 ) ( 0 0 ) +C +C where Er is an invertible diagonal matrix having on the diagonal +C the decreasingly ordered nonzero singular values of E. +C Optionally, the A22 matrix can be further reduced to the +C SVD form +C +C ( Ar 0 ) +C A22 = ( ) , +C ( 0 0 ) +C +C where Ar is an invertible diagonal matrix having on the diagonal +C the decreasingly ordered nonzero singular values of A22. +C The left and/or right orthogonal transformations performed +C to reduce E and A22 are accumulated. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBA CHARACTER*1 +C = 'N': do not reduce A22; +C = 'R': reduce A22 to an SVD form. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A, B, and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A, E, and C. N >= 0. +C +C M (input) INTEGER +C The number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The number of rows of matrix C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix Q'*A*Z. If JOBA = 'R', this matrix +C is in the form +C +C ( A11 * * ) +C Q'*A*Z = ( * Ar 0 ) , +C ( * 0 0 ) +C +C where A11 is a RANKE-by-RANKE matrix and Ar is a +C RNKA22-by-RNKA22 invertible diagonal matrix, with +C decresingly ordered positive diagonal elements. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix Q'*E*Z. +C +C ( Er 0 ) +C Q'*E*Z = ( ) , +C ( 0 0 ) +C +C where Er is a RANKE-by-RANKE invertible diagonal matrix +C having on the diagonal the decreasingly ordered positive +C singular values of E. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the input/state matrix B. +C On exit, the leading L-by-M part of this array contains +C the transformed matrix Q'*B. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed matrix C*Z. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C Q (output) DOUBLE PRECISION array, dimension (LDQ,L) +C The leading L-by-L part of this array contains the +C orthogonal matrix Q, which is the accumulated product of +C transformations applied to A, E, and B on the left. +C +C LDQ INTEGER +C The leading dimension of array Q. LDQ >= MAX(1,L). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C The leading N-by-N part of this array contains the +C orthogonal matrix Z, which is the accumulated product of +C transformations applied to A, E, and C on the right. +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= MAX(1,N). +C +C RANKE (output) INTEGER +C The effective rank of matrix E, and thus also the order +C of the invertible diagonal submatrix Er. +C RANKE is computed as the number of singular values of E +C greater than TOL*SVEMAX, where SVEMAX is the maximum +C singular value of E. +C +C RNKA22 (output) INTEGER +C If JOBA = 'R', then RNKA22 is the effective rank of +C matrix A22, and thus also the order of the invertible +C diagonal submatrix Ar. RNKA22 is computed as the number +C of singular values of A22 greater than TOL*SVAMAX, +C where SVAMAX is an estimate of the maximum singular value +C of A. +C If JOBA = 'N', then RNKA22 is not referenced. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the rank of E +C and of A22. If TOL > 0, then singular values less than +C TOL*SVMAX are treated as zero, where SVMAX is the maximum +C singular value of E or an estimate of it for A and E. +C If TOL <= 0, the default tolerance TOLDEF = EPS*L*N is +C used instead, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH). TOL < 1. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,MIN(L,N) + +C MAX(3*MIN(L,N)+MAX(L,N), 5*MIN(L,N), M, P)). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: the QR algorithm has failed to converge when computing +C singular value decomposition. In this case INFO +C specifies how many superdiagonals did not converge. +C This failure is not likely to occur. +C +C METHOD +C +C The routine computes the singular value decomposition (SVD) of E, +C in the form +C +C ( Er 0 ) +C E = Q * ( ) * Z' +C ( 0 0 ) +C +C and finds the largest RANKE-by-RANKE leading diagonal submatrix +C Er whose condition number is less than 1/TOL. RANKE defines thus +C the effective rank of matrix E. +C If JOBA = 'R' the same reduction is performed on A22 in the +C partitioned matrix +C +C ( A11 A12 ) +C Q'*A*Z = ( ) , +C ( A21 A22 ) +C +C to obtain it in the form +C +C ( Ar 0 ) +C A22 = ( ) , +C ( 0 0 ) +C +C with Ar an invertible diagonal matrix. +C +C The accumulated transformations are also applied to the rest of +C matrices +C +C B <- Q' * B, C <- C * Z. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( L*L*N ) floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. Based on the RASP routine RPDSSV. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 1999, +C Feb. 2000, Oct. 2001, May 2003. +C +C KEYWORDS +C +C Descriptor system, matrix algebra, matrix operations, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBA + INTEGER INFO, L, LDA, LDB, LDC, LDE, LDQ, LDWORK, + $ LDZ, M, N, P, RNKA22, RANKE + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), + $ Z( LDZ, * ) +C .. Local Scalars .. + LOGICAL REDA + INTEGER I, IR1, J, KW, LA22, LN, LN2, LWR, NA22, WRKOPT + DOUBLE PRECISION EPSM, SVEMAX, SVLMAX, TOLDEF +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DGEQRF, DGELQF, DGESVD, + $ DLACPY, DLASET, DORMQR, DORMLQ, DSWAP, MA02AD, + $ MB03UD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C +C .. Executable Statements .. +C + REDA = LSAME( JOBA, 'R' ) +C +C Test the input parameters. +C + INFO = 0 + WRKOPT = MIN( L, N ) + + $ MAX( M, P, 3*MIN( L, N ) + MAX( L, N ), 5*MIN( L, N ) ) + IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA ) THEN + INFO = -1 + ELSE IF( L.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -7 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDQ.LT.MAX( 1, L ) ) THEN + INFO = -15 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -20 + ELSE IF( LDWORK.LT.MAX( 1, WRKOPT ) ) THEN + INFO = -22 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01ED', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( L.EQ.0 .OR. N.EQ.0 ) THEN + IF( L.GT.0 ) + $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) + IF( N.GT.0 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) + DWORK(1) = ONE + RANKE = 0 + IF( REDA ) RNKA22 = 0 + RETURN + END IF +C + LN = MIN( L, N ) + EPSM = DLAMCH( 'EPSILON' ) +C + TOLDEF = TOL + IF( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance for rank determination. +C + TOLDEF = EPSM * DBLE( L*N ) + END IF +C +C Set the estimate of the maximum singular value of E to +C max(||E||,||A||) to detect negligible A or E matrices. +C + SVLMAX = MAX( DLANGE( 'F', L, N, E, LDE, DWORK ) , + $ DLANGE( 'F', L, N, A, LDA, DWORK ) ) +C +C Compute the SVD of E +C +C ( Er 0 ) +C E = Qr * ( ) * Zr' +C ( 0 0 ) +C +C Workspace: needed MIN(L,N) + MAX(3*MIN(L,N)+MAX(L,N),5*MIN(L,N)); +C prefer larger. +C + LWR = LDWORK - LN + KW = LN + 1 +C + CALL DGESVD( 'A', 'A', L, N, E, LDE, DWORK, Q, LDQ, Z, LDZ, + $ DWORK(KW), LWR, INFO ) + IF( INFO.GT.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C Determine the rank of E. +C + RANKE = 0 + IF( DWORK(1).GT.SVLMAX*EPSM ) THEN + RANKE = 1 + SVEMAX = DWORK(1) + DO 10 I = 2, LN + IF( DWORK(I).LT.SVEMAX*TOLDEF ) GO TO 20 + RANKE = RANKE + 1 + 10 CONTINUE +C + 20 CONTINUE + END IF +C +C Apply transformation on the rest of matrices. +C + IF( RANKE.GT.0 ) THEN +C +C A <-- Qr' * A * Zr. +C + CALL DGEMM( 'Transpose', 'No transpose', L, N, L, ONE, + $ Q, LDQ, A, LDA, ZERO, E, LDE ) + CALL DGEMM( 'No transpose', 'Transpose', L, N, N, ONE, + $ E, LDE, Z, LDZ, ZERO, A, LDA ) +C +C B <-- Qr' * B. +C Workspace: need L; +C prefer L*M. +C + IF( LWR.GT.L*M .AND. M.GT.0 ) THEN +C + CALL DGEMM( 'Transpose', 'No transpose', L, M, L, ONE, + $ Q, LDQ, B, LDB, ZERO, DWORK(KW), L ) + CALL DLACPY( 'Full', L, M, DWORK(KW), L, B, LDB ) + ELSE + DO 30 J = 1, M + CALL DGEMV( 'Transpose', L, L, ONE, Q, LDQ, B(1,J), 1, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( L, DWORK(KW), 1, B(1,J), 1 ) + 30 CONTINUE + END IF +C +C C <-- C * Zr. +C Workspace: need N; +C prefer P*N. +C + IF( LWR.GT.P*N ) THEN +C + CALL DGEMM( 'No transpose', 'Transpose', P, N, N, ONE, + $ C, LDC, Z, LDZ, ZERO, DWORK(KW), MAX( 1, P ) ) + CALL DLACPY( 'Full', P, N, DWORK(KW), MAX( 1, P ), C, LDC ) + ELSE + DO 40 I = 1, P + CALL DGEMV( 'No transpose', N, N, ONE, Z, LDZ, + $ C(I,1), LDC, ZERO, DWORK(KW), 1 ) + CALL DCOPY( N, DWORK(KW), 1, C(I,1), LDC ) + 40 CONTINUE + END IF + WRKOPT = MAX( WRKOPT, L*M, P*N ) + END IF +C +C Reduce A22 if necessary. +C + IF( REDA ) THEN + LA22 = L - RANKE + NA22 = N - RANKE + LN2 = MIN( LA22, NA22 ) + IF( LN2.EQ.0 ) THEN + IR1 = 1 + RNKA22 = 0 + ELSE +C +C Compute the SVD of A22 using a storage saving approach. +C + IR1 = RANKE + 1 + IF( LA22.GE.NA22 ) THEN +C +C Compute the QR decomposition of A22 in the form +C +C A22 = Q2 * ( R2 ) , +C ( 0 ) +C +C where R2 is upper triangular. +C Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL DGEQRF( LA22, NA22, A(IR1,IR1), LDA, DWORK(IR1), + $ DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C Apply transformation Q2 to A, B, and Q. +C +C A <--diag(I, Q2') * A +C Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL DORMQR( 'Left', 'Transpose', LA22, RANKE, LN2, + $ A(IR1,IR1), LDA, DWORK(IR1), A(IR1,1), LDA, + $ DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C B <-- diag(I, Q2') * B +C Workspace: need MIN(L,N) + M; +C prefer MIN(L,N) + M*NB. +C + IF ( M.GT.0 ) THEN + CALL DORMQR( 'Left', 'Transpose', LA22, M, LN2, + $ A(IR1,IR1), LDA, DWORK(IR1), B(IR1,1), + $ LDB, DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) + END IF +C +C Q <-- Q * diag(I, Q2) +C Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + CALL DORMQR( 'Right', 'No transpose', L, LA22, LN2, + $ A(IR1,IR1), LDA, DWORK(IR1), Q(1,IR1), LDQ, + $ DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C Compute the SVD of the upper triangular submatrix R2 as +C +C ( Ar 0 ) +C R2 = Q2r * ( ) * Z2r' , +C ( 0 0 ) +C +C where Q2r is stored in E and Z2r' is stored in A22. +C Workspace: need MAX(1,5*MIN(L,N)); +C prefer larger. +C + CALL MB03UD( 'Vectors', 'Vectors', LN2, A(IR1,IR1), LDA, + $ E(IR1,IR1), LDE, DWORK(IR1), DWORK(KW), LWR, + $ INFO ) + IF( INFO.GT.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C Determine the rank of A22. +C + RNKA22 = 0 + IF( DWORK(IR1).GT.SVLMAX*EPSM ) THEN + RNKA22 = 1 + DO 50 I = IR1+1, LN + IF( DWORK(I).LE.SVLMAX*TOLDEF ) GO TO 60 + RNKA22 = RNKA22 + 1 + 50 CONTINUE +C + 60 CONTINUE + END IF +C +C Apply transformation on the rest of matrices. +C + IF( RNKA22.GT.0 ) THEN +C +C A <-- diag(I,Q2r') * A * diag(I,Zr2) +C + CALL DGEMM( 'Transpose', 'No transpose', LN2, RANKE, + $ LN2, ONE, E(IR1,IR1), LDE, A(IR1,1), LDA, + $ ZERO, E(IR1,1), LDE ) + CALL DLACPY( 'Full', LN2, RANKE, E(IR1,1), LDE, + $ A(IR1,1), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', RANKE, LN2, + $ LN2, ONE, A(1,IR1), LDA, A(IR1,IR1), LDA, + $ ZERO, E(1,IR1), LDE ) + CALL DLACPY( 'Full', RANKE, LN2, E(1,IR1), LDE, + $ A(1,IR1), LDA ) +C +C B <-- diag(I,Q2r') * B +C + IF( LWR.GT.LN2*M .AND. M.GT.0 ) THEN +C + CALL DGEMM( 'Transpose', 'No transpose', LN2, M, + $ LN2, ONE, E(IR1,IR1), LDE, B(IR1,1), + $ LDB, ZERO, DWORK(KW), LN2 ) + CALL DLACPY( 'Full', LN2, M, DWORK(KW), LN2, + $ B(IR1,1), LDB ) + ELSE + DO 70 J = 1, M + CALL DGEMV( 'Transpose', LN2, LN2, ONE, + $ E(IR1,IR1), LDE, B( IR1,J), 1, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( LN2, DWORK(KW), 1, B(IR1,J), 1 ) + 70 CONTINUE + END IF +C +C C <-- C * diag(I,Zr2) +C + IF( LWR.GT.P*LN2 .AND. P.GT.0 ) THEN +C + CALL DGEMM( 'No transpose', 'Transpose', P, LN2, + $ LN2, ONE, C(1,IR1), LDC, A(IR1,IR1), + $ LDA, ZERO, DWORK(KW), P ) + CALL DLACPY( 'Full', P, LN2, DWORK( KW ), P, + $ C(1,IR1), LDC ) + ELSE + DO 80 I = 1, P + CALL DGEMV( 'No transpose', LN2, LN2, ONE, + $ A(IR1,IR1), LDA, C(I,IR1), LDC, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( LN2, DWORK(KW), 1, C(I,IR1), LDC ) + 80 CONTINUE + END IF +C +C Q <-- Q * diag(I, Qr2) +C + IF( LWR.GT.L*LN2 ) THEN +C + CALL DGEMM( 'No transpose', 'No transpose', L, LN2, + $ LN2, ONE, Q(1,IR1), LDQ, E(IR1,IR1), + $ LDE, ZERO, DWORK(KW), L ) + CALL DLACPY( 'Full', L, LN2, DWORK(KW), L, + $ Q(1,IR1), LDQ ) + ELSE + DO 90 I = 1, L + CALL DGEMV( 'Transpose', LN2, LN2, ONE, + $ E(IR1,IR1), LDE, Q(I,IR1), LDQ, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( LN2, DWORK(KW), 1, Q(I,IR1), LDQ ) + 90 CONTINUE + END IF +C +C Z' <-- diag(I, Zr2') * Z' +C + IF( LWR.GT.N*LN2 ) THEN +C + CALL DGEMM( 'No transpose', 'No transpose', LN2, N, + $ LN2, ONE, A(IR1,IR1), LDA, Z(IR1,1), + $ LDZ, ZERO, DWORK(KW), LN2 ) + CALL DLACPY( 'Full', LN2, N, DWORK(KW), LN2, + $ Z(IR1,1), LDZ ) + ELSE + DO 100 J = 1, N + CALL DGEMV( 'No transpose', LN2, LN2, ONE, + $ A(IR1,IR1), LDA, Z(IR1,J), 1, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( LN2, DWORK(KW), 1, Z(IR1,J), 1 ) + 100 CONTINUE + END IF + END IF + ELSE +C +C Compute the LQ decomposition of A22 in the form +C +C A22 = ( L2 0 )* Z2 +C +C where L2 is lower triangular. +C Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + CALL DGELQF( LA22, NA22, A(IR1,IR1), LDA, DWORK(IR1), + $ DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C Apply transformation Z2 to A, C, and Z. +C +C A <-- A * diag(I, Z2') +C Workspace: need 2*MIN(L,N); +C prefer MIN(L,N) + MIN(L,N)*NB. +C + CALL DORMLQ( 'Right', 'Transpose', RANKE, NA22, LN2, + $ A(IR1,IR1), LDA, DWORK(IR1), A(1,IR1), LDA, + $ DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C C <-- C * diag(I, Z2') +C Workspace: need MIN(L,N) + P; +C prefer MIN(L,N) + P*NB. +C + IF ( P.GT.0 ) THEN + CALL DORMLQ( 'Right', 'Transpose', P, NA22, LN2, + $ A(IR1,IR1), LDA, DWORK(IR1), C(1,IR1), + $ LDC, DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) + END IF +C +C Z' <- diag(I, Z2) * Z' +C Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL DORMLQ( 'Left', 'No transpose', NA22, N, LN2, + $ A(IR1,IR1), LDA, DWORK(IR1), Z(IR1,1), LDZ, + $ DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C Compute the SVD of the lower triangular submatrix L2 as +C +C ( Ar 0 ) +C L2' = Z2r * ( ) * Q2r' +C ( 0 0 ) +C +C where Q2r' is stored in E and Z2r is stored in A22. +C Workspace: need MAX(1,5*MIN(L,N)); +C prefer larger. +C + CALL MA02AD( 'Lower', LN2, LN2, A(IR1,IR1), LDA, + $ E(IR1,IR1), LDE ) + CALL MB03UD( 'Vectors', 'Vectors', LN2, E(IR1,IR1), LDE, + $ A(IR1,IR1), LDA, DWORK(IR1), DWORK(KW), + $ LWR, INFO ) + IF( INFO.GT.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C Determine the rank of A22. +C + RNKA22 = 0 + IF( DWORK(IR1).GT.SVLMAX*EPSM ) THEN + RNKA22 = 1 + DO 110 I = IR1+1, LN + IF( DWORK(I).LE.SVLMAX*TOLDEF ) GO TO 120 + RNKA22 = RNKA22 + 1 + 110 CONTINUE +C + 120 CONTINUE + END IF +C +C Apply transformation on the rest of matrices. +C + IF( RNKA22.GT.0 ) THEN +C +C A <-- diag(I,Q2r') * A * diag(I,Zr2) +C + CALL DGEMM( 'No transpose', 'No transpose', LN2, + $ RANKE, LN2, ONE, E(IR1,IR1), LDE, + $ A(IR1,1), LDA, ZERO, E(IR1,1), LDE ) + CALL DLACPY( 'Full', LN2, RANKE, E(IR1,1), LDE, + $ A(IR1,1), LDA ) + CALL DGEMM( 'No transpose', 'No transpose', RANKE, + $ LN2, LN2, ONE, A(1,IR1), LDA, + $ A(IR1,IR1), LDA, ZERO, E(1,IR1), LDE ) + CALL DLACPY( 'Full', RANKE, LN2, E(1,IR1), LDE, + $ A(1,IR1), LDA ) +C +C B <-- diag(I,Q2r') * B +C + IF( LWR.GT.LN2*M .AND. M.GT.0 ) THEN +C + CALL DGEMM( 'No transpose', 'No transpose', LN2, M, + $ LN2, ONE, E(IR1,IR1), LDE, B(IR1,1), + $ LDB, ZERO, DWORK(KW), LN2 ) + CALL DLACPY( 'Full', LN2, M, DWORK(KW), LN2, + $ B(IR1,1), LDB ) + ELSE + DO 130 J = 1, M + CALL DGEMV( 'No transpose', LN2, LN2, ONE, + $ E(IR1,IR1), LDE, B( IR1,J), 1, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( LN2, DWORK(KW), 1, B(IR1,J), 1 ) + 130 CONTINUE + END IF +C +C C <-- C * diag(I,Zr2) +C + IF( LWR.GT.P*LN2 .AND. P.GT.0 ) THEN +C + CALL DGEMM( 'No transpose', 'No transpose', P, LN2, + $ LN2, ONE, C(1,IR1), LDC, A(IR1,IR1), + $ LDA, ZERO, DWORK(KW), P ) + CALL DLACPY( 'Full', P, LN2, DWORK( KW ), P, + $ C(1,IR1), LDC ) + ELSE + DO 140 I = 1, P + CALL DGEMV( 'Transpose', LN2, LN2, ONE, + $ A(IR1,IR1), LDA, C(I,IR1), LDC, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( LN2, DWORK(KW), 1, C(I,IR1), LDC ) + 140 CONTINUE + END IF +C +C Q <-- Q * diag(I, Qr2) +C + IF( LWR.GT.L*LN2 ) THEN +C + CALL DGEMM( 'No transpose', 'Transpose', L, LN2, + $ LN2, ONE, Q(1,IR1), LDQ, E(IR1,IR1), + $ LDE, ZERO, DWORK(KW), L ) + CALL DLACPY( 'Full', L, LN2, DWORK(KW), L, + $ Q(1,IR1), LDQ ) + ELSE + DO 150 I = 1, L + CALL DGEMV( 'No transpose', LN2, LN2, ONE, + $ E(IR1,IR1), LDE, Q(I,IR1), LDQ, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( LN2, DWORK(KW), 1, Q(I,IR1), LDQ ) + 150 CONTINUE + END IF +C +C Z' <-- diag(I, Zr2') * Z' +C + IF( LWR.GT.N*LN2 ) THEN +C + CALL DGEMM( 'Transpose', 'No transpose', LN2, N, + $ LN2, ONE, A(IR1,IR1), LDA, Z(IR1,1), + $ LDZ, ZERO, DWORK(KW), LN2 ) + CALL DLACPY( 'Full', LN2, N, DWORK(KW), LN2, + $ Z(IR1,1), LDZ ) + ELSE + DO 160 J = 1, N + CALL DGEMV( 'Transpose', LN2, LN2, ONE, + $ A(IR1,IR1), LDA, Z(IR1,J), 1, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( LN2, DWORK(KW), 1, Z(IR1,J), 1 ) + 160 CONTINUE + END IF + END IF + END IF + END IF + END IF +C +C Set E. +C + CALL DLASET( 'Full', L, N, ZERO, ZERO, E, LDE ) + CALL DCOPY( RANKE, DWORK, 1, E, LDE+1 ) +C + IF( REDA ) THEN +C +C Set A22. +C + CALL DLASET( 'Full', LA22, NA22, ZERO, ZERO, A(IR1,IR1), LDA ) + CALL DCOPY( RNKA22, DWORK(IR1), 1, A(IR1,IR1), LDA+1 ) + END IF +C +C Transpose Z. +C + DO 170 I = 2, N + CALL DSWAP( I-1, Z(1,I), 1, Z(I,1), LDZ ) + 170 CONTINUE +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of TG01ED *** + END diff --git a/mex/sources/libslicot/TG01FD.f b/mex/sources/libslicot/TG01FD.f new file mode 100644 index 000000000..c50d5fc95 --- /dev/null +++ b/mex/sources/libslicot/TG01FD.f @@ -0,0 +1,725 @@ + SUBROUTINE TG01FD( COMPQ, COMPZ, JOBA, L, N, M, P, A, LDA, E, LDE, + $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, + $ TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute for the descriptor system (A-lambda E,B,C) +C the orthogonal transformation matrices Q and Z such that the +C transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is +C in a SVD-like coordinate form with +C +C ( A11 A12 ) ( Er 0 ) +C Q'*A*Z = ( ) , Q'*E*Z = ( ) , +C ( A21 A22 ) ( 0 0 ) +C +C where Er is an upper triangular invertible matrix. +C Optionally, the A22 matrix can be further reduced to the form +C +C ( Ar X ) +C A22 = ( ) , +C ( 0 0 ) +C +C with Ar an upper triangular invertible matrix, and X either a full +C or a zero matrix. +C The left and/or right orthogonal transformations performed +C to reduce E and A22 can be optionally accumulated. +C +C ARGUMENTS +C +C Mode Parameters +C +C COMPQ CHARACTER*1 +C = 'N': do not compute Q; +C = 'I': Q is initialized to the unit matrix, and the +C orthogonal matrix Q is returned; +C = 'U': Q must contain an orthogonal matrix Q1 on entry, +C and the product Q1*Q is returned. +C +C COMPZ CHARACTER*1 +C = 'N': do not compute Z; +C = 'I': Z is initialized to the unit matrix, and the +C orthogonal matrix Z is returned; +C = 'U': Z must contain an orthogonal matrix Z1 on entry, +C and the product Z1*Z is returned. +C +C JOBA CHARACTER*1 +C = 'N': do not reduce A22; +C = 'R': reduce A22 to a SVD-like upper triangular form. +C = 'T': reduce A22 to an upper trapezoidal form. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A, B, and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A, E, and C. N >= 0. +C +C M (input) INTEGER +C The number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The number of rows of matrix C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix +C is in the form +C +C ( A11 * * ) +C Q'*A*Z = ( * Ar X ) , +C ( * 0 0 ) +C +C where A11 is a RANKE-by-RANKE matrix and Ar is a +C RNKA22-by-RNKA22 invertible upper triangular matrix. +C If JOBA = 'R' then A has the above form with X = 0. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix Q'*E*Z. +C +C ( Er 0 ) +C Q'*E*Z = ( ) , +C ( 0 0 ) +C +C where Er is a RANKE-by-RANKE upper triangular invertible +C matrix. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the input/state matrix B. +C On exit, the leading L-by-M part of this array contains +C the transformed matrix Q'*B. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed matrix C*Z. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,L) +C If COMPQ = 'N': Q is not referenced. +C If COMPQ = 'I': on entry, Q need not be set; +C on exit, the leading L-by-L part of this +C array contains the orthogonal matrix Q, +C where Q' is the product of Householder +C transformations which are applied to A, +C E, and B on the left. +C If COMPQ = 'U': on entry, the leading L-by-L part of this +C array must contain an orthogonal matrix +C Q1; +C on exit, the leading L-by-L part of this +C array contains the orthogonal matrix +C Q1*Q. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= 1, if COMPQ = 'N'; +C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C If COMPZ = 'N': Z is not referenced. +C If COMPZ = 'I': on entry, Z need not be set; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix Z, +C which is the product of Householder +C transformations applied to A, E, and C +C on the right. +C If COMPZ = 'U': on entry, the leading N-by-N part of this +C array must contain an orthogonal matrix +C Z1; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix +C Z1*Z. +C +C LDZ INTEGER +C The leading dimension of array Z. +C LDZ >= 1, if COMPZ = 'N'; +C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. +C +C RANKE (output) INTEGER +C The estimated rank of matrix E, and thus also the order +C of the invertible upper triangular submatrix Er. +C +C RNKA22 (output) INTEGER +C If JOBA = 'R' or 'T', then RNKA22 is the estimated rank of +C matrix A22, and thus also the order of the invertible +C upper triangular submatrix Ar. +C If JOBA = 'N', then RNKA22 is not referenced. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the rank of E +C and of A22. If the user sets TOL > 0, then the given +C value of TOL is used as a lower bound for the +C reciprocal condition numbers of leading submatrices +C of R or R22 in the QR decompositions E * P = Q * R of E +C or A22 * P22 = Q22 * R22 of A22. +C A submatrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = L*N*EPS, is used instead, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, N+P, MIN(L,N)+MAX(3*N-1,M,L) ). +C For optimal performance, LDWORK should be larger. +C +C If LDWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C DWORK array, returns this value as the first entry of +C the DWORK array, and no error message related to LDWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a truncated QR factorization with column +C pivoting of E, in the form +C +C ( E11 E12 ) +C E * P = Q * ( ) +C ( 0 E22 ) +C +C and finds the largest RANKE-by-RANKE leading submatrix E11 whose +C estimated condition number is less than 1/TOL. RANKE defines thus +C the rank of matrix E. Further E22, being negligible, is set to +C zero, and an orthogonal matrix Y is determined such that +C +C ( E11 E12 ) = ( Er 0 ) * Y . +C +C The overal transformation matrix Z results as Z = P * Y' and the +C resulting transformed matrices Q'*A*Z and Q'*E*Z have the form +C +C ( Er 0 ) ( A11 A12 ) +C E <- Q'* E * Z = ( ) , A <- Q' * A * Z = ( ) , +C ( 0 0 ) ( A21 A22 ) +C +C where Er is an upper triangular invertible matrix. +C If JOBA = 'R' the same reduction is performed on A22 to obtain it +C in the form +C +C ( Ar 0 ) +C A22 = ( ) , +C ( 0 0 ) +C +C with Ar an upper triangular invertible matrix. +C If JOBA = 'T' then A22 is row compressed using the QR +C factorization with column pivoting to the form +C +C ( Ar X ) +C A22 = ( ) +C ( 0 0 ) +C +C with Ar an upper triangular invertible matrix. +C +C The transformations are also applied to the rest of system +C matrices +C +C B <- Q' * B, C <- C * Z. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( L*L*N ) floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. Based on the RASP routine RPDSSV. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 1999, +C May 2003, Jan. 2009. +C +C KEYWORDS +C +C Descriptor system, matrix algebra, matrix operations, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ, JOBA + INTEGER INFO, L, LDA, LDB, LDC, LDE, LDQ, LDWORK, + $ LDZ, M, N, P, RANKE, RNKA22 + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), + $ Z( LDZ, * ) +C .. Local Scalars .. + LOGICAL ILQ, ILZ, LQUERY, REDA, REDTR, WITHB, WITHC + INTEGER I, ICOMPQ, ICOMPZ, IR1, IRE1, J, K, KW, LA22, + $ LH, LN, LWR, NA22, NB, WRKOPT + DOUBLE PRECISION SVLMAX, TOLDEF +C .. Local Arrays .. + DOUBLE PRECISION SVAL(3) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DLASET, DORMQR, DORMRZ, DSWAP, DTZRZF, MB03OY, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode COMPQ. +C + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'U' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +C +C Decode COMPZ. +C + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'U' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF + REDA = LSAME( JOBA, 'R' ) + REDTR = LSAME( JOBA, 'T' ) + WITHB = M.GT.0 + WITHC = P.GT.0 + LQUERY = ( LDWORK.EQ.-1 ) +C +C Test the input parameters. +C + LN = MIN( L, N ) + INFO = 0 + WRKOPT = MAX( 1, N+P, LN + MAX( 3*N-1, M, L ) ) + IF( ICOMPQ.LE.0 ) THEN + INFO = -1 + ELSE IF( ICOMPZ.LE.0 ) THEN + INFO = -2 + ELSE IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA .AND. + $ .NOT.REDTR ) THEN + INFO = -3 + ELSE IF( L.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -9 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.L ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN + INFO = -17 + ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -19 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -22 + ELSE + IF( LQUERY ) THEN + NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LC', L, N, LN, -1 ) ) + WRKOPT = MAX( WRKOPT, LN + N*NB ) + IF( WITHB ) THEN + NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LC', L, M, LN, -1 ) ) + WRKOPT = MAX( WRKOPT, LN + M*NB ) + END IF + IF( ILQ ) THEN + NB = MIN( 64, ILAENV( 1, 'DORMQR', 'RN', L, L, LN, -1 ) ) + WRKOPT = MAX( WRKOPT, LN + L*NB ) + END IF + NB = ILAENV( 1, 'DGERQF', ' ', L, N, -1, -1 ) + WRKOPT = MAX( WRKOPT, LN + N*NB ) + NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RC', L, N, N, -1 ) ) + WRKOPT = MAX( WRKOPT, N + MAX( 1, L )*NB ) + IF( WITHC ) THEN + NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RC', P, N, N, -1 ) ) + WRKOPT = MAX( WRKOPT, N + MAX( 1, P )*NB ) + END IF + IF( ILZ ) THEN + NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RC', N, N, N, -1 ) ) + WRKOPT = MAX( WRKOPT, N + MAX( 1, N )*NB ) + END IF + ELSE IF( LDWORK.LT.WRKOPT ) THEN + INFO = -25 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01FD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C +C Initialize Q and Z if necessary. +C + IF( ICOMPQ.EQ.3 ) + $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) + IF( ICOMPZ.EQ.3 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +C +C Quick return if possible. +C + IF( L.EQ.0 .OR. N.EQ.0 ) THEN + DWORK(1) = ONE + RANKE = 0 + IF( REDA .OR. REDTR ) RNKA22 = 0 + RETURN + END IF +C + TOLDEF = TOL + IF( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance for rank determination. +C + TOLDEF = DBLE( L*N )*DLAMCH( 'EPSILON' ) + END IF +C +C Set the estimate of maximum singular value of E to +C max(||E||,||A||) to detect negligible A or E matrices. +C + SVLMAX = MAX( DLANGE( 'F', L, N, E, LDE, DWORK ), + $ DLANGE( 'F', L, N, A, LDA, DWORK ) ) +C +C Compute the rank-revealing QR decomposition of E, +C +C ( E11 E12 ) +C E * P = Qr * ( ) , +C ( 0 E22 ) +C +C and determine the rank of E using incremental condition +C estimation. +C Workspace: MIN(L,N) + 3*N - 1. +C + LWR = LDWORK - LN + KW = LN + 1 +C + CALL MB03OY( L, N, E, LDE, TOLDEF, SVLMAX, RANKE, SVAL, IWORK, + $ DWORK, DWORK(KW), INFO ) +C +C Apply transformation on the rest of matrices. +C + IF( RANKE.GT.0 ) THEN +C +C A <-- Qr' * A. +C Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL DORMQR( 'Left', 'Transpose', L, N, RANKE, E, LDE, DWORK, + $ A, LDA, DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C B <-- Qr' * B. +C Workspace: need MIN(L,N) + M; +C prefer MIN(L,N) + M*NB. +C + IF( WITHB ) THEN + CALL DORMQR( 'Left', 'Transpose', L, M, RANKE, E, LDE, + $ DWORK, B, LDB, DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) + END IF +C +C Q <-- Q * Qr. +C Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + IF( ILQ ) THEN + CALL DORMQR( 'Right', 'No Transpose', L, L, RANKE, E, LDE, + $ DWORK, Q, LDQ, DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) + END IF +C +C Set lower triangle of E to zero. +C + IF( L.GE.2 ) + $ CALL DLASET( 'Lower', L-1, RANKE, ZERO, ZERO, E(2,1), LDE ) +C +C Compute A*P, C*P and Z*P by forward permuting the columns of +C A, C and Z based on information in IWORK. +C + DO 10 J = 1, N + IWORK(J) = -IWORK(J) + 10 CONTINUE + DO 30 I = 1, N + IF( IWORK(I).LT.0 ) THEN + J = I + IWORK(J) = -IWORK(J) + 20 CONTINUE + K = IWORK(J) + IF( IWORK(K).LT.0 ) THEN + CALL DSWAP( L, A(1,J), 1, A(1,K), 1 ) + IF( WITHC ) + $ CALL DSWAP( P, C(1,J), 1, C(1,K), 1 ) + IF( ILZ ) + $ CALL DSWAP( N, Z(1,J), 1, Z(1,K), 1 ) + IWORK(K) = -IWORK(K) + J = K + GO TO 20 + END IF + END IF + 30 CONTINUE +C +C Determine an orthogonal matrix Y such that +C +C ( E11 E12 ) = ( Er 0 ) * Y . +C +C Compute E <-- E*Y', A <-- A*Y', C <-- C*Y', Z <-- Z*Y'. +C + IF( RANKE.LT.N ) THEN +C +C Workspace: need 2*N; +C prefer N + N*NB. +C + KW = RANKE + 1 + CALL DTZRZF( RANKE, N, E, LDE, DWORK, DWORK(KW), + $ LDWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Workspace: need N + MAX(L,P,N); +C prefer N + MAX(L,P,N)*NB. +C + LH = N - RANKE + CALL DORMRZ( 'Right', 'Transpose', L, N, RANKE, LH, E, LDE, + $ DWORK, A, LDA, DWORK(KW), LDWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + IF( WITHC ) THEN + CALL DORMRZ( 'Right', 'Transpose', P, N, RANKE, LH, E, + $ LDE, DWORK, C, LDC, DWORK(KW), LDWORK-KW+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF + IF( ILZ ) THEN + CALL DORMRZ( 'Right', 'Transpose', N, N, RANKE, LH, E, + $ LDE, DWORK, Z, LDZ, DWORK(KW), LDWORK-KW+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF +C +C Set E12 and E22 to zero. +C + CALL DLASET( 'Full', L, LH, ZERO, ZERO, E(1,KW), LDE ) + END IF + ELSE + CALL DLASET( 'Full', L, N, ZERO, ZERO, E, LDE ) + END IF +C +C Reduce A22 if necessary. +C + IF( REDA .OR. REDTR ) THEN + LA22 = L - RANKE + NA22 = N - RANKE + IF( MIN( LA22, NA22 ).EQ.0 ) THEN + RNKA22 = 0 + ELSE +C +C Compute the rank-revealing QR decomposition of A22, +C +C ( R11 R12 ) +C A22 * P2 = Q2 * ( ) , +C ( 0 R22 ) +C +C and determine the rank of A22 using incremental +C condition estimation. +C Workspace: MIN(L,N) + 3*N - 1. +C + IR1 = RANKE + 1 + CALL MB03OY( LA22, NA22, A(IR1,IR1), LDA, TOLDEF, + $ SVLMAX, RNKA22, SVAL, IWORK, DWORK, + $ DWORK(KW), INFO ) +C +C Apply transformation on the rest of matrices. +C + IF( RNKA22.GT.0 ) THEN +C +C A <-- diag(I, Q2') * A +C Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL DORMQR( 'Left', 'Transpose', LA22, RANKE, RNKA22, + $ A(IR1,IR1), LDA, DWORK, A(IR1,1), LDA, + $ DWORK(KW), LWR, INFO ) +C +C B <-- diag(I, Q2') * B +C Workspace: need MIN(L,N) + M; +C prefer MIN(L,N) + M*NB. +C + IF ( WITHB ) + $ CALL DORMQR( 'Left', 'Transpose', LA22, M, RNKA22, + $ A(IR1,IR1), LDA, DWORK, B(IR1,1), LDB, + $ DWORK(KW), LWR, INFO ) +C +C Q <-- Q * diag(I, Q2) +C Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + IF( ILQ ) + $ CALL DORMQR( 'Right', 'No transpose', L, LA22, RNKA22, + $ A(IR1,IR1), LDA, DWORK, Q(1,IR1), LDQ, + $ DWORK(KW), LWR, INFO ) +C +C Set lower triangle of A22 to zero. +C + IF( LA22.GE.2 ) + $ CALL DLASET( 'Lower', LA22-1, RNKA22, ZERO, ZERO, + $ A(IR1+1,IR1), LDA ) +C +C Compute A*diag(I,P2), C*diag(I,P2) and Z*diag(I,P2) +C by forward permuting the columns of A, C and Z based +C on information in IWORK. +C + DO 40 J = 1, NA22 + IWORK(J) = -IWORK(J) + 40 CONTINUE + DO 60 I = 1, NA22 + IF( IWORK(I).LT.0 ) THEN + J = I + IWORK(J) = -IWORK(J) + 50 CONTINUE + K = IWORK(J) + IF( IWORK(K).LT.0 ) THEN + CALL DSWAP( RANKE, A(1,RANKE+J), 1, + $ A(1,RANKE+K), 1 ) + IF( WITHC ) + $ CALL DSWAP( P, C(1,RANKE+J), 1, + $ C(1,RANKE+K), 1 ) + IF( ILZ ) + $ CALL DSWAP( N, Z(1,RANKE+J), 1, + $ Z(1,RANKE+K), 1 ) + IWORK(K) = -IWORK(K) + J = K + GO TO 50 + END IF + END IF + 60 CONTINUE +C + IF( REDA .AND. RNKA22.LT.NA22 ) THEN +C +C Determine an orthogonal matrix Y2 such that +C +C ( R11 R12 ) = ( Ar 0 ) * Y2 . +C +C Compute A <-- A*diag(I, Y2'), C <-- C*diag(I, Y2'), +C Z <-- Z*diag(I, Y2'). +C Workspace: need 2*N. +C prefer N + N*NB. +C + KW = RANKE + 1 + CALL DTZRZF( RNKA22, NA22, A(IR1,IR1), LDA, DWORK, + $ DWORK(KW), LDWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Workspace: need N + MAX(P,N); +C prefer N + MAX(P,N)*NB. +C + LH = NA22 - RNKA22 + IF( WITHC ) THEN + CALL DORMRZ( 'Right', 'Transpose', P, N, RNKA22, + $ LH, A(IR1,IR1), LDA, DWORK, C, LDC, + $ DWORK(KW), LDWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF + IF( ILZ ) THEN + CALL DORMRZ( 'Right', 'Transpose', N, N, RNKA22, + $ LH, A(IR1,IR1), LDA, DWORK, Z, LDZ, + $ DWORK(KW), LDWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF + IRE1 = RANKE + RNKA22 + 1 +C +C Set R12 and R22 to zero. +C + CALL DLASET( 'Full', LA22, LH, ZERO, ZERO, + $ A(IR1,IRE1), LDA ) + END IF + ELSE + CALL DLASET( 'Full', LA22, NA22, ZERO, ZERO, + $ A(IR1,IR1), LDA) + END IF + END IF + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of TG01FD *** + END diff --git a/mex/sources/libslicot/TG01FZ.f b/mex/sources/libslicot/TG01FZ.f new file mode 100644 index 000000000..5d8f59509 --- /dev/null +++ b/mex/sources/libslicot/TG01FZ.f @@ -0,0 +1,733 @@ + SUBROUTINE TG01FZ( COMPQ, COMPZ, JOBA, L, N, M, P, A, LDA, E, LDE, + $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, + $ TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute for the descriptor system (A-lambda E,B,C) +C the unitary transformation matrices Q and Z such that the +C transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is +C in a SVD-like coordinate form with +C +C ( A11 A12 ) ( Er 0 ) +C Q'*A*Z = ( ) , Q'*E*Z = ( ) , +C ( A21 A22 ) ( 0 0 ) +C +C where Er is an upper triangular invertible matrix, and ' denotes +C the conjugate transpose. Optionally, the A22 matrix can be further +C reduced to the form +C +C ( Ar X ) +C A22 = ( ) , +C ( 0 0 ) +C +C with Ar an upper triangular invertible matrix, and X either a full +C or a zero matrix. +C The left and/or right unitary transformations performed +C to reduce E and A22 can be optionally accumulated. +C +C ARGUMENTS +C +C Mode Parameters +C +C COMPQ CHARACTER*1 +C = 'N': do not compute Q; +C = 'I': Q is initialized to the unit matrix, and the +C unitary matrix Q is returned; +C = 'U': Q must contain a unitary matrix Q1 on entry, +C and the product Q1*Q is returned. +C +C COMPZ CHARACTER*1 +C = 'N': do not compute Z; +C = 'I': Z is initialized to the unit matrix, and the +C unitary matrix Z is returned; +C = 'U': Z must contain a unitary matrix Z1 on entry, +C and the product Z1*Z is returned. +C +C JOBA CHARACTER*1 +C = 'N': do not reduce A22; +C = 'R': reduce A22 to a SVD-like upper triangular form. +C = 'T': reduce A22 to an upper trapezoidal form. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A, B, and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A, E, and C. N >= 0. +C +C M (input) INTEGER +C The number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The number of rows of matrix C. P >= 0. +C +C A (input/output) COMPLEX*16 array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix +C is in the form +C +C ( A11 * * ) +C Q'*A*Z = ( * Ar X ) , +C ( * 0 0 ) +C +C where A11 is a RANKE-by-RANKE matrix and Ar is a +C RNKA22-by-RNKA22 invertible upper triangular matrix. +C If JOBA = 'R' then A has the above form with X = 0. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) COMPLEX*16 array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix Q'*E*Z. +C +C ( Er 0 ) +C Q'*E*Z = ( ) , +C ( 0 0 ) +C +C where Er is a RANKE-by-RANKE upper triangular invertible +C matrix. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) COMPLEX*16 array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the input/state matrix B. +C On exit, the leading L-by-M part of this array contains +C the transformed matrix Q'*B. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. +C +C C (input/output) COMPLEX*16 array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed matrix C*Z. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C Q (input/output) COMPLEX*16 array, dimension (LDQ,L) +C If COMPQ = 'N': Q is not referenced. +C If COMPQ = 'I': on entry, Q need not be set; +C on exit, the leading L-by-L part of this +C array contains the unitary matrix Q, +C where Q' is the product of Householder +C transformations which are applied to A, +C E, and B on the left. +C If COMPQ = 'U': on entry, the leading L-by-L part of this +C array must contain a unitary matrix Q1; +C on exit, the leading L-by-L part of this +C array contains the unitary matrix Q1*Q. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= 1, if COMPQ = 'N'; +C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. +C +C Z (input/output) COMPLEX*16 array, dimension (LDZ,N) +C If COMPZ = 'N': Z is not referenced. +C If COMPZ = 'I': on entry, Z need not be set; +C on exit, the leading N-by-N part of this +C array contains the unitary matrix Z, +C which is the product of Householder +C transformations applied to A, E, and C +C on the right. +C If COMPZ = 'U': on entry, the leading N-by-N part of this +C array must contain a unitary matrix Z1; +C on exit, the leading N-by-N part of this +C array contains the unitary matrix Z1*Z. +C +C LDZ INTEGER +C The leading dimension of array Z. +C LDZ >= 1, if COMPZ = 'N'; +C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. +C +C RANKE (output) INTEGER +C The estimated rank of matrix E, and thus also the order +C of the invertible upper triangular submatrix Er. +C +C RNKA22 (output) INTEGER +C If JOBA = 'R' or 'T', then RNKA22 is the estimated rank of +C matrix A22, and thus also the order of the invertible +C upper triangular submatrix Ar. +C If JOBA = 'N', then RNKA22 is not referenced. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the rank of E +C and of A22. If the user sets TOL > 0, then the given +C value of TOL is used as a lower bound for the +C reciprocal condition numbers of leading submatrices +C of R or R22 in the QR decompositions E * P = Q * R of E +C or A22 * P22 = Q22 * R22 of A22. +C A submatrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = L*N*EPS, is used instead, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (2*N) +C +C ZWORK DOUBLE PRECISION array, dimension (LZWORK) +C On exit, if INFO = 0, ZWORK(1) returns the optimal value +C of LZWORK. +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK >= MAX( 1, N+P, MIN(L,N)+MAX(3*N-1,M,L) ). +C For optimal performance, LZWORK should be larger. +C +C If LZWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C ZWORK array, returns this value as the first entry of +C the ZWORK array, and no error message related to LZWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a truncated QR factorization with column +C pivoting of E, in the form +C +C ( E11 E12 ) +C E * P = Q * ( ) +C ( 0 E22 ) +C +C and finds the largest RANKE-by-RANKE leading submatrix E11 whose +C estimated condition number is less than 1/TOL. RANKE defines thus +C the rank of matrix E. Further E22, being negligible, is set to +C zero, and a unitary matrix Y is determined such that +C +C ( E11 E12 ) = ( Er 0 ) * Y . +C +C The overal transformation matrix Z results as Z = P * Y' and the +C resulting transformed matrices Q'*A*Z and Q'*E*Z have the form +C +C ( Er 0 ) ( A11 A12 ) +C E <- Q'* E * Z = ( ) , A <- Q' * A * Z = ( ) , +C ( 0 0 ) ( A21 A22 ) +C +C where Er is an upper triangular invertible matrix. +C If JOBA = 'R' the same reduction is performed on A22 to obtain it +C in the form +C +C ( Ar 0 ) +C A22 = ( ) , +C ( 0 0 ) +C +C with Ar an upper triangular invertible matrix. +C If JOBA = 'T' then A22 is row compressed using the QR +C factorization with column pivoting to the form +C +C ( Ar X ) +C A22 = ( ) +C ( 0 0 ) +C +C with Ar an upper triangular invertible matrix. +C +C The transformations are also applied to the rest of system +C matrices +C +C B <- Q' * B, C <- C * Z. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( L*L*N ) floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Descriptor system, matrix algebra, matrix operations, unitary +C transformation. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION DONE, DZERO + PARAMETER ( DONE = 1.0D+0, DZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ, JOBA + INTEGER INFO, L, LDA, LDB, LDC, LDE, LDQ, LDZ, LZWORK, + $ M, N, P, RANKE, RNKA22 + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ E( LDE, * ), Q( LDQ, * ), Z( LDZ, * ), + $ ZWORK( * ) + DOUBLE PRECISION DWORK( * ) +C .. Local Scalars .. + LOGICAL ILQ, ILZ, LQUERY, REDA, REDTR, WITHB, WITHC + INTEGER I, ICOMPQ, ICOMPZ, IR1, IRE1, J, K, KW, LA22, + $ LH, LN, LWR, NA22, NB, WRKOPT + DOUBLE PRECISION SVLMAX, TOLDEF +C .. Local Arrays .. + DOUBLE PRECISION SVAL(3) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL DLAMCH, ILAENV, LSAME, ZLANGE +C .. External Subroutines .. + EXTERNAL MB3OYZ, XERBLA, ZLASET, ZSWAP, ZTZRZF, ZUNMQR, + $ ZUNMRZ +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode COMPQ. +C + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'U' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +C +C Decode COMPZ. +C + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'U' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF + REDA = LSAME( JOBA, 'R' ) + REDTR = LSAME( JOBA, 'T' ) + WITHB = M.GT.0 + WITHC = P.GT.0 + LQUERY = ( LZWORK.EQ.-1 ) +C +C Test the input parameters. +C + LN = MIN( L, N ) + INFO = 0 + WRKOPT = MAX( 1, N+P, LN + MAX( 3*N-1, M, L ) ) + IF( ICOMPQ.LE.0 ) THEN + INFO = -1 + ELSE IF( ICOMPZ.LE.0 ) THEN + INFO = -2 + ELSE IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA .AND. + $ .NOT.REDTR ) THEN + INFO = -3 + ELSE IF( L.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -9 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.L ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN + INFO = -17 + ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -19 + ELSE IF( TOL.GE.DONE ) THEN + INFO = -22 + ELSE + IF( LQUERY ) THEN + NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', L, N, LN, -1 ) ) + WRKOPT = MAX( WRKOPT, LN + N*NB ) + IF( WITHB ) THEN + NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', L, M, LN, -1 ) ) + WRKOPT = MAX( WRKOPT, LN + M*NB ) + END IF + IF( ILQ ) THEN + NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'RN', L, L, LN, -1 ) ) + WRKOPT = MAX( WRKOPT, LN + L*NB ) + END IF + NB = ILAENV( 1, 'ZGERQF', ' ', L, N, -1, -1 ) + WRKOPT = MAX( WRKOPT, LN + N*NB ) + NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', L, N, N, -1 ) ) + WRKOPT = MAX( WRKOPT, N + MAX( 1, L )*NB ) + IF( WITHC ) THEN + NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', P, N, N, -1 ) ) + WRKOPT = MAX( WRKOPT, N + MAX( 1, P )*NB ) + END IF + IF( ILZ ) THEN + NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', N, N, N, -1 ) ) + WRKOPT = MAX( WRKOPT, N + MAX( 1, N )*NB ) + END IF + ELSE IF( LZWORK.LT.WRKOPT ) THEN + INFO = -26 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01FZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + ZWORK(1) = WRKOPT + RETURN + END IF +C +C Initialize Q and Z if necessary. +C + IF( ICOMPQ.EQ.3 ) + $ CALL ZLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) + IF( ICOMPZ.EQ.3 ) + $ CALL ZLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +C +C Quick return if possible. +C + IF( L.EQ.0 .OR. N.EQ.0 ) THEN + ZWORK(1) = ONE + RANKE = 0 + IF( REDA .OR. REDTR ) RNKA22 = 0 + RETURN + END IF +C + TOLDEF = TOL + IF( TOLDEF.LE.DZERO ) THEN +C +C Use the default tolerance for rank determination. +C + TOLDEF = DBLE( L*N )*DLAMCH( 'EPSILON' ) + END IF +C +C Set the estimate of maximum singular value of E to +C max(||E||,||A||) to detect negligible A or E matrices. +C + SVLMAX = MAX( ZLANGE( 'F', L, N, E, LDE, DWORK ), + $ ZLANGE( 'F', L, N, A, LDA, DWORK ) ) +C +C Compute the rank-revealing QR decomposition of E, +C +C ( E11 E12 ) +C E * P = Qr * ( ) , +C ( 0 E22 ) +C +C and determine the rank of E using incremental condition +C estimation. +C Complex Workspace: MIN(L,N) + 3*N - 1. +C Real Workspace: 2*N. +C + LWR = LZWORK - LN + KW = LN + 1 +C + CALL MB3OYZ( L, N, E, LDE, TOLDEF, SVLMAX, RANKE, SVAL, IWORK, + $ ZWORK, DWORK, ZWORK(KW), INFO ) +C +C Apply transformation on the rest of matrices. +C + IF( RANKE.GT.0 ) THEN +C +C A <-- Qr' * A. +C Complex Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL ZUNMQR( 'Left', 'ConjTranspose', L, N, RANKE, E, LDE, + $ ZWORK, A, LDA, ZWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(KW) ) ) +C +C B <-- Qr' * B. +C Complex Workspace: need MIN(L,N) + M; +C prefer MIN(L,N) + M*NB. +C + IF( WITHB ) THEN + CALL ZUNMQR( 'Left', 'ConjTranspose', L, M, RANKE, E, LDE, + $ ZWORK, B, LDB, ZWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(KW) ) ) + END IF +C +C Q <-- Q * Qr. +C Complex Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + IF( ILQ ) THEN + CALL ZUNMQR( 'Right', 'No Transpose', L, L, RANKE, E, LDE, + $ ZWORK, Q, LDQ, ZWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(KW) ) ) + END IF +C +C Set lower triangle of E to zero. +C + IF( L.GE.2 ) + $ CALL ZLASET( 'Lower', L-1, RANKE, ZERO, ZERO, E(2,1), LDE ) +C +C Compute A*P, C*P and Z*P by forward permuting the columns of +C A, C and Z based on information in IWORK. +C + DO 10 J = 1, N + IWORK(J) = -IWORK(J) + 10 CONTINUE + DO 30 I = 1, N + IF( IWORK(I).LT.0 ) THEN + J = I + IWORK(J) = -IWORK(J) + 20 CONTINUE + K = IWORK(J) + IF( IWORK(K).LT.0 ) THEN + CALL ZSWAP( L, A(1,J), 1, A(1,K), 1 ) + IF( WITHC ) + $ CALL ZSWAP( P, C(1,J), 1, C(1,K), 1 ) + IF( ILZ ) + $ CALL ZSWAP( N, Z(1,J), 1, Z(1,K), 1 ) + IWORK(K) = -IWORK(K) + J = K + GO TO 20 + END IF + END IF + 30 CONTINUE +C +C Determine a unitary matrix Y such that +C +C ( E11 E12 ) = ( Er 0 ) * Y . +C +C Compute E <-- E*Y', A <-- A*Y', C <-- C*Y', Z <-- Z*Y'. +C + IF( RANKE.LT.N ) THEN +C +C Complex Workspace: need 2*N; +C prefer N + N*NB. +C + KW = RANKE + 1 + CALL ZTZRZF( RANKE, N, E, LDE, ZWORK, ZWORK(KW), + $ LZWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) +C +C Complex Workspace: need N + MAX(L,P,N); +C prefer N + MAX(L,P,N)*NB. +C + LH = N - RANKE + CALL ZUNMRZ( 'Right', 'Conjugate transpose', L, N, RANKE, + $ LH, E, LDE, ZWORK, A, LDA, ZWORK(KW), + $ LZWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) + IF( WITHC ) THEN + CALL ZUNMRZ( 'Right', 'Conjugate transpose', P, N, RANKE, + $ LH, E, LDE, ZWORK, C, LDC, ZWORK(KW), + $ LZWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) + END IF + IF( ILZ ) THEN + CALL ZUNMRZ( 'Right', 'Conjugate transpose', N, N, RANKE, + $ LH, E, LDE, ZWORK, Z, LDZ, ZWORK(KW), + $ LZWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) + END IF +C +C Set E12 and E22 to zero. +C + CALL ZLASET( 'Full', L, LH, ZERO, ZERO, E(1,KW), LDE ) + END IF + ELSE + CALL ZLASET( 'Full', L, N, ZERO, ZERO, E, LDE ) + END IF +C +C Reduce A22 if necessary. +C + IF( REDA .OR. REDTR ) THEN + LA22 = L - RANKE + NA22 = N - RANKE + IF( MIN( LA22, NA22 ).EQ.0 ) THEN + RNKA22 = 0 + ELSE +C +C Compute the rank-revealing QR decomposition of A22, +C +C ( R11 R12 ) +C A22 * P2 = Q2 * ( ) , +C ( 0 R22 ) +C +C and determine the rank of A22 using incremental +C condition estimation. +C Complex Workspace: MIN(L,N) + 3*N - 1. +C Real Workspace: 2*N. +C + IR1 = RANKE + 1 + CALL MB3OYZ( LA22, NA22, A(IR1,IR1), LDA, TOLDEF, + $ SVLMAX, RNKA22, SVAL, IWORK, ZWORK, + $ DWORK, ZWORK(KW), INFO ) +C +C Apply transformation on the rest of matrices. +C + IF( RNKA22.GT.0 ) THEN +C +C A <-- diag(I, Q2') * A +C Complex Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL ZUNMQR( 'Left', 'ConjTranspose', LA22, RANKE, + $ RNKA22, A(IR1,IR1), LDA, ZWORK, A(IR1,1), + $ LDA, ZWORK(KW), LWR, INFO ) +C +C B <-- diag(I, Q2') * B +C Complex Workspace: need MIN(L,N) + M; +C prefer MIN(L,N) + M*NB. +C + IF ( WITHB ) + $ CALL ZUNMQR( 'Left', 'ConjTranspose', LA22, M, RNKA22, + $ A(IR1,IR1), LDA, ZWORK, B(IR1,1), LDB, + $ ZWORK(KW), LWR, INFO ) +C +C Q <-- Q * diag(I, Q2) +C Complex Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + IF( ILQ ) + $ CALL ZUNMQR( 'Right', 'No transpose', L, LA22, RNKA22, + $ A(IR1,IR1), LDA, ZWORK, Q(1,IR1), LDQ, + $ ZWORK(KW), LWR, INFO ) +C +C Set lower triangle of A22 to zero. +C + IF( LA22.GE.2 ) + $ CALL ZLASET( 'Lower', LA22-1, RNKA22, ZERO, ZERO, + $ A(IR1+1,IR1), LDA ) +C +C Compute A*diag(I,P2), C*diag(I,P2) and Z*diag(I,P2) +C by forward permuting the columns of A, C and Z based +C on information in IWORK. +C + DO 40 J = 1, NA22 + IWORK(J) = -IWORK(J) + 40 CONTINUE + DO 60 I = 1, NA22 + IF( IWORK(I).LT.0 ) THEN + J = I + IWORK(J) = -IWORK(J) + 50 CONTINUE + K = IWORK(J) + IF( IWORK(K).LT.0 ) THEN + CALL ZSWAP( RANKE, A(1,RANKE+J), 1, + $ A(1,RANKE+K), 1 ) + IF( WITHC ) + $ CALL ZSWAP( P, C(1,RANKE+J), 1, + $ C(1,RANKE+K), 1 ) + IF( ILZ ) + $ CALL ZSWAP( N, Z(1,RANKE+J), 1, + $ Z(1,RANKE+K), 1 ) + IWORK(K) = -IWORK(K) + J = K + GO TO 50 + END IF + END IF + 60 CONTINUE +C + IF( REDA .AND. RNKA22.LT.NA22 ) THEN +C +C Determine a unitary matrix Y2 such that +C +C ( R11 R12 ) = ( Ar 0 ) * Y2 . +C +C Compute A <-- A*diag(I, Y2'), C <-- C*diag(I, Y2'), +C Z <-- Z*diag(I, Y2'). +C +C Complex Workspace: need 2*N; +C prefer N + N*NB. +C + KW = RANKE + 1 + CALL ZTZRZF( RNKA22, NA22, A(IR1,IR1), LDA, ZWORK, + $ ZWORK(KW), LZWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) +C +C Complex Workspace: need N + MAX(P,N); +C prefer N + MAX(P,N)*NB. +C + LH = NA22 - RNKA22 + IF( WITHC ) THEN + CALL ZUNMRZ( 'Right', 'Conjugate transpose', P, N, + $ RNKA22, LH, A(IR1,IR1), LDA, ZWORK, C, + $ LDC, ZWORK(KW), LZWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) + END IF + IF( ILZ ) THEN + CALL ZUNMRZ( 'Right', 'Conjugate transpose', N, N, + $ RNKA22, LH, A(IR1,IR1), LDA, ZWORK, Z, + $ LDZ, ZWORK(KW), LZWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) + END IF + IRE1 = RANKE + RNKA22 + 1 +C +C Set R12 and R22 to zero. +C + CALL ZLASET( 'Full', LA22, LH, ZERO, ZERO, + $ A(IR1,IRE1), LDA ) + END IF + ELSE + CALL ZLASET( 'Full', LA22, NA22, ZERO, ZERO, + $ A(IR1,IR1), LDA) + END IF + END IF + END IF +C + ZWORK(1) = WRKOPT +C + RETURN +C *** Last line of TG01FZ *** + END diff --git a/mex/sources/libslicot/TG01HD.f b/mex/sources/libslicot/TG01HD.f new file mode 100644 index 000000000..318f1f353 --- /dev/null +++ b/mex/sources/libslicot/TG01HD.f @@ -0,0 +1,545 @@ + SUBROUTINE TG01HD( JOBCON, COMPQ, COMPZ, N, M, P, A, LDA, E, LDE, + $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, NCONT, NIUCON, + $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute orthogonal transformation matrices Q and Z which +C reduce the N-th order descriptor system (A-lambda*E,B,C) +C to the form +C +C ( Ac * ) ( Ec * ) ( Bc ) +C Q'*A*Z = ( ) , Q'*E*Z = ( ) , Q'*B = ( ) , +C ( 0 Anc ) ( 0 Enc ) ( 0 ) +C +C C*Z = ( Cc Cnc ) , +C +C where the NCONT-th order descriptor system (Ac-lambda*Ec,Bc,Cc) +C is a finite and/or infinite controllable. The pencil +C Anc - lambda*Enc is regular of order N-NCONT and contains the +C uncontrollable finite and/or infinite eigenvalues of the pencil +C A-lambda*E. +C +C For JOBCON = 'C' or 'I', the pencil ( Bc Ec-lambda*Ac ) has full +C row rank NCONT for all finite lambda and is in a staircase form +C with +C _ _ _ _ +C ( E1,0 E1,1 ... E1,k-1 E1,k ) +C ( _ _ _ ) +C ( Bc Ec ) = ( 0 E2,1 ... E2,k-1 E2,k ) , (1) +C ( ... _ _ ) +C ( 0 0 ... Ek,k-1 Ek,k ) +C +C _ _ _ +C ( A1,1 ... A1,k-1 A1,k ) +C ( _ _ ) +C Ac = ( 0 ... A2,k-1 A2,k ) , (2) +C ( ... _ ) +C ( 0 ... 0 Ak,k ) +C _ +C where Ei,i-1 is an rtau(i)-by-rtau(i-1) full row rank matrix +C _ +C (with rtau(0) = M) and Ai,i is an rtau(i)-by-rtau(i) +C upper triangular matrix. +C +C For JOBCON = 'F', the pencil ( Bc Ac-lambda*Ec ) has full +C row rank NCONT for all finite lambda and is in a staircase form +C with +C _ _ _ _ +C ( A1,0 A1,1 ... A1,k-1 A1,k ) +C ( _ _ _ ) +C ( Bc Ac ) = ( 0 A2,1 ... A2,k-1 A2,k ) , (3) +C ( ... _ _ ) +C ( 0 0 ... Ak,k-1 Ak,k ) +C +C _ _ _ +C ( E1,1 ... E1,k-1 E1,k ) +C ( _ _ ) +C Ec = ( 0 ... E2,k-1 E2,k ) , (4) +C ( ... _ ) +C ( 0 ... 0 Ek,k ) +C _ +C where Ai,i-1 is an rtau(i)-by-rtau(i-1) full row rank matrix +C _ +C (with rtau(0) = M) and Ei,i is an rtau(i)-by-rtau(i) +C upper triangular matrix. +C +C For JOBCON = 'C', the (N-NCONT)-by-(N-NCONT) regular pencil +C Anc - lambda*Enc has the form +C +C ( Ainc - lambda*Einc * ) +C Anc - lambda*Enc = ( ) , +C ( 0 Afnc - lambda*Efnc ) +C +C where: +C 1) the NIUCON-by-NIUCON regular pencil Ainc - lambda*Einc, +C with Ainc upper triangular and nonsingular, contains the +C uncontrollable infinite eigenvalues of A - lambda*E; +C 2) the (N-NCONT-NIUCON)-by-(N-NCONT-NIUCON) regular pencil +C Afnc - lambda*Efnc, with Efnc upper triangular and +C nonsingular, contains the uncontrollable finite +C eigenvalues of A - lambda*E. +C +C Note: The significance of the two diagonal blocks can be +C interchanged by calling the routine with the +C arguments A and E interchanged. In this case, +C Ainc - lambda*Einc contains the uncontrollable zero +C eigenvalues of A - lambda*E, while Afnc - lambda*Efnc +C contains the uncontrollable nonzero finite and infinite +C eigenvalues of A - lambda*E. +C +C For JOBCON = 'F', the pencil Anc - lambda*Enc has the form +C +C Anc - lambda*Enc = Afnc - lambda*Efnc , +C +C where the regular pencil Afnc - lambda*Efnc, with Efnc +C upper triangular and nonsingular, contains the uncontrollable +C finite eigenvalues of A - lambda*E. +C +C For JOBCON = 'I', the pencil Anc - lambda*Enc has the form +C +C Anc - lambda*Enc = Ainc - lambda*Einc , +C +C where the regular pencil Ainc - lambda*Einc, with Ainc +C upper triangular and nonsingular, contains the uncontrollable +C nonzero finite and infinite eigenvalues of A - lambda*E. +C +C The left and/or right orthogonal transformations Q and Z +C performed to reduce the system matrices can be optionally +C accumulated. +C +C The reduced order descriptor system (Ac-lambda*Ec,Bc,Cc) has +C the same transfer-function matrix as the original system +C (A-lambda*E,B,C). +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBCON CHARACTER*1 +C = 'C': separate both finite and infinite uncontrollable +C eigenvalues; +C = 'F': separate only finite uncontrollable eigenvalues: +C = 'I': separate only nonzero finite and infinite +C uncontrollable eigenvalues. +C +C COMPQ CHARACTER*1 +C = 'N': do not compute Q; +C = 'I': Q is initialized to the unit matrix, and the +C orthogonal matrix Q is returned; +C = 'U': Q must contain an orthogonal matrix Q1 on entry, +C and the product Q1*Q is returned. +C +C COMPZ CHARACTER*1 +C = 'N': do not compute Z; +C = 'I': Z is initialized to the unit matrix, and the +C orthogonal matrix Z is returned; +C = 'U': Z must contain an orthogonal matrix Z1 on entry, +C and the product Z1*Z is returned. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the descriptor state vector; also the +C order of square matrices A and E, the number of rows of +C matrix B, and the number of columns of matrix C. N >= 0. +C +C M (input) INTEGER +C The dimension of descriptor system input vector; also the +C number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The dimension of descriptor system output vector; also the +C number of rows of matrix C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the N-by-N state matrix A. +C On exit, the leading N-by-N part of this array contains +C the transformed state matrix Q'*A*Z, +C +C ( Ac * ) +C Q'*A*Z = ( ) , +C ( 0 Anc ) +C +C where Ac is NCONT-by-NCONT and Anc is +C (N-NCONT)-by-(N-NCONT). +C If JOBCON = 'F', the matrix ( Bc Ac ) is in the +C controllability staircase form (3). +C If JOBCON = 'C' or 'I', the submatrix Ac is upper +C triangular. +C If JOBCON = 'C', the Anc matrix has the form +C +C ( Ainc * ) +C Anc = ( ) , +C ( 0 Afnc ) +C +C where the NIUCON-by-NIUCON matrix Ainc is nonsingular and +C upper triangular. +C If JOBCON = 'I', Anc is nonsingular and upper triangular. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the N-by-N descriptor matrix E. +C On exit, the leading N-by-N part of this array contains +C the transformed descriptor matrix Q'*E*Z, +C +C ( Ec * ) +C Q'*E*Z = ( ) , +C ( 0 Enc ) +C +C where Ec is NCONT-by-NCONT and Enc is +C (N-NCONT)-by-(N-NCONT). +C If JOBCON = 'C' or 'I', the matrix ( Bc Ec ) is in the +C controllability staircase form (1). +C If JOBCON = 'F', the submatrix Ec is upper triangular. +C If JOBCON = 'C', the Enc matrix has the form +C +C ( Einc * ) +C Enc = ( ) , +C ( 0 Efnc ) +C +C where the NIUCON-by-NIUCON matrix Einc is nilpotent +C and the (N-NCONT-NIUCON)-by-(N-NCONT-NIUCON) matrix Efnc +C is nonsingular and upper triangular. +C If JOBCON = 'F', Enc is nonsingular and upper triangular. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the N-by-M input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed input matrix +C +C ( Bc ) +C Q'*B = ( ) , +C ( 0 ) +C +C where Bc is NCONT-by-M. +C For JOBCON = 'C' or 'I', the matrix ( Bc Ec ) is in the +C controllability staircase form (1). +C For JOBCON = 'F', the matrix ( Bc Ac ) is in the +C controllability staircase form (3). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed matrix C*Z. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C If COMPQ = 'N': Q is not referenced. +C If COMPQ = 'I': on entry, Q need not be set; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix Q, +C where Q' is the product of transformations +C which are applied to A, E, and B on +C the left. +C If COMPQ = 'U': on entry, the leading N-by-N part of this +C array must contain an orthogonal matrix +C Qc; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix +C Qc*Q. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= 1, if COMPQ = 'N'; +C LDQ >= MAX(1,N), if COMPQ = 'U' or 'I'. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C If COMPZ = 'N': Z is not referenced. +C If COMPZ = 'I': on entry, Z need not be set; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix Z, +C which is the product of transformations +C applied to A, E, and C on the right. +C If COMPZ = 'U': on entry, the leading N-by-N part of this +C array must contain an orthogonal matrix +C Zc; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix +C Zc*Z. +C +C LDZ INTEGER +C The leading dimension of array Z. +C LDZ >= 1, if COMPZ = 'N'; +C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. +C +C NCONT (output) INTEGER +C The order of the reduced matrices Ac and Ec, and the +C number of rows of reduced matrix Bc; also the order of +C the controllable part of the pair (A-lambda*E,B). +C +C NIUCON (output) INTEGER +C For JOBCON = 'C', the order of the reduced matrices +C Ainc and Einc; also the number of uncontrollable +C infinite eigenvalues of the pencil A - lambda*E. +C For JOBCON = 'F' or 'I', NIUCON has no significance +C and is set to zero. +C +C NRBLCK (output) INTEGER +C For JOBCON = 'C' or 'I', the number k, of full row rank +C _ +C blocks Ei,i in the staircase form of the pencil +C (Bc Ec-lambda*Ac) (see (1) and (2)). +C For JOBCON = 'F', the number k, of full row rank blocks +C _ +C Ai,i in the staircase form of the pencil (Bc Ac-lambda*Ec) +C (see (3) and (4)). +C +C RTAU (output) INTEGER array, dimension (N) +C RTAU(i), for i = 1, ..., NRBLCK, is the row dimension of +C _ _ +C the full row rank block Ei,i-1 or Ai,i-1 in the staircase +C form (1) or (3) for JOBCON = 'C' or 'I', or +C for JOBCON = 'F', respectively. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determinations when +C transforming (A-lambda*E, B). If the user sets TOL > 0, +C then the given value of TOL is used as a lower bound for +C reciprocal condition numbers in rank determinations; a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*N*EPS, is used instead, where EPS +C is the machine precision (see LAPACK Library routine +C DLAMCH). TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension MAX(N,2*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The subroutine is based on the reduction algorithms of [1]. +C +C REFERENCES +C +C [1] A. Varga +C Computation of Irreducible Generalized State-Space +C Realizations. +C Kybernetika, vol. 26, pp. 89-106, 1990. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( N**3 ) floating point operations. +C +C FURTHER COMMENTS +C +C If the system matrices A, E and B are badly scaled, it is +C generally recommendable to scale them with the SLICOT routine +C TG01AD, before calling TG01HD. +C +C CONTRIBUTOR +C +C C. Oara, University "Politehnica" Bucharest. +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. Based on the RASP routine RPDSCF. +C +C REVISIONS +C +C July 1999, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C Controllability, minimal realization, orthogonal canonical form, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ, JOBCON + INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDZ, + $ M, N, NCONT, NIUCON, NRBLCK, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK( * ), RTAU( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), + $ Z( LDZ, * ) +C .. Local Scalars .. + CHARACTER JOBQ, JOBZ + LOGICAL FINCON, ILQ, ILZ, INFCON + INTEGER ICOMPQ, ICOMPZ, LBA, NR +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL TG01HX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable Statements .. +C +C Decode JOBCON. +C + IF( LSAME( JOBCON, 'C' ) ) THEN + FINCON = .TRUE. + INFCON = .TRUE. + ELSE IF( LSAME( JOBCON, 'F' ) ) THEN + FINCON = .TRUE. + INFCON = .FALSE. + ELSE IF( LSAME( JOBCON, 'I' ) ) THEN + FINCON = .FALSE. + INFCON = .TRUE. + ELSE + FINCON = .FALSE. + INFCON = .FALSE. + END IF +C +C Decode COMPQ. +C + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'U' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +C +C Decode COMPZ. +C + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'U' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF +C +C Test the input scalar parameters. +C + INFO = 0 + IF( .NOT.FINCON .AND. .NOT.INFCON ) THEN + INFO = -1 + ELSE IF( ICOMPQ.LE.0 ) THEN + INFO = -2 + ELSE IF( ICOMPZ.LE.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -14 + ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN + INFO = -16 + ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -18 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -23 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01HD', -INFO ) + RETURN + END IF +C + JOBQ = COMPQ + JOBZ = COMPZ +C + IF( FINCON ) THEN +C +C Perform finite controllability form reduction. +C + CALL TG01HX( JOBQ, JOBZ, N, N, M, P, N, MAX( 0, N-1 ), A, LDA, + $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NR, + $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) + IF( NRBLCK.GT.1 ) THEN + LBA = RTAU(1) + RTAU(2) - 1 + ELSE IF( NRBLCK.EQ.1 ) THEN + LBA = RTAU(1) - 1 + ELSE + LBA = 0 + END IF + IF( ILQ ) JOBQ = 'U' + IF( ILZ ) JOBZ = 'U' + ELSE + NR = N + LBA = MAX( 0, N-1 ) + END IF +C + IF( INFCON ) THEN +C +C Perform infinite controllability form reduction. +C + CALL TG01HX( JOBQ, JOBZ, N, N, M, P, NR, LBA, E, LDE, + $ A, LDA, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NCONT, + $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) + IF( FINCON ) THEN + NIUCON = NR - NCONT + ELSE + NIUCON = 0 + END IF + ELSE + NCONT = NR + NIUCON = 0 + END IF +C + RETURN +C +C *** Last line of TG01HD *** + END diff --git a/mex/sources/libslicot/TG01HX.f b/mex/sources/libslicot/TG01HX.f new file mode 100644 index 000000000..c0717f81a --- /dev/null +++ b/mex/sources/libslicot/TG01HX.f @@ -0,0 +1,694 @@ + SUBROUTINE TG01HX( COMPQ, COMPZ, L, N, M, P, N1, LBE, A, LDA, + $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NR, + $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C Given the descriptor system (A-lambda*E,B,C) with the system +C matrices A, E and B of the form +C +C ( A1 X1 ) ( E1 Y1 ) ( B1 ) +C A = ( ) , E = ( ) , B = ( ) , +C ( 0 X2 ) ( 0 Y2 ) ( 0 ) +C +C where +C - B is an L-by-M matrix, with B1 an N1-by-M submatrix +C - A is an L-by-N matrix, with A1 an N1-by-N1 submatrix +C - E is an L-by-N matrix, with E1 an N1-by-N1 submatrix +C with LBE nonzero sub-diagonals, +C this routine reduces the pair (A1-lambda*E1,B1) to the form +C +C Qc'*[A1-lambda*E1 B1]*diag(Zc,I) = +C +C ( Bc Ac-lambda*Ec * ) +C ( ) , +C ( 0 0 Anc-lambda*Enc ) +C +C where: +C 1) the pencil ( Bc Ac-lambda*Ec ) has full row rank NR for +C all finite lambda and is in a staircase form with +C _ _ _ _ +C ( A1,0 A1,1 ... A1,k-1 A1,k ) +C ( _ _ _ ) +C ( Bc Ac ) = ( 0 A2,1 ... A2,k-1 A2,k ) , (1) +C ( ... _ _ ) +C ( 0 0 ... Ak,k-1 Ak,k ) +C +C _ _ _ +C ( E1,1 ... E1,k-1 E1,k ) +C ( _ _ ) +C Ec = ( 0 ... E2,k-1 E2,k ) , (2) +C ( ... _ ) +C ( 0 ... 0 Ek,k ) +C _ +C where Ai,i-1 is an rtau(i)-by-rtau(i-1) full row rank +C _ +C matrix (with rtau(0) = M) and Ei,i is an rtau(i)-by-rtau(i) +C upper triangular matrix. +C +C 2) the pencil Anc-lambda*Enc is regular of order N1-NR with Enc +C upper triangular; this pencil contains the uncontrollable +C finite eigenvalues of the pencil (A1-lambda*E1). +C +C The transformations are applied to the whole matrices A, E, B +C and C. The left and/or right orthogonal transformations Qc and Zc +C performed to reduce the pencil S(lambda) can be optionally +C accumulated in the matrices Q and Z, respectivelly. +C +C The reduced order descriptor system (Ac-lambda*Ec,Bc,Cc) has no +C uncontrollable finite eigenvalues and has the same +C transfer-function matrix as the original system (A-lambda*E,B,C). +C +C ARGUMENTS +C +C Mode Parameters +C +C COMPQ CHARACTER*1 +C = 'N': do not compute Q; +C = 'I': Q is initialized to the unit matrix, and the +C orthogonal matrix Q is returned; +C = 'U': Q must contain an orthogonal matrix Q1 on entry, +C and the product Q1*Q is returned. +C +C COMPZ CHARACTER*1 +C = 'N': do not compute Z; +C = 'I': Z is initialized to the unit matrix, and the +C orthogonal matrix Z is returned; +C = 'U': Z must contain an orthogonal matrix Z1 on entry, +C and the product Z1*Z is returned. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of descriptor state equations; also the number +C of rows of matrices A, E and B. L >= 0. +C +C N (input) INTEGER +C The dimension of the descriptor state vector; also the +C number of columns of matrices A, E and C. N >= 0. +C +C M (input) INTEGER +C The dimension of descriptor system input vector; also the +C number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The dimension of descriptor system output; also the +C number of rows of matrix C. P >= 0. +C +C N1 (input) INTEGER +C The order of subsystem (A1-lambda*E1,B1,C1) to be reduced. +C MIN(L,N) >= N1 >= 0. +C +C LBE (input) INTEGER +C The number of nonzero sub-diagonals of submatrix E1. +C MAX(0,N1-1) >= LBE >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the L-by-N state matrix A in the partitioned +C form +C ( A1 X1 ) +C A = ( ) , +C ( 0 X2 ) +C +C where A1 is N1-by-N1. +C On exit, the leading L-by-N part of this array contains +C the transformed state matrix, +C +C ( Ac * * ) +C Qc'*A*Zc = ( 0 Anc * ) , +C ( 0 0 * ) +C +C where Ac is NR-by-NR and Anc is (N1-NR)-by-(N1-NR). +C The matrix ( Bc Ac ) is in the controlability +C staircase form (1). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the L-by-N descriptor matrix E in the partitioned +C form +C ( E1 Y1 ) +C E = ( ) , +C ( 0 Y2 ) +C +C where E1 is N1-by-N1 matrix with LBE nonzero +C sub-diagonals. +C On exit, the leading L-by-N part of this array contains +C the transformed descriptor matrix +C +C ( Ec * * ) +C Qc'*E*Zc = ( 0 Enc * ) , +C ( 0 0 * ) +C +C where Ec is NR-by-NR and Enc is (N1-NR)-by-(N1-NR). +C Both Ec and Enc are upper triangular and Enc is +C nonsingular. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the L-by-M input matrix B in the partitioned +C form +C ( B1 ) +C B = ( ) , +C ( 0 ) +C +C where B1 is N1-by-M. +C On exit, the leading L-by-M part of this array contains +C the transformed input matrix +C +C ( Bc ) +C Qc'*B = ( ) , +C ( 0 ) +C +C where Bc is NR-by-M. +C The matrix ( Bc Ac ) is in the controlability +C staircase form (1). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,L). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed matrix C*Zc. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,L) +C If COMPQ = 'N': Q is not referenced. +C If COMPQ = 'I': on entry, Q need not be set; +C on exit, the leading L-by-L part of this +C array contains the orthogonal matrix Q, +C where Q' is the product of transformations +C which are applied to A, E, and B on +C the left. +C If COMPQ = 'U': on entry, the leading L-by-L part of this +C array must contain an orthogonal matrix +C Qc; +C on exit, the leading L-by-L part of this +C array contains the orthogonal matrix +C Qc*Q. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= 1, if COMPQ = 'N'; +C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C If COMPZ = 'N': Z is not referenced. +C If COMPZ = 'I': on entry, Z need not be set; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix Z, +C which is the product of transformations +C applied to A, E, and C on the right. +C If COMPZ = 'U': on entry, the leading N-by-N part of this +C array must contain an orthogonal matrix +C Zc; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix +C Zc*Z. +C +C LDZ INTEGER +C The leading dimension of array Z. +C LDZ >= 1, if COMPZ = 'N'; +C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. +C +C NR (output) INTEGER +C The order of the reduced matrices Ac and Ec, and the +C number of rows of the reduced matrix Bc; also the order of +C the controllable part of the pair (B, A-lambda*E). +C +C NRBLCK (output) INTEGER _ +C The number k, of full row rank blocks Ai,i in the +C staircase form of the pencil (Bc Ac-lambda*Ec) (see (1) +C and (2)). +C +C RTAU (output) INTEGER array, dimension (N1) +C RTAU(i), for i = 1, ..., NRBLCK, is the row dimension of +C _ +C the full row rank block Ai,i-1 in the staircase form (1). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determinations when +C transforming (A-lambda*E, B). If the user sets TOL > 0, +C then the given value of TOL is used as a lower bound for +C reciprocal condition numbers in rank determinations; a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = L*N*EPS, is used instead, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension MAX(N,L,2*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The subroutine is based on the reduction algorithm of [1]. +C +C REFERENCES +C +C [1] A. Varga +C Computation of Irreducible Generalized State-Space +C Realizations. +C Kybernetika, vol. 26, pp. 89-106, 1990. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( N*N1**2 ) floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. Based on the RASP routine RPDS05. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 1999, +C May 2003, Nov. 2003. +C A. Varga, German Aerospace Center, Oberpfaffenhofen, Nov. 2003. +C +C KEYWORDS +C +C Controllability, minimal realization, orthogonal canonical form, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ONE, P05, ZERO + PARAMETER ( ONE = 1.0D0, P05 = 0.05D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ + INTEGER INFO, L, LBE, LDA, LDB, LDC, LDE, LDQ, LDZ, M, + $ N, N1, NR, NRBLCK, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK( * ), RTAU( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), + $ Z( LDZ, * ) +C .. Local Scalars .. + LOGICAL ILQ, ILZ, WITHC + INTEGER I, IC, ICOL, ICOMPQ, ICOMPZ, IROW, ISMAX, + $ ISMIN, J, K, MN, NF, NR1, RANK, TAUIM1 + DOUBLE PRECISION CO, C1, C2, RCOND, SMAX, SMAXPR, SMIN, SMINPR, + $ SVLMAX, S1, S2, SI, T, TT +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2 + EXTERNAL DLAMCH, DLANGE, DLAPY2, DNRM2, IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DLARF, DLARFG, DLARTG, DLASET, DROT, + $ DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +C +C .. Executable Statements .. +C +C Decode COMPQ. +C + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'U' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +C +C Decode COMPZ. +C + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'U' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF +C +C Test the input scalar parameters. +C + INFO = 0 + IF( ICOMPQ.LE.0 ) THEN + INFO = -1 + ELSE IF( ICOMPZ.LE.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( N1.LT.0 .OR. N1.GT.MIN( L, N ) ) THEN + INFO = -7 + ELSE IF( LBE.LT.0 .OR. LBE.GT.MAX( 0, N1-1 ) ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -10 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -12 + ELSE IF( LDB.LT.MAX( 1, L ) ) THEN + INFO = -14 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN + INFO = -18 + ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -20 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -24 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01HX', -INFO ) + RETURN + END IF +C +C Initialize Q and Z if necessary. +C + IF( ICOMPQ.EQ.3 ) + $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) + IF( ICOMPZ.EQ.3 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +C +C Initialize output variables. +C + NR = 0 + NRBLCK = 0 +C +C Quick return if possible. +C + IF( M.EQ.0 .OR. N1.EQ.0 ) THEN + RETURN + END IF +C + WITHC = P.GT.0 + SVLMAX = DLAPY2( DLANGE( 'F', L, M, B, LDB, DWORK ), + $ DLANGE( 'F', L, N, A, LDA, DWORK ) ) + RCOND = TOL + IF ( RCOND.LE.ZERO ) THEN +C +C Use the default tolerance in controllability determination. +C + RCOND = DBLE( L*N )*DLAMCH( 'EPSILON' ) + END IF +C + IF ( SVLMAX.LT.RCOND ) + $ SVLMAX = ONE +C +C Reduce E to upper triangular form if necessary. +C + IF( LBE.GT.0 ) THEN + DO 10 I = 1, N1-1 +C +C Generate elementary reflector H(i) to annihilate +C E(i+1:i+lbe,i). +C + K = MIN( LBE, N1-I ) + 1 + CALL DLARFG( K, E(I,I), E(I+1,I), 1, TT ) + T = E(I,I) + E(I,I) = ONE +C +C Apply H(i) to E(i:n1,i+1:n) from the left. +C + CALL DLARF( 'Left', K, N-I, E(I,I), 1, TT, + $ E(I,I+1), LDE, DWORK ) +C +C Apply H(i) to A(i:n1,1:n) from the left. +C + CALL DLARF( 'Left', K, N, E(I,I), 1, TT, + $ A(I,1), LDA, DWORK ) +C +C Apply H(i) to B(i:n1,1:m) from the left. +C + CALL DLARF( 'Left', K, M, E(I,I), 1, TT, + $ B(I,1), LDB, DWORK ) + IF( ILQ ) THEN +C +C Apply H(i) to Q(1:l,i:n1) from the right. +C + CALL DLARF( 'Right', L, K, E(I,I), 1, TT, + $ Q(1,I), LDQ, DWORK ) + END IF + E(I,I) = T + 10 CONTINUE + IF( N1.GT.1 ) + $ CALL DLASET( 'Lower', N1-1, N1-1, ZERO, ZERO, E(2,1), LDE ) + END IF +C + ISMIN = 1 + ISMAX = ISMIN + M + IC = -M + TAUIM1 = M + NF = N1 +C + 20 CONTINUE + NRBLCK = NRBLCK + 1 + RANK = 0 + IF( NF.GT.0 ) THEN +C +C IROW will point to the current pivot line in B, +C ICOL+1 will point to the first active columns of A. +C + ICOL = IC + TAUIM1 + IROW = NR + NR1 = NR + 1 + IF( NR.GT.0 ) + $ CALL DLACPY( 'Full', NF, TAUIM1, A(NR1,IC+1), LDA, + $ B(NR1,1), LDB ) +C +C Perform QR-decomposition with column pivoting on the current B +C while keeping E upper triangular. +C The current B is at first iteration B and for subsequent +C iterations the NF-by-TAUIM1 matrix delimited by rows +C NR + 1 to N1 and columns IC + 1 to IC + TAUIM1 of A. +C The rank of current B is computed in RANK. +C + IF( TAUIM1.GT.1 ) THEN +C +C Compute column norms. +C + DO 30 J = 1, TAUIM1 + DWORK(J) = DNRM2( NF, B(NR1,J), 1 ) + DWORK(M+J) = DWORK(J) + IWORK(J) = J + 30 CONTINUE + END IF +C + MN = MIN( NF, TAUIM1 ) +C + 40 CONTINUE + IF( RANK.LT.MN ) THEN + J = RANK + 1 + IROW = IROW + 1 +C +C Pivot if necessary. +C + IF( J.NE.TAUIM1 ) THEN + K = ( J - 1 ) + IDAMAX( TAUIM1-J+1, DWORK(J), 1 ) + IF( K.NE.J ) THEN + CALL DSWAP( NF, B(NR1,J), 1, B(NR1,K), 1 ) + I = IWORK(K) + IWORK(K) = IWORK(J) + IWORK(J) = I + DWORK(K) = DWORK(J) + DWORK(M+K) = DWORK(M+J) + END IF + END IF +C +C Zero elements below the current diagonal element of B. +C + DO 50 I = N1-1, IROW, -1 +C +C Rotate rows I and I+1 to zero B(I+1,J). +C + T = B(I,J) + CALL DLARTG( T, B(I+1,J), CO, SI, B(I,J) ) + B(I+1,J) = ZERO + CALL DROT( N-I+1, E(I,I), LDE, E(I+1,I), LDE, CO, SI ) + IF( J.LT.TAUIM1 ) + $ CALL DROT( TAUIM1-J, B(I,J+1), LDB, + $ B(I+1,J+1), LDB, CO, SI ) + CALL DROT( N-ICOL, A(I,ICOL+1), LDA, + $ A(I+1,ICOL+1), LDA, CO, SI ) + IF( ILQ ) CALL DROT( L, Q(1,I), 1, Q(1,I+1), 1, CO, SI ) +C +C Rotate columns I, I+1 to zero E(I+1,I). +C + T = E(I+1,I+1) + CALL DLARTG( T, E(I+1,I), CO, SI, E(I+1,I+1) ) + E(I+1,I) = ZERO + CALL DROT( I, E(1,I+1), 1, E(1,I), 1, CO, SI ) + CALL DROT( N1, A(1,I+1), 1, A(1,I), 1, CO, SI ) + IF( ILZ ) CALL DROT( N, Z(1,I+1), 1, Z(1,I), 1, CO, SI ) + IF( WITHC ) + $ CALL DROT( P, C(1,I+1), 1, C(1,I), 1, CO, SI ) + 50 CONTINUE +C + IF( RANK.EQ.0 ) THEN +C +C Initialize; exit if matrix is zero (RANK = 0). +C + SMAX = ABS( B(NR1,1) ) + IF ( SMAX.EQ.ZERO ) GO TO 80 + SMIN = SMAX + SMAXPR = SMAX + SMINPR = SMIN + C1 = ONE + C2 = ONE + ELSE +C +C One step of incremental condition estimation. +C + CALL DLAIC1( IMIN, RANK, DWORK(ISMIN), SMIN, + $ B(NR1,J), B(IROW,J), SMINPR, S1, C1 ) + CALL DLAIC1( IMAX, RANK, DWORK(ISMAX), SMAX, + $ B(NR1,J), B(IROW,J), SMAXPR, S2, C2 ) + END IF +C +C Check the rank; finish the loop if rank loss occurs. +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN +C +C Finish the loop if last row. +C + IF( IROW.EQ.N1 ) THEN + RANK = RANK + 1 + GO TO 80 + END IF +C +C Update partial column norms. +C + DO 60 I = J + 1, TAUIM1 + IF( DWORK(I).NE.ZERO ) THEN + T = ONE - ( ABS( B(IROW,I) )/DWORK(I) )**2 + T = MAX( T, ZERO ) + TT = ONE + P05*T*( DWORK(I)/DWORK(M+I) )**2 + IF( TT.NE.ONE ) THEN + DWORK(I) = DWORK(I)*SQRT( T ) + ELSE + DWORK(I) = DNRM2( NF-J, B(IROW+1,I), 1 ) + DWORK(M+I) = DWORK(I) + END IF + END IF + 60 CONTINUE +C + DO 70 I = 1, RANK + DWORK(ISMIN+I-1) = S1*DWORK(ISMIN+I-1) + DWORK(ISMAX+I-1) = S2*DWORK(ISMAX+I-1) + 70 CONTINUE +C + DWORK(ISMIN+RANK) = C1 + DWORK(ISMAX+RANK) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + GO TO 40 + END IF + END IF + END IF + IF( NR.GT.0 ) THEN + CALL DLASET( 'Full', N1-IROW+1, TAUIM1-J+1, ZERO, ZERO, + $ B(IROW,J), LDB ) + END IF + GO TO 80 + END IF + END IF +C + 80 IF( RANK.GT.0 ) THEN + RTAU(NRBLCK) = RANK +C +C Back permute interchanged columns. +C + IF( TAUIM1.GT.1 ) THEN + DO 100 J = 1, TAUIM1 + IF( IWORK(J).GT.0 ) THEN + K = IWORK(J) + IWORK(J) = -K + 90 CONTINUE + IF( K.NE.J ) THEN + CALL DSWAP( RANK, B(NR1,J), 1, B(NR1,K), 1 ) + IWORK(K) = -IWORK(K) + K = -IWORK(K) + GO TO 90 + END IF + END IF + 100 CONTINUE + END IF + END IF + IF( NR.GT.0 ) + $ CALL DLACPY( 'Full', NF, TAUIM1, B(NR1,1), LDB, + $ A(NR1,IC+1), LDA ) + IF( RANK.GT.0 ) THEN + NR = NR + RANK + NF = NF - RANK + IC = IC + TAUIM1 + TAUIM1 = RANK + GO TO 20 + ELSE + NRBLCK = NRBLCK - 1 + END IF +C + IF( NRBLCK.GT.0 ) RANK = RTAU(1) + IF( RANK.LT.N1 ) + $ CALL DLASET( 'Full', N1-RANK, M, ZERO, ZERO, B(RANK+1,1), LDB ) +C + RETURN +C *** Last line of TG01HX *** + END diff --git a/mex/sources/libslicot/TG01ID.f b/mex/sources/libslicot/TG01ID.f new file mode 100644 index 000000000..dfd3888a3 --- /dev/null +++ b/mex/sources/libslicot/TG01ID.f @@ -0,0 +1,587 @@ + SUBROUTINE TG01ID( JOBOBS, COMPQ, COMPZ, N, M, P, A, LDA, E, LDE, + $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, NOBSV, NIUOBS, + $ NLBLCK, CTAU, TOL, IWORK, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute orthogonal transformation matrices Q and Z which +C reduce the N-th order descriptor system (A-lambda*E,B,C) +C to the form +C +C ( Ano * ) ( Eno * ) ( Bno ) +C Q'*A*Z = ( ) , Q'*E*Z = ( ) , Q'*B = ( ) , +C ( 0 Ao ) ( 0 Eo ) ( Bo ) +C +C C*Z = ( 0 Co ) , +C +C where the NOBSV-th order descriptor system (Ao-lambda*Eo,Bo,Co) +C is a finite and/or infinite observable. The pencil +C Ano - lambda*Eno is regular of order N-NOBSV and contains the +C unobservable finite and/or infinite eigenvalues of the pencil +C A-lambda*E. +C +C For JOBOBS = 'O' or 'I', the pencil ( Eo-lambda*Ao ) has full +C ( Co ) +C column rank NOBSV for all finite lambda and is in a staircase form +C with +C _ _ _ _ +C ( Ek,k Ek,k-1 ... Ek,2 Ek,1 ) +C ( _ _ _ _ ) +C ( Eo ) = ( Ek-1,k Ek-1,k-1 ... Ek-1,2 Ek-1,1 ) , (1) +C ( Co ) ( ... ... _ _ ) +C ( 0 0 ... E1,2 E1,1 ) +C ( _ ) +C ( 0 0 ... 0 E0,1 ) +C _ _ _ +C ( Ak,k ... Ak,2 Ak,1 ) +C ( ... _ _ ) +C Ao = ( 0 ... A2,2 A2,1 ) , (2) +C ( _ ) +C ( 0 ... 0 A1,1 ) +C _ +C where Ei-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix +C _ +C (with CTAU(0) = P) and Ai,i is a CTAU(i)-by-CTAU(i) +C upper triangular matrix. +C +C For JOBOBS = 'F', the pencil ( Ao-lambda*Eo ) has full +C ( Co ) +C column rank NOBSV for all finite lambda and is in a staircase form +C with +C _ _ _ _ +C ( Ak,k Ak,k-1 ... Ak,2 Ak,1 ) +C ( _ _ _ _ ) +C ( Ao ) = ( Ak-1,k Ak-1,k-1 ... Ak-1,2 Ak-1,1 ) , (3) +C ( Co ) ( ... ... _ _ ) +C ( 0 0 ... A1,2 A1,1 ) +C ( _ ) +C ( 0 0 ... 0 A0,1 ) +C _ _ _ +C ( Ek,k ... Ek,2 Ek,1 ) +C ( ... _ _ ) +C Eo = ( 0 ... E2,2 E2,1 ) , (4) +C ( _ ) +C ( 0 ... 0 E1,1 ) +C _ +C where Ai-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix +C _ +C (with CTAU(0) = P) and Ei,i is a CTAU(i)-by-CTAU(i) +C upper triangular matrix. +C +C For JOBOBS = 'O', the (N-NOBSV)-by-(N-NOBSV) regular pencil +C Ano - lambda*Eno has the form +C +C ( Afno - lambda*Efno * ) +C Ano - lambda*Eno = ( ) , +C ( 0 Aino - lambda*Eino ) +C +C where: +C 1) the NIUOBS-by-NIUOBS regular pencil Aino - lambda*Eino, +C with Aino upper triangular and nonsingular, contains the +C unobservable infinite eigenvalues of A - lambda*E; +C 2) the (N-NOBSV-NIUOBS)-by-(N-NOBSV-NIUOBS) regular pencil +C Afno - lambda*Efno, with Efno upper triangular and +C nonsingular, contains the unobservable finite +C eigenvalues of A - lambda*E. +C +C Note: The significance of the two diagonal blocks can be +C interchanged by calling the routine with the +C arguments A and E interchanged. In this case, +C Aino - lambda*Eino contains the unobservable zero +C eigenvalues of A - lambda*E, while Afno - lambda*Efno +C contains the unobservable nonzero finite and infinite +C eigenvalues of A - lambda*E. +C +C For JOBOBS = 'F', the pencil Ano - lambda*Eno has the form +C +C Ano - lambda*Eno = Afno - lambda*Efno , +C +C where the regular pencil Afno - lambda*Efno, with Efno +C upper triangular and nonsingular, contains the unobservable +C finite eigenvalues of A - lambda*E. +C +C For JOBOBS = 'I', the pencil Ano - lambda*Eno has the form +C +C Ano - lambda*Eno = Aino - lambda*Eino , +C +C where the regular pencil Aino - lambda*Eino, with Aino +C upper triangular and nonsingular, contains the unobservable +C nonzero finite and infinite eigenvalues of A - lambda*E. +C +C The left and/or right orthogonal transformations Q and Z +C performed to reduce the system matrices can be optionally +C accumulated. +C +C The reduced order descriptor system (Ao-lambda*Eo,Bo,Co) has +C the same transfer-function matrix as the original system +C (A-lambda*E,B,C). +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBOBS CHARACTER*1 +C = 'O': separate both finite and infinite unobservable +C eigenvalues; +C = 'F': separate only finite unobservable eigenvalues; +C = 'I': separate only nonzero finite and infinite +C unobservable eigenvalues. +C +C COMPQ CHARACTER*1 +C = 'N': do not compute Q; +C = 'I': Q is initialized to the unit matrix, and the +C orthogonal matrix Q is returned; +C = 'U': Q must contain an orthogonal matrix Q1 on entry, +C and the product Q1*Q is returned. +C +C COMPZ CHARACTER*1 +C = 'N': do not compute Z; +C = 'I': Z is initialized to the unit matrix, and the +C orthogonal matrix Z is returned; +C = 'U': Z must contain an orthogonal matrix Z1 on entry, +C and the product Z1*Z is returned. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the descriptor state vector; also the +C order of square matrices A and E, the number of rows of +C matrix B, and the number of columns of matrix C. N >= 0. +C +C M (input) INTEGER +C The dimension of descriptor system input vector; also the +C number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The dimension of descriptor system output vector; also the +C number of rows of matrix C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the N-by-N state matrix A. +C On exit, the leading N-by-N part of this array contains +C the transformed state matrix Q'*A*Z, +C +C ( Ano * ) +C Q'*A*Z = ( ) , +C ( 0 Ao ) +C +C where Ao is NOBSV-by-NOBSV and Ano is +C (N-NOBSV)-by-(N-NOBSV). +C If JOBOBS = 'F', the matrix ( Ao ) is in the observability +C ( Co ) +C staircase form (3). +C If JOBOBS = 'O' or 'I', the submatrix Ao is upper +C triangular. +C If JOBOBS = 'O', the submatrix Ano has the form +C +C ( Afno * ) +C Ano = ( ) , +C ( 0 Aino ) +C +C where the NIUOBS-by-NIUOBS matrix Aino is nonsingular and +C upper triangular. +C If JOBOBS = 'I', Ano is nonsingular and upper triangular. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the N-by-N descriptor matrix E. +C On exit, the leading N-by-N part of this array contains +C the transformed state matrix Q'*E*Z, +C +C ( Eno * ) +C Q'*E*Z = ( ) , +C ( 0 Eo ) +C +C where Eo is NOBSV-by-NOBSV and Eno is +C (N-NOBSV)-by-(N-NOBSV). +C If JOBOBS = 'O' or 'I', the matrix ( Eo ) is in the +C ( Co ) +C observability staircase form (1). +C If JOBOBS = 'F', the submatrix Eo is upper triangular. +C If JOBOBS = 'O', the Eno matrix has the form +C +C ( Efno * ) +C Eno = ( ) , +C ( 0 Eino ) +C +C where the NIUOBS-by-NIUOBS matrix Eino is nilpotent +C and the (N-NOBSV-NIUOBS)-by-(N-NOBSV-NIUOBS) matrix Efno +C is nonsingular and upper triangular. +C If JOBOBS = 'F', Eno is nonsingular and upper triangular. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,MAX(M,P)) +C On entry, the leading N-by-M part of this array must +C contain the N-by-M input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed input matrix Q'*B. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,N) if M > 0 or LDB >= 1 if M = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed matrix +C +C C*Z = ( 0 Co ) , +C +C where Co is P-by-NOBSV. +C If JOBOBS = 'O' or 'I', the matrix ( Eo ) is in the +C ( Co ) +C observability staircase form (1). +C If JOBOBS = 'F', the matrix ( Ao ) is in the observability +C ( Co ) +C staircase form (3). +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M,P). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C If COMPQ = 'N': Q is not referenced. +C If COMPQ = 'I': on entry, Q need not be set; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix Q, +C where Q' is the product of transformations +C which are applied to A, E, and B on +C the left. +C If COMPQ = 'U': on entry, the leading N-by-N part of this +C array must contain an orthogonal matrix +C Qc; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix +C Qc*Q. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= 1, if COMPQ = 'N'; +C LDQ >= MAX(1,N), if COMPQ = 'U' or 'I'. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C If COMPZ = 'N': Z is not referenced. +C If COMPZ = 'I': on entry, Z need not be set; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix Z, +C which is the product of transformations +C applied to A, E, and C on the right. +C If COMPZ = 'U': on entry, the leading N-by-N part of this +C array must contain an orthogonal matrix +C Zc; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix +C Zc*Z. +C +C LDZ INTEGER +C The leading dimension of array Z. +C LDZ >= 1, if COMPZ = 'N'; +C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. +C +C NOBSV (output) INTEGER +C The order of the reduced matrices Ao and Eo, and the +C number of columns of reduced matrix Co; also the order of +C observable part of the pair (C, A-lambda*E). +C +C NIUOBS (output) INTEGER +C For JOBOBS = 'O', the order of the reduced matrices +C Aino and Eino; also the number of unobservable +C infinite eigenvalues of the pencil A - lambda*E. +C For JOBOBS = 'F' or 'I', NIUOBS has no significance +C and is set to zero. +C +C NLBLCK (output) INTEGER +C For JOBOBS = 'O' or 'I', the number k, of full column rank +C _ +C blocks Ei-1,i in the staircase form of the pencil +C (Eo-lambda*Ao) (see (1) and (2)). +C ( Co ) +C For JOBOBS = 'F', the number k, of full column rank blocks +C _ +C Ai-1,i in the staircase form of the pencil (Ao-lambda*Eo) +C ( Co ) +C (see (3) and (4)). +C +C CTAU (output) INTEGER array, dimension (N) +C CTAU(i), for i = 1, ..., NLBLCK, is the column dimension +C _ _ +C of the full column rank block Ei-1,i or Ai-1,i in the +C staircase form (1) or (3) for JOBOBS = 'O' or 'I', or +C for JOBOBS = 'F', respectively. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determinations when +C transforming (A'-lambda*E',C')'. If the user sets TOL > 0, +C then the given value of TOL is used as a lower bound for +C reciprocal condition numbers in rank determinations; a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*N*EPS, is used instead, where EPS +C is the machine precision (see LAPACK Library routine +C DLAMCH). TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (P) +C +C DWORK DOUBLE PRECISION array, dimension MAX(N,2*P) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The subroutine is based on the dual of the reduction +C algorithms of [1]. +C +C REFERENCES +C +C [1] A. Varga +C Computation of Irreducible Generalized State-Space +C Realizations. +C Kybernetika, vol. 26, pp. 89-106, 1990. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( N**3 ) floating point operations. +C +C FURTHER COMMENTS +C +C If the system matrices A, E and C are badly scaled, it is +C generally recommendable to scale them with the SLICOT routine +C TG01AD, before calling TG01ID. +C +C CONTRIBUTOR +C +C C. Oara, University "Politehnica" Bucharest. +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. Based on the RASP routine RPDSCF. +C +C REVISIONS +C +C July 1999, V. Sima, Research Institute for Informatics, Bucharest. +C May 2003, March 2004, V. Sima. +C +C KEYWORDS +C +C Observability, minimal realization, orthogonal canonical form, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ, JOBOBS + INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDZ, + $ M, N, NIUOBS, NLBLCK, NOBSV, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER CTAU( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), + $ Z( LDZ, * ) +C .. Local Scalars .. + CHARACTER JOBQ, JOBZ + LOGICAL FINOBS, ILQ, ILZ, INFOBS + INTEGER I, ICOMPQ, ICOMPZ, LBA, LBE, NR +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB07MD, DSWAP, MA02BD, MA02CD, TB01XD, + $ TG01HX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable Statements .. +C +C Decode JOBOBS. +C + IF( LSAME( JOBOBS, 'O') ) THEN + FINOBS = .TRUE. + INFOBS = .TRUE. + ELSE IF( LSAME( JOBOBS, 'F') ) THEN + FINOBS = .TRUE. + INFOBS = .FALSE. + ELSE IF( LSAME( JOBOBS, 'I') ) THEN + FINOBS = .FALSE. + INFOBS = .TRUE. + ELSE + FINOBS = .FALSE. + INFOBS = .FALSE. + END IF +C +C Decode COMPQ. +C + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'U' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +C +C Decode COMPZ. +C + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'U' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF +C +C Test the input scalar parameters. +C + INFO = 0 + IF( .NOT.FINOBS .AND. .NOT.INFOBS ) THEN + INFO = -1 + ELSE IF( ICOMPQ.LE.0 ) THEN + INFO = -2 + ELSE IF( ICOMPZ.LE.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, M, P ) ) THEN + INFO = -14 + ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN + INFO = -16 + ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -18 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -23 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01ID', -INFO ) + RETURN + END IF +C + JOBQ = COMPQ + JOBZ = COMPZ +C +C Build the dual system. +C + CALL AB07MD( 'Z', N, M, P, A, LDA, B, LDB, C, LDC, DUM, 1, + $ INFO ) + DO 10 I = 2, N + CALL DSWAP( I-1, E(I,1), LDE, E(1,I), 1 ) + 10 CONTINUE +C + IF( FINOBS ) THEN +C +C Perform finite observability form reduction. +C + CALL TG01HX( JOBZ, JOBQ, N, N, P, M, N, MAX( 0, N-1 ), A, LDA, + $ E, LDE, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NR, + $ NLBLCK, CTAU, TOL, IWORK, DWORK, INFO ) + IF( NLBLCK.GT.1 ) THEN + LBA = CTAU(1) + CTAU(2) - 1 + ELSE IF( NLBLCK.EQ.1 ) THEN + LBA = CTAU(1) - 1 + ELSE + LBA = 0 + END IF + IF( ILQ ) JOBQ = 'U' + IF( ILZ ) JOBZ = 'U' + LBE = 0 + ELSE + NR = N + LBA = MAX( 0, N-1 ) + LBE = LBA + END IF +C + IF( INFOBS ) THEN +C +C Perform infinite observability form reduction. +C + CALL TG01HX( JOBZ, JOBQ, N, N, P, M, NR, LBA, E, LDE, + $ A, LDA, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NOBSV, + $ NLBLCK, CTAU, TOL, IWORK, DWORK, INFO ) + IF( FINOBS ) THEN + NIUOBS = NR - NOBSV + ELSE + NIUOBS = 0 + END IF + IF( NLBLCK.GT.1 ) THEN + LBE = CTAU(1) + CTAU(2) - 1 + ELSE IF( NLBLCK.EQ.1 ) THEN + LBE = CTAU(1) - 1 + ELSE + LBE = 0 + END IF + LBA = 0 + ELSE + NOBSV = NR + NIUOBS = 0 + END IF +C +C Compute the pertransposed dual system exploiting matrix shapes. +C + LBA = MAX( LBA, NIUOBS-1, N-NOBSV-NIUOBS-1 ) + IF ( P.EQ.0 .OR. NR.EQ.0 ) + $ LBE = MAX( 0, N - 1 ) + CALL TB01XD( 'Z', N, P, M, LBA, MAX( 0, N-1 ), A, LDA, B, LDB, + $ C, LDC, DUM, 1, INFO ) + CALL MA02CD( N, LBE, MAX( 0, N-1 ), E, LDE ) + IF( ILZ ) CALL MA02BD( 'Right', N, N, Z, LDZ ) + IF( ILQ ) CALL MA02BD( 'Right', N, N, Q, LDQ ) + RETURN +C *** Last line of TG01ID *** + END diff --git a/mex/sources/libslicot/TG01JD.f b/mex/sources/libslicot/TG01JD.f new file mode 100644 index 000000000..93cecec4e --- /dev/null +++ b/mex/sources/libslicot/TG01JD.f @@ -0,0 +1,613 @@ + SUBROUTINE TG01JD( JOB, SYSTYP, EQUIL, N, M, P, A, LDA, E, LDE, + $ B, LDB, C, LDC, NR, INFRED, TOL, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a reduced (controllable, observable, or irreducible) +C descriptor representation (Ar-lambda*Er,Br,Cr) for an original +C descriptor representation (A-lambda*E,B,C). +C The pencil Ar-lambda*Er is in an upper block Hessenberg form, with +C either Ar or Er upper triangular. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Indicates whether the user wishes to remove the +C uncontrollable and/or unobservable parts as follows: +C = 'I': Remove both the uncontrollable and unobservable +C parts to get an irreducible descriptor +C representation; +C = 'C': Remove the uncontrollable part only to get a +C controllable descriptor representation; +C = 'O': Remove the unobservable part only to get an +C observable descriptor representation. +C +C SYSTYP CHARACTER*1 +C Indicates the type of descriptor system algorithm +C to be applied according to the assumed +C transfer-function matrix as follows: +C = 'R': Rational transfer-function matrix; +C = 'S': Proper (standard) transfer-function matrix; +C = 'P': Polynomial transfer-function matrix. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily scale +C the system (A-lambda*E,B,C) as follows: +C = 'S': Perform scaling; +C = 'N': Do not perform scaling. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the descriptor state vector; also the +C order of square matrices A and E, the number of rows of +C matrix B, and the number of columns of matrix C. N >= 0. +C +C M (input) INTEGER +C The dimension of descriptor system input vector; also the +C number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The dimension of descriptor system output vector; also the +C number of rows of matrix C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state matrix A. +C On exit, the leading NR-by-NR part of this array contains +C the reduced order state matrix Ar of an irreducible, +C controllable, or observable realization for the original +C system, depending on the value of JOB, JOB = 'I', +C JOB = 'C', or JOB = 'O', respectively. +C The matrix Ar is upper triangular if SYSTYP = 'R' or 'P'. +C If SYSTYP = 'S' and JOB = 'C', the matrix [Br Ar] +C is in a controllable staircase form (see TG01HD). +C If SYSTYP = 'S' and JOB = 'I' or 'O', the matrix ( Ar ) +C ( Cr ) +C is in an observable staircase form (see TG01HD). +C The block structure of staircase forms is contained +C in the leading INFRED(7) elements of IWORK. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the original descriptor matrix E. +C On exit, the leading NR-by-NR part of this array contains +C the reduced order descriptor matrix Er of an irreducible, +C controllable, or observable realization for the original +C system, depending on the value of JOB, JOB = 'I', +C JOB = 'C', or JOB = 'O', respectively. +C The resulting Er has INFRED(6) nonzero sub-diagonals. +C If at least for one k = 1,...,4, INFRED(k) >= 0, then the +C resulting Er is structured being either upper triangular +C or block Hessenberg, in accordance to the last +C performed order reduction phase (see METHOD). +C The block structure of staircase forms is contained +C in the leading INFRED(7) elements of IWORK. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M), +C if JOB = 'C', or (LDB,MAX(M,P)), otherwise. +C On entry, the leading N-by-M part of this array must +C contain the original input matrix B; if JOB = 'I', +C or JOB = 'O', the remainder of the leading N-by-MAX(M,P) +C part is used as internal workspace. +C On exit, the leading NR-by-M part of this array contains +C the reduced input matrix Br of an irreducible, +C controllable, or observable realization for the original +C system, depending on the value of JOB, JOB = 'I', +C JOB = 'C', or JOB = 'O', respectively. +C If JOB = 'C', only the first IWORK(1) rows of B are +C nonzero. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original output matrix C; if JOB = 'I', +C or JOB = 'O', the remainder of the leading MAX(M,P)-by-N +C part is used as internal workspace. +C On exit, the leading P-by-NR part of this array contains +C the transformed state/output matrix Cr of an irreducible, +C controllable, or observable realization for the original +C system, depending on the value of JOB, JOB = 'I', +C JOB = 'C', or JOB = 'O', respectively. +C If JOB = 'I', or JOB = 'O', only the last IWORK(1) columns +C (in the first NR columns) of C are nonzero. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,M,P) if N > 0. +C LDC >= 1 if N = 0. +C +C NR (output) INTEGER +C The order of the reduced descriptor representation +C (Ar-lambda*Er,Br,Cr) of an irreducible, controllable, +C or observable realization for the original system, +C depending on JOB = 'I', JOB = 'C', or JOB = 'O', +C respectively. +C +C INFRED (output) INTEGER array, dimension 7 +C This array contains information on performed reduction +C and on structure of resulting system matrices as follows: +C INFRED(k) >= 0 (k = 1, 2, 3, or 4) if Phase k of reduction +C (see METHOD) has been performed. In this +C case, INFRED(k) is the achieved order +C reduction in Phase k. +C INFRED(k) < 0 (k = 1, 2, 3, or 4) if Phase k was not +C performed. +C INFRED(5) - the number of nonzero sub-diagonals of A. +C INFRED(6) - the number of nonzero sub-diagonals of E. +C INFRED(7) - the number of blocks in the resulting +C staircase form at last performed reduction +C phase. The block dimensions are contained +C in the first INFRED(7) elements of IWORK. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determinations when +C transforming (A-lambda*E,B,C). If the user sets TOL > 0, +C then the given value of TOL is used as a lower bound for +C reciprocal condition numbers in rank determinations; a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*N*EPS, is used instead, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension N+MAX(M,P) +C On exit, if INFO = 0, the leading INFRED(7) elements of +C IWORK contain the orders of the diagonal blocks of +C Ar-lambda*Er. +C +C DWORK DOUBLE PRECISION array, dimension LDWORK +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(8*N,2*M,2*P), if EQUIL = 'S'; +C LDWORK >= MAX(N,2*M,2*P), if EQUIL = 'N'. +C If LDWORK >= MAX(2*N*N+N*M+N*P)+MAX(N,2*M,2*P) then more +C accurate results are to be expected by performing only +C those reductions phases (see METHOD), where effective +C order reduction occurs. This is achieved by saving the +C system matrices before each phase and restoring them if no +C order reduction took place. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The subroutine is based on the reduction algorithms of [1]. +C The order reduction is performed in 4 phases: +C Phase 1: Eliminate all finite uncontrolable eigenvalues. +C The resulting matrix ( Br Ar ) is in a controllable +C staircase form (see SLICOT Library routine TG01HD), and +C Er is upper triangular. +C This phase is performed if JOB = 'I' or 'C' and +C SYSTYP = 'R' or 'S'. +C Phase 2: Eliminate all infinite and finite nonzero uncontrollable +C eigenvalues. The resulting matrix ( Br Er ) is in a +C controllable staircase form (see TG01HD), and Ar is +C upper triangular. +C This phase is performed if JOB = 'I' or 'C' and +C SYSTYP = 'R' or 'P'. +C Phase 3: Eliminate all finite unobservable eigenvalues. +C The resulting matrix ( Ar ) is in an observable +C ( Cr ) +C staircase form (see SLICOT Library routine TG01ID), and +C Er is upper triangular. +C This phase is performed if JOB = 'I' or 'O' and +C SYSTYP = 'R' or 'S'. +C Phase 4: Eliminate all infinite and finite nonzero unobservable +C eigenvalues. The resulting matrix ( Er ) is in an +C ( Cr ) +C observable staircase form (see TG01ID), and Ar is +C upper triangular. +C This phase is performed if JOB = 'I' or 'O' and +C SYSTYP = 'R' or 'P'. +C +C REFERENCES +C +C [1] A. Varga +C Computation of Irreducible Generalized State-Space +C Realizations. +C Kybernetika, vol. 26, pp. 89-106, 1990. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( N**3 ) floating point operations. +C +C FURTHER COMMENTS +C +C If the pencil (A-lambda*E) has no zero eigenvalues, then an +C irreducible realization can be computed skipping Phases 1 and 3 +C by using the setting: JOB = 'I' and SYSTYP = 'P'. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C April 1999. Based on the RASP routine RPDSIR. +C +C REVISIONS +C +C July 1999, V. Sima, Research Institute for Informatics, Bucharest. +C May 2003, A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C May 2003, March 2004, V. Sima. +C +C KEYWORDS +C +C Controllability, irreducible realization, observability, +C orthogonal canonical form, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL, JOB, SYSTYP + INTEGER INFO, LDA, LDB, LDC, LDE, LDWORK, M, N, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER INFRED(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), E(LDE,*) +C .. Local Scalars .. + CHARACTER JOBQ, JOBZ + LOGICAL FINCON, FINOBS, INFCON, INFOBS, LEQUIL, LJOBC, + $ LJOBIR, LJOBO, LSPACE, LSYSP, LSYSR, LSYSS + INTEGER KWA, KWB, KWC, KWE, LBA, LBE, LDM, LDP, LDQ, + $ LDZ, M1, MAXMP, N1, NBLCK, NC, P1 +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, MA02CD, TB01XD, TG01AD, TG01HX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 + MAXMP = MAX( M, P ) + N1 = MAX( 1, N ) +C +C Decode JOB. +C + LJOBIR = LSAME( JOB, 'I' ) + LJOBC = LJOBIR .OR. LSAME( JOB, 'C' ) + LJOBO = LJOBIR .OR. LSAME( JOB, 'O' ) +C +C Decode SYSTYP. +C + LSYSR = LSAME( SYSTYP, 'R' ) + LSYSS = LSYSR .OR. LSAME( SYSTYP, 'S' ) + LSYSP = LSYSR .OR. LSAME( SYSTYP, 'P' ) +C + LEQUIL = LSAME( EQUIL, 'S' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBC .AND. .NOT.LJOBO ) THEN + INFO = -1 + ELSE IF( .NOT.LSYSS .AND. .NOT.LSYSP ) THEN + INFO = -2 + ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.N1 ) THEN + INFO = -8 + ELSE IF( LDE.LT.N1 ) THEN + INFO = -10 + ELSE IF( LDB.LT.N1 ) THEN + INFO = -12 + ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN + INFO = -14 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -17 + ELSE IF( ( .NOT.LEQUIL .AND. LDWORK.LT.MAX( N, 2*MAXMP ) ) .OR. + $ ( LEQUIL .AND. LDWORK.LT.MAX( 8*N, 2*MAXMP ) ) ) THEN + INFO = -20 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TG01JD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + INFRED(1) = -1 + INFRED(2) = -1 + INFRED(3) = -1 + INFRED(4) = -1 + INFRED(5) = 0 + INFRED(6) = 0 + INFRED(7) = 0 +C + IF( MAX( N, MAXMP ).EQ.0 ) THEN + NR = 0 + RETURN + END IF +C + M1 = MAX( 1, M ) + P1 = MAX( 1, P ) + LDM = MAX( LDC, M ) + LDP = MAX( LDC, P ) +C +C Set controllability/observability determination options. +C + FINCON = LJOBC .AND. LSYSS + INFCON = LJOBC .AND. LSYSP + FINOBS = LJOBO .AND. LSYSS + INFOBS = LJOBO .AND. LSYSP +C +C Set large workspace option and determine offsets. +C + LSPACE = LDWORK.GE.N*( 2*N + M + P ) + MAX( N, 2*MAXMP ) + KWA = MAX( N, 2*MAXMP ) + 1 + KWE = KWA + N*N + KWB = KWE + N*N + KWC = KWB + N*M +C +C If required, scale the system (A-lambda*E,B,C). +C Workspace: need 8*N. +C + IF( LEQUIL ) THEN + CALL TG01AD( 'All', N, N, M, P, ZERO, A, LDA, E, LDE, B, LDB, + $ C, LDP, DWORK(1), DWORK(N+1), DWORK(2*N+1), INFO ) + END IF +C + JOBQ = 'N' + JOBZ = 'N' + LDQ = 1 + LDZ = 1 + LBA = MAX( 0, N-1 ) + LBE = LBA + NC = N + NR = N +C + IF( FINCON ) THEN +C +C Phase 1: Eliminate all finite uncontrolable eigenvalues. +C + IF( LSPACE) THEN +C +C Save system matrices. +C + CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) + CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) + CALL DLACPY( 'Full', NC, M, B, LDB, DWORK(KWB), N1 ) + CALL DLACPY( 'Full', P, NC, C, LDC, DWORK(KWC), P1 ) + END IF +C +C Perform finite controllability form reduction. +C Workspace: need MAX(N,2*M). +C + CALL TG01HX( JOBQ, JOBZ, NC, NC, M, P, NC, LBE, A, LDA, + $ E, LDE, B, LDB, C, LDP, DUM, LDQ, DUM, LDZ, NR, + $ NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO ) + IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN + IF( NBLCK.GT.1 ) THEN + LBA = IWORK(1) + IWORK(2) - 1 + ELSE IF( NBLCK.EQ.1 ) THEN + LBA = IWORK(1) - 1 + ELSE + LBA = 0 + END IF + LBE = 0 + INFRED(1) = NC - NR + INFRED(7) = NBLCK + NC = NR + ELSE +C +C Restore system matrices. +C + CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) + CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) + CALL DLACPY( 'Full', NC, M, DWORK(KWB), N1, B, LDB ) + CALL DLACPY( 'Full', P, NC, DWORK(KWC), P1, C, LDC ) + END IF + END IF +C + IF( INFCON ) THEN +C +C Phase 2: Eliminate all infinite and all finite nonzero +C uncontrolable eigenvalues. +C + IF( LSPACE ) THEN +C +C Save system matrices. +C + CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) + CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) + CALL DLACPY( 'Full', NC, M, B, LDB, DWORK(KWB), N1 ) + CALL DLACPY( 'Full', P, NC, C, LDC, DWORK(KWC), P1 ) + END IF +C +C Perform infinite controllability form reduction. +C Workspace: need MAX(N,2*M). +C + CALL TG01HX( JOBQ, JOBZ, NC, NC, M, P, NC, LBA, E, LDE, + $ A, LDA, B, LDB, C, LDP, DUM, LDQ, DUM, LDZ, NR, + $ NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO ) + IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN + IF( NBLCK.GT.1 ) THEN + LBE = IWORK(1) + IWORK(2) - 1 + ELSE IF( NBLCK.EQ.1 ) THEN + LBE = IWORK(1) - 1 + ELSE + LBE = 0 + END IF + LBA = 0 + INFRED(2) = NC - NR + INFRED(7) = NBLCK + NC = NR + ELSE +C +C Restore system matrices. +C + CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) + CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) + CALL DLACPY( 'Full', NC, M, DWORK(KWB), N1, B, LDB ) + CALL DLACPY( 'Full', P, NC, DWORK(KWC), P1, C, LDC ) + END IF + END IF +C + IF( FINOBS .OR. INFOBS) THEN +C +C Compute the pertransposed dual system exploiting matrix shapes. +C + CALL TB01XD( 'Z', NC, M, P, LBA, MAX( 0, NC-1 ), A, LDA, + $ B, LDB, C, LDC, DUM, 1, INFO ) + CALL MA02CD( NC, LBE, MAX( 0, NC-1 ), E, LDE ) + END IF +C + IF( FINOBS ) THEN +C +C Phase 3: Eliminate all finite unobservable eigenvalues. +C + IF( LSPACE ) THEN +C +C Save system matrices. +C + CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) + CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) + CALL DLACPY( 'Full', NC, P, B, LDB, DWORK(KWC), N1 ) + CALL DLACPY( 'Full', M, NC, C, LDC, DWORK(KWB), M1 ) + END IF +C +C Perform finite observability form reduction. +C Workspace: need MAX(N,2*P). +C + CALL TG01HX( JOBZ, JOBQ, NC, NC, P, M, NC, LBE, A, LDA, + $ E, LDE, B, LDB, C, LDM, DUM, LDZ, DUM, LDQ, NR, + $ NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO ) + IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN + IF( NBLCK.GT.1 ) THEN + LBA = IWORK(1) + IWORK(2) - 1 + ELSE IF( NBLCK.EQ.1 ) THEN + LBA = IWORK(1) - 1 + ELSE + LBA = 0 + END IF + LBE = 0 + INFRED(3) = NC - NR + INFRED(7) = NBLCK + NC = NR + ELSE +C +C Restore system matrices. +C + CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) + CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) + CALL DLACPY( 'Full', NC, P, DWORK(KWC), N1, B, LDB ) + CALL DLACPY( 'Full', M, NC, DWORK(KWB), M1, C, LDC ) + END IF + END IF +C + IF( INFOBS ) THEN +C +C Phase 4: Eliminate all infinite and all finite nonzero +C unobservable eigenvalues. +C + IF( LSPACE) THEN +C +C Save system matrices. +C + CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) + CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) + CALL DLACPY( 'Full', NC, P, B, LDB, DWORK(KWC), N1 ) + CALL DLACPY( 'Full', M, NC, C, LDC, DWORK(KWB), M1 ) + END IF +C +C Perform infinite observability form reduction. +C Workspace: need MAX(N,2*P). +C + CALL TG01HX( JOBZ, JOBQ, NC, NC, P, M, NC, LBA, E, LDE, + $ A, LDA, B, LDB, C, LDM, DUM, LDZ, DUM, LDQ, NR, + $ NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO ) + IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN + IF( NBLCK.GT.1 ) THEN + LBE = IWORK(1) + IWORK(2) - 1 + ELSE IF( NBLCK.EQ.1 ) THEN + LBE = IWORK(1) - 1 + ELSE + LBE = 0 + END IF + LBA = 0 + INFRED(4) = NC - NR + INFRED(7) = NBLCK + NC = NR + ELSE +C +C Restore system matrices. +C + CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) + CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) + CALL DLACPY( 'Full', NC, P, DWORK(KWC), N1, B, LDB ) + CALL DLACPY( 'Full', M, NC, DWORK(KWB), M1, C, LDC ) + END IF + END IF +C + IF( FINOBS .OR. INFOBS ) THEN +C +C Compute the pertransposed dual system exploiting matrix shapes. +C + CALL TB01XD( 'Z', NC, P, M, LBA, MAX( 0, NC-1 ), A, LDA, + $ B, LDB, C, LDC, DUM, 1, INFO ) + CALL MA02CD( NC, LBE, MAX( 0, NC-1 ), E, LDE ) + END IF +C +C Set structural information on A and E. +C + INFRED(5) = LBA + INFRED(6) = LBE +C + RETURN +C *** Last line of TG01JD *** + END diff --git a/mex/sources/libslicot/TG01WD.f b/mex/sources/libslicot/TG01WD.f new file mode 100644 index 000000000..26d06848e --- /dev/null +++ b/mex/sources/libslicot/TG01WD.f @@ -0,0 +1,319 @@ + SUBROUTINE TG01WD( N, M, P, A, LDA, E, LDE, B, LDB, C, LDC, + $ Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the pair (A,E) to a real generalized Schur form +C by using an orthogonal equivalence transformation +C (A,E) <-- (Q'*A*Z,Q'*E*Z) and to apply the transformation +C to the matrices B and C: B <-- Q'*B and C <-- C*Z. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e., the order of the matrices A and E. N >= 0. +C +C M (input) INTEGER +C The number of system inputs, or of columns of B. M >= 0. +C +C P (input) INTEGER +C The number of system outputs, or of rows of C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading N-by-N part of this array contains +C the matrix Q' * A * Z in an upper quasi-triangular form. +C The elements below the first subdiagonal are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the original descriptor matrix E. +C On exit, the leading N-by-N part of this array contains +C the matrix Q' * E * Z in an upper triangular form. +C The elements below the diagonal are set to zero. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed input matrix Q' * B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed output matrix C * Z. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) +C The leading N-by-N part of this array contains the left +C orthogonal transformation matrix used to reduce (A,E) to +C the real generalized Schur form. +C The columns of Q are the left generalized Schur vectors +C of the pair (A,E). +C +C LDQ INTEGER +C The leading dimension of array Q. LDQ >= max(1,N). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C The leading N-by-N part of this array contains the right +C orthogonal transformation matrix used to reduce (A,E) to +C the real generalized Schur form. +C The columns of Z are the right generalized Schur vectors +C of the pair (A,E). +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= max(1,N). +C +C ALPHAR (output) DOUBLE PRECISION array, dimension (N) +C ALPHAI (output) DOUBLE PRECISION array, dimension (N) +C BETA (output) DOUBLE PRECISION array, dimension (N) +C On exit, if INFO = 0, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), +C j=1,...,N, will be the generalized eigenvalues. +C ALPHAR(j) + ALPHAI(j)*i, and BETA(j), j=1,...,N, are the +C diagonals of the complex Schur form that would result if +C the 2-by-2 diagonal blocks of the real Schur form of +C (A,E) were further reduced to triangular form using +C 2-by-2 complex unitary transformations. +C If ALPHAI(j) is zero, then the j-th eigenvalue is real; +C if positive, then the j-th and (j+1)-st eigenvalues are a +C complex conjugate pair, with ALPHAI(j+1) negative. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. LDWORK >= 8*N+16. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, the QZ algorithm failed to compute +C the generalized real Schur form; elements i+1:N of +C ALPHAR, ALPHAI, and BETA should be correct. +C +C METHOD +C +C The pair (A,E) is reduced to a real generalized Schur form using +C an orthogonal equivalence transformation (A,E) <-- (Q'*A*Z,Q'*E*Z) +C and the transformation is applied to the matrices B and C: +C B <-- Q'*B and C <-- C*Z. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires about 25N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. +C +C KEYWORDS +C +C Orthogonal transformation, generalized real Schur form, similarity +C transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDWORK, LDZ, + $ M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), + $ BETA(*), C(LDC,*), DWORK(*), E(LDE,*), + $ Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL BLAS3, BLOCK + INTEGER BL, CHUNK, I, J, MAXWRK, SDIM +C .. Local Arrays .. + LOGICAL BWORK(1) +C .. External Functions .. + LOGICAL LSAME, DELCTG + EXTERNAL LSAME, DELCTG +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DGGES, DLACPY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C +C .. Executable Statements .. +C + INFO = 0 +C +C Check the scalar input parameters. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDWORK.LT.8*N+16 ) THEN + INFO = -20 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TG01WD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Reduce (A,E) to real generalized Schur form using an orthogonal +C equivalence transformation (A,E) <-- (Q'*A*Z,Q'*E*Z), accumulate +C the transformations in Q and Z, and compute the generalized +C eigenvalues of the pair (A,E) in (ALPHAR, ALPHAI, BETA). +C +C Workspace: need 8*N+16; +C prefer larger. +C + CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, N, + $ A, LDA, E, LDE, SDIM, ALPHAR, ALPHAI, BETA, Q, LDQ, + $ Z, LDZ, DWORK, LDWORK, BWORK, INFO ) + IF( INFO.NE.0 ) + $ RETURN + MAXWRK = INT( DWORK(1) ) +C +C Apply the transformation: B <-- Q'*B. Use BLAS 3, if enough space. +C + CHUNK = LDWORK / N + BLOCK = M.GT.1 + BLAS3 = CHUNK.GE.M .AND. BLOCK +C + IF( BLAS3 ) THEN +C +C Enough workspace for a fast BLAS 3 algorithm. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, Q, LDQ, + $ DWORK, N, ZERO, B, LDB ) +C + ELSE IF ( BLOCK ) THEN +C +C Use as many columns of B as possible. +C + DO 10 J = 1, M, CHUNK + BL = MIN( M-J+1, CHUNK ) + CALL DLACPY( 'Full', N, BL, B(1,J), LDB, DWORK, N ) + CALL DGEMM( 'Transpose', 'NoTranspose', N, BL, N, ONE, Q, + $ LDQ, DWORK, N, ZERO, B(1,J), LDB ) + 10 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. Here, M <= 1. +C + IF ( M.GT.0 ) THEN + CALL DCOPY( N, B, 1, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, Q, LDQ, DWORK, 1, ZERO, + $ B, 1 ) + END IF + END IF + MAXWRK = MAX( MAXWRK, N*M ) +C +C Apply the transformation: C <-- C*Z. Use BLAS 3, if enough space. +C + BLOCK = P.GT.1 + BLAS3 = CHUNK.GE.P .AND. BLOCK +C + IF ( BLAS3 ) THEN + CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P ) + CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, + $ DWORK, P, Z, LDZ, ZERO, C, LDC ) +C + ELSE IF ( BLOCK ) THEN +C +C Use as many rows of C as possible. +C + DO 20 I = 1, P, CHUNK + BL = MIN( P-I+1, CHUNK ) + CALL DLACPY( 'Full', BL, N, C(I,1), LDC, DWORK, BL ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, N, N, ONE, + $ DWORK, BL, Z, LDZ, ZERO, C(I,1), LDC ) + 20 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. Here, P <= 1. +C + IF ( P.GT.0 ) THEN + CALL DCOPY( N, C, LDC, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, Z, LDZ, DWORK, 1, ZERO, + $ C, LDC ) + END IF +C + END IF + MAXWRK = MAX( MAXWRK, P*N ) +C + DWORK(1) = DBLE( MAXWRK ) +C + RETURN +C *** Last line of TG01WD *** + END diff --git a/mex/sources/libslicot/UD01BD.f b/mex/sources/libslicot/UD01BD.f new file mode 100644 index 000000000..256984c17 --- /dev/null +++ b/mex/sources/libslicot/UD01BD.f @@ -0,0 +1,149 @@ + SUBROUTINE UD01BD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To read the coefficients of a matrix polynomial +C dp-1 dp +C P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s + P(dp) * s . +C +C ARGUMENTS +C +C Input/Output Parameters +C +C MP (input) INTEGER +C The number of rows of the matrix polynomial P(s). +C MP >= 1. +C +C NP (input) INTEGER +C The number of columns of the matrix polynomial P(s). +C NP >= 1. +C +C DP (input) INTEGER +C The degree of the matrix polynomial P(s). DP >= 0. +C +C NIN (input) INTEGER +C The input channel from which the elements of P(s) are +C read. NIN >= 0. +C +C P (output) DOUBLE PRECISION array, dimension +C (LDP1,LDP2,DP+1) +C The leading MP-by-NP-by-(DP+1) part of this array contains +C the coefficients of the matrix polynomial P(s). +C Specifically, P(i,j,k) contains the coefficient of +C s**(k-1) of the polynomial which is the (i,j)-th element +C of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and +C k = 1,2,...,DP+1. +C +C LDP1 INTEGER +C The leading dimension of array P. LDP1 >= MP. +C +C LDP2 INTEGER +C The second dimension of array P. LDP2 >= NP. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The coefficients P(i), i = 0, ..., DP, which are MP-by-NP +C matrices, are read from the input file NIN row by row. Each P(i) +C must be preceded by a text line. This text line can be used to +C indicate the coefficient matrices. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C Based on routine RDMAPO by A.J. Geurts, Eindhoven University of +C Technology, Holland. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER DP, INFO, LDP1, LDP2, MP, NP, NIN +C .. Array Arguments .. + DOUBLE PRECISION P(LDP1,LDP2,*) +C .. Local Scalars .. + INTEGER I, J, K +C .. External Subroutines .. + EXTERNAL XERBLA +C +C .. Executable Statements .. +C + INFO = 0 +C +C Check the input scalar arguments. +C + IF( MP.LT.1 ) THEN + INFO = -1 + ELSE IF( NP.LT.1 ) THEN + INFO = -2 + ELSE IF( DP.LT.0 ) THEN + INFO = -3 + ELSE IF( NIN.LT.0 ) THEN + INFO = -4 + ELSE IF( LDP1.LT.MP ) THEN + INFO = -6 + ELSE IF( LDP2.LT.NP ) THEN + INFO = -7 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'UD01BD', -INFO ) + RETURN + END IF +C +C Skip the text line preceding P(i) and read P(i), i = 0, ..., DP, +C row after row. +C + DO 20 K = 1, DP + 1 + READ ( NIN, FMT = '()' ) +C + DO 10 I = 1, MP + READ ( NIN, FMT = * ) ( P(I,J,K), J = 1, NP ) + 10 CONTINUE +C + 20 CONTINUE +C + RETURN +C *** Last line of UD01BD *** + END diff --git a/mex/sources/libslicot/UD01CD.f b/mex/sources/libslicot/UD01CD.f new file mode 100644 index 000000000..52a104558 --- /dev/null +++ b/mex/sources/libslicot/UD01CD.f @@ -0,0 +1,174 @@ + SUBROUTINE UD01CD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To read the elements of a sparse matrix polynomial +C dp-1 dp +C P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s + P(dp) * s . +C +C ARGUMENTS +C +C Input/Output Parameters +C +C MP (input) INTEGER +C The number of rows of the matrix polynomial P(s). +C MP >= 1. +C +C NP (input) INTEGER +C The number of columns of the matrix polynomial P(s). +C NP >= 1. +C +C DP (input) INTEGER +C The degree of the matrix polynomial P(s). DP >= 0. +C +C NIN (input) INTEGER +C The input channel from which the elements of P(s) are +C read. NIN >= 0. +C +C P (output) DOUBLE PRECISION array, dimension +C (LDP1,LDP2,DP+1) +C The leading MP-by-NP-by-(DP+1) part of this array contains +C the coefficients of the matrix polynomial P(s). +C Specifically, P(i,j,k) contains the coefficient of +C s**(k-1) of the polynomial which is the (i,j)-th element +C of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and +C k = 1,2,...,DP+1. +C The not assigned elements are set to zero. +C +C LDP1 INTEGER +C The leading dimension of array P. LDP1 >= MP. +C +C LDP2 INTEGER +C The second dimension of array P. LDP2 >= NP. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1 : if a row index i is read with i < 1 or i > MP or +C a column index j is read with j < 1 or j > NP or +C a coefficient degree d is read with d < 0 or +C d > DP + 1. This is a warning. +C +C METHOD +C +C First, the elements P(i,j,k) with 1 <= i <= MP, 1 <= j <= NP and +C 1 <= k <= DP + 1 are set to zero. Next the nonzero (polynomial) +C elements are read from the input file NIN. Each nonzero element is +C given by the values i, j, d, P(i,j,k), k = 1, ..., d+1, where d is +C the degree and P(i,j,k) is the coefficient of s**(k-1) in the +C (i,j)-th element of P(s), i.e., let +C d +C P (s) = P (0) + P (1) * s + . . . + P (d) * s +C i,j i,j i,j i,j +C +C be the nonzero (i,j)-th element of the matrix polynomial P(s). +C +C Then P(i,j,k) corresponds to coefficient P (k-1), k = 1,...,d+1. +C i,j +C For each nonzero element, the values i, j, and d are read as one +C record of the file NIN, and the values P(i,j,k), k = 1,...,d+1, +C are read as the following record. +C The routine terminates after the last line has been read. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C Based on routine RDSPOM by A.J. Geurts, Eindhoven University of +C Technology, Holland. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER DP, INFO, LDP1, LDP2, MP, NP, NIN +C .. Array Arguments .. + DOUBLE PRECISION P(LDP1,LDP2,*) +C .. Local Scalars .. + INTEGER D, I, J, K +C .. External Subroutines .. + EXTERNAL DLASET, XERBLA +C +C .. Executable Statements .. +C + INFO = 0 +C +C Check the input scalar arguments. +C + IF( MP.LT.1 ) THEN + INFO = -1 + ELSE IF( NP.LT.1 ) THEN + INFO = -2 + ELSE IF( DP.LT.0 ) THEN + INFO = -3 + ELSE IF( NIN.LT.0 ) THEN + INFO = -4 + ELSE IF( LDP1.LT.MP ) THEN + INFO = -6 + ELSE IF( LDP2.LT.NP ) THEN + INFO = -7 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'UD01CD', -INFO ) + RETURN + END IF +C + DO 10 K = 1, DP+1 + CALL DLASET( 'Full', MP, NP, ZERO, ZERO, P(1,1,K), LDP1 ) + 10 CONTINUE +C +C Read (i, j, d, P(i,j,k), k=1,...,d+1) of the nonzero elements one +C by one. +C + 20 READ( NIN, FMT = *, END = 30 ) I, J, D + IF ( I.LT.1 .OR. I.GT.MP .OR. J.LT.1 .OR. J.GT.NP .OR. + $ D.LT.0 .OR. D.GT.(DP+1) ) THEN + INFO = 1 + READ ( NIN, FMT = * ) + ELSE + READ ( NIN, FMT = * ) ( P(I,J,K), K = 1, D+1 ) + END IF + GO TO 20 +C + 30 CONTINUE + RETURN +C *** Last line of UD01CD *** + END diff --git a/mex/sources/libslicot/UD01DD.f b/mex/sources/libslicot/UD01DD.f new file mode 100644 index 000000000..d09cadbd3 --- /dev/null +++ b/mex/sources/libslicot/UD01DD.f @@ -0,0 +1,138 @@ + SUBROUTINE UD01DD( M, N, NIN, A, LDA, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To read the elements of a sparse matrix. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C NIN (input) INTEGER +C The input channel from which the elements of A are read. +C NIN >= 0. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading M-by-N part of this array contains the sparse +C matrix A. The not assigned elements are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1 : if a row index i is read with i < 1 or i > M or +C a column index j is read with j < 1 or j > N. +C This is a warning. +C +C METHOD +C +C First, the elements A(i,j) with 1 <= i <= M and 1 <= j <= N are +C set to zero. Next the nonzero elements are read from the input +C file NIN. Each line of NIN must contain consecutively the values +C i, j, A(i,j). The routine terminates after the last line has been +C read. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C Based on routine RDSPAR by A.J. Geurts, Eindhoven University of +C Technology, Holland. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, M, N, NIN +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*) +C .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION AIJ +C .. External Subroutines .. + EXTERNAL DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable statements .. +C + INFO = 0 +C +C Check the input scalar arguments. +C + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NIN.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'UD01DD', -INFO ) + RETURN + END IF +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) +C +C Read (i, j, A(i,j)) of the nonzero elements one by one. +C + 10 READ( NIN, FMT = *, END = 20 ) I, J, AIJ + IF ( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN + INFO = 1 + ELSE + A(I,J) = AIJ + END IF + GO TO 10 + 20 CONTINUE +C + RETURN +C *** Last line of UD01DD *** + END diff --git a/mex/sources/libslicot/UD01MD.f b/mex/sources/libslicot/UD01MD.f new file mode 100644 index 000000000..a44e6545c --- /dev/null +++ b/mex/sources/libslicot/UD01MD.f @@ -0,0 +1,175 @@ + SUBROUTINE UD01MD( M, N, L, NOUT, A, LDA, TEXT, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To print an M-by-N real matrix A row by row. The elements of A +C are output to 7 significant figures. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of matrix A to be printed. M >= 1. +C +C N (input) INTEGER +C The number of columns of matrix A to be printed. N >= 1. +C +C L (input) INTEGER +C The number of elements of matrix A to be printed per line. +C 1 <= L <= 5. +C +C NOUT (input) INTEGER +C The output channel to which the results are sent. +C NOUT >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading M-by-N part of this array must contain the +C matrix to be printed. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= M. +C +C TEXT (input) CHARACTER*72. +C Title caption of the matrix to be printed (up to a +C maximum of 72 characters). For example, TEXT = 'Matrix A'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine first prints the contents of TEXT as a title, followed +C by the elements of the matrix A such that +C +C (i) if N <= L, the leading M-by-N part is printed; +C (ii) if N = k*L + p (where k,p > 0), then k M-by-L blocks of +C consecutive columns of A are printed one after another +C followed by one M-by-p block containing the last p columns +C of A. +C +C Row numbers are printed on the left of each row and a column +C number appears on top of each column. +C The routine uses 2 + (k + 1)*(m + 1) lines and 8 + 15*c positions +C per line where c is the actual number of columns, (i.e. c = L +C or c = p). +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1997. +C Supersedes Release 2.0 routine UD01AD by H. Willemsen, Eindhoven +C University of Technology, Holland. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2009. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INFO, L, LDA, M, N, NOUT + CHARACTER*(*) TEXT +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*) +C .. Local Scalars .. + INTEGER I, J, J1, J2, JJ, LENTXT, LTEXT, N1 +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC LEN, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( M.LT.1 ) THEN + INFO = -1 + ELSE IF( N.LT.1 ) THEN + INFO = -2 + ELSE IF( L.LT.1 .OR. L.GT.5 ) THEN + INFO = -3 + ELSE IF( NOUT.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.M ) THEN + INFO = -6 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'UD01MD', -INFO ) + RETURN + END IF +C + LENTXT = LEN( TEXT ) +C + DO 20 LTEXT = MIN( 72, LENTXT ), 2, -1 + IF ( TEXT(LTEXT:LTEXT).NE.' ' ) GO TO 40 + 20 CONTINUE +C + 40 CONTINUE + WRITE ( NOUT, FMT=99996 ) TEXT(1:LTEXT), M, N + N1 = ( N-1 )/L + J1 = 1 + J2 = L +C + DO 80 J = 1, N1 + WRITE ( NOUT, FMT=99999 ) ( JJ, JJ=J1, J2 ) +C + DO 60 I = 1, M + WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, J2 ) + 60 CONTINUE +C + WRITE ( NOUT, FMT=99998 ) + J1 = J1 + L + J2 = J2 + L + 80 CONTINUE +C + WRITE ( NOUT, FMT=99999 ) ( J, J=J1, N ) +C + DO 100 I = 1, M + WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, N ) + 100 CONTINUE +C + WRITE ( NOUT, FMT=99998 ) +C + RETURN +C +99999 FORMAT (8X,5(5X,I5,5X) ) +99998 FORMAT (' ' ) +99997 FORMAT (1X,I5,2X,5D15.7 ) +99996 FORMAT (1X,A,' (',I5,'X',I5,')',/ ) +C *** Last line of UD01MD *** + END diff --git a/mex/sources/libslicot/UD01MZ.f b/mex/sources/libslicot/UD01MZ.f new file mode 100644 index 000000000..a9d83f706 --- /dev/null +++ b/mex/sources/libslicot/UD01MZ.f @@ -0,0 +1,175 @@ + SUBROUTINE UD01MZ( M, N, L, NOUT, A, LDA, TEXT, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To print an M-by-N real matrix A row by row. The elements of A +C are output to 7 significant figures. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of matrix A to be printed. M >= 1. +C +C N (input) INTEGER +C The number of columns of matrix A to be printed. N >= 1. +C +C L (input) INTEGER +C The number of elements of matrix A to be printed per line. +C 1 <= L <= 3. +C +C NOUT (input) INTEGER +C The output channel to which the results are sent. +C NOUT >= 0. +C +C A (input) COMPLEX*16 array, dimension (LDA,N) +C The leading M-by-N part of this array must contain the +C matrix to be printed. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= M. +C +C TEXT (input) CHARACTER*72. +C Title caption of the matrix to be printed (up to a +C maximum of 72 characters). For example, TEXT = 'Matrix A'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine first prints the contents of TEXT as a title, followed +C by the elements of the matrix A such that +C +C (i) if N <= L, the leading M-by-N part is printed; +C (ii) if N = k*L + p (where k,p > 0), then k M-by-L blocks of +C consecutive columns of A are printed one after another +C followed by one M-by-p block containing the last p columns +C of A. +C +C Row numbers are printed on the left of each row and a column +C number appears on top of each complex column. +C The routine uses 2 + (k + 1)*(m + 1) lines and 7 + 32*c positions +C per line where c is the actual number of columns, (i.e. c = L +C or c = p). +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1997. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Dec. 2008. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INFO, L, LDA, M, N, NOUT + CHARACTER*(*) TEXT +C .. Array Arguments .. + COMPLEX*16 A(LDA,*) +C .. Local Scalars .. + INTEGER I, J, J1, J2, JJ, LENTXT, LTEXT, N1 +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC LEN, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( M.LT.1 ) THEN + INFO = -1 + ELSE IF( N.LT.1 ) THEN + INFO = -2 + ELSE IF( L.LT.1 .OR. L.GT.3 ) THEN + INFO = -3 + ELSE IF( NOUT.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.M ) THEN + INFO = -6 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'UD01MZ', -INFO ) + RETURN + END IF +C + LENTXT = LEN( TEXT ) +C + DO 20 LTEXT = MIN( 72, LENTXT ), 2, -1 + IF ( TEXT(LTEXT:LTEXT).NE.' ' ) GO TO 40 + 20 CONTINUE +C + 40 CONTINUE + WRITE ( NOUT, FMT=99996 ) TEXT(1:LTEXT), M, N + N1 = ( N-1 )/L + J1 = 1 + J2 = L +C + DO 80 J = 1, N1 + WRITE ( NOUT, FMT=99999 ) ( JJ, JJ=J1, J2 ) +C + DO 60 I = 1, M + WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, J2 ) + 60 CONTINUE +C + WRITE ( NOUT, FMT=99998 ) + J1 = J1 + L + J2 = J2 + L + 80 CONTINUE +C + WRITE ( NOUT, FMT=99999 ) ( J, J=J1, N ) +C + DO 100 I = 1, M + WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, N ) + 100 CONTINUE +C + WRITE ( NOUT, FMT=99998 ) +C + RETURN +C +99999 FORMAT (7X,5(13X,I5,14X) ) +99998 FORMAT (' ' ) +99997 FORMAT (1X,I5,2X,3(D15.7,SP,D15.7,S,'i ') ) +99996 FORMAT (1X,A,' (',I5,'X',I5,')',/ ) +C *** Last line of UD01MZ *** + END diff --git a/mex/sources/libslicot/UD01ND.f b/mex/sources/libslicot/UD01ND.f new file mode 100644 index 000000000..1791f9865 --- /dev/null +++ b/mex/sources/libslicot/UD01ND.f @@ -0,0 +1,203 @@ + SUBROUTINE UD01ND( MP, NP, DP, L, NOUT, P, LDP1, LDP2, TEXT, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To print the MP-by-NP coefficient matrices of a matrix polynomial +C dp-1 dp +C P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s + P(dp) * s . +C +C The elements of the matrices are output to 7 significant figures. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C MP (input) INTEGER +C The number of rows of the matrix polynomial P(s). +C MP >= 1. +C +C NP (input) INTEGER +C The number of columns of the matrix polynomial P(s). +C NP >= 1. +C +C DP (input) INTEGER +C The degree of the matrix polynomial P(s). DP >= 0. +C +C L (input) INTEGER +C The number of elements of the coefficient matrices to be +C printed per line. 1 <= L <= 5. +C +C NOUT (input) INTEGER +C The output channel to which the results are sent. +C NOUT >= 0. +C +C P (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1) +C The leading MP-by-NP-by-(DP+1) part of this array must +C contain the coefficients of the matrix polynomial P(s). +C Specifically, P(i,j,k) must contain the coefficient of +C s**(k-1) of the polynomial which is the (i,j)-th element +C of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and +C k = 1,2,...,DP+1. +C +C LDP1 INTEGER +C The leading dimension of array P. LDP1 >= MP. +C +C LDP2 INTEGER +C The second dimension of array P. LDP2 >= NP. +C +C TEXT (input) CHARACTER*72 +C Title caption of the coefficient matrices to be printed. +C TEXT is followed by the degree of the coefficient matrix, +C within brackets. If TEXT = ' ', then the coefficient +C matrices are separated by an empty line. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C For i = 1, 2, ..., DP + 1 the routine first prints the contents of +C TEXT followed by (i-1) as a title, followed by the elements of the +C MP-by-NP coefficient matrix P(i) such that +C (i) if NP < L, then the leading MP-by-NP part is printed; +C (ii) if NP = k*L + p (where k, p > 0), then k MP-by-L blocks of +C consecutive columns of P(i) are printed one after another +C followed by one MP-by-p block containing the last p columns +C of P(i). +C Row numbers are printed on the left of each row and a column +C number on top of each column. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C Based on routine PRMAPO by A.J. Geurts, Eindhoven University of +C Technology, Holland. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER DP, INFO, L, LDP1, LDP2, MP, NP, NOUT + CHARACTER*(*) TEXT +C .. Array Arguments .. + DOUBLE PRECISION P(LDP1,LDP2,*) +C .. Local Scalars .. + INTEGER I, J, J1, J2, JJ, K, LENTXT, LTEXT, N1 +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC LEN, MIN +C +C .. Executable Statements .. +C + INFO = 0 +C +C Check the input scalar arguments. +C + IF( MP.LT.1 ) THEN + INFO = -1 + ELSE IF( NP.LT.1 ) THEN + INFO = -2 + ELSE IF( DP.LT.0 ) THEN + INFO = -3 + ELSE IF( L.LT.1 .OR. L.GT.5 ) THEN + INFO = -4 + ELSE IF( NOUT.LT.0 ) THEN + INFO = -5 + ELSE IF( LDP1.LT.MP ) THEN + INFO = -7 + ELSE IF( LDP2.LT.NP ) THEN + INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'UD01ND', -INFO ) + RETURN + END IF +C + LENTXT = LEN( TEXT ) + LTEXT = MIN( 72, LENTXT ) +C WHILE ( TEXT(LTEXT:LTEXT) = ' ' ) DO + 10 IF ( TEXT(LTEXT:LTEXT).EQ.' ' ) THEN + LTEXT = LTEXT - 1 + GO TO 10 + END IF +C END WHILE 10 +C + DO 50 K = 1, DP + 1 + IF ( LTEXT.EQ.0 ) THEN + WRITE ( NOUT, FMT = 99999 ) + ELSE + WRITE ( NOUT, FMT = 99998 ) TEXT(1:LTEXT), K - 1, MP, NP + END IF + N1 = ( NP - 1 )/L + J1 = 1 + J2 = L +C + DO 30 J = 1, N1 + WRITE ( NOUT, FMT = 99997 ) ( JJ, JJ = J1, J2 ) +C + DO 20 I = 1, MP + WRITE ( NOUT, FMT = 99996 ) I, ( P(I,JJ,K), JJ = J1, J2 ) + 20 CONTINUE +C + J1 = J1 + L + J2 = J2 + L + 30 CONTINUE +C + WRITE ( NOUT, FMT = 99997 ) ( J, J = J1, NP ) +C + DO 40 I = 1, MP + WRITE ( NOUT, FMT = 99996 ) I, ( P(I,JJ,K), JJ = J1, NP ) + 40 CONTINUE +C + 50 CONTINUE +C + WRITE ( NOUT, FMT = 99999 ) +C + RETURN +C +99999 FORMAT (' ') +99998 FORMAT (/, 1X, A, '(', I2, ')', ' (', I2, 'X', I2, ')') +99997 FORMAT (5X, 5(6X, I2, 7X)) +99996 FORMAT (1X, I2, 2X, 5D15.7) +C +C *** Last line of UD01ND *** + END diff --git a/mex/sources/libslicot/UE01MD.f b/mex/sources/libslicot/UE01MD.f new file mode 100644 index 000000000..c460bf9bf --- /dev/null +++ b/mex/sources/libslicot/UE01MD.f @@ -0,0 +1,266 @@ + INTEGER FUNCTION UE01MD( ISPEC, NAME, OPTS, N1, N2, N3 ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To provide an extension of the LAPACK routine ILAENV to +C machine-specific parameters for SLICOT routines. +C +C The default values in this version aim to give good performance on +C a wide range of computers. For optimal performance, however, the +C user is advised to modify this routine. Note that an optimized +C BLAS is a crucial prerequisite for any speed gains. For further +C details, see ILAENV. +C +C FUNCTION VALUE +C +C UE01MD INTEGER +C The function value set according to ISPEC. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C ISPEC (input) INTEGER +C Specifies the parameter to be returned as the value of +C UE01MD, as follows: +C = 1: the optimal blocksize; if the returned value is 1, an +C unblocked algorithm will give the best performance; +C = 2: the minimum block size for which the block routine +C should be used; if the usable block size is less than +C this value, an unblocked routine should be used; +C = 3: the crossover point (in a block routine, for N less +C than this value, an unblocked routine should be used) +C = 4: the number of shifts, used in the product eigenvalue +C routine; +C = 8: the crossover point for the multishift QR method for +C product eigenvalue problems. +C +C NAME (input) CHARACTER*(*) +C The name of the calling subroutine, in either upper case +C or lower case. +C +C OPTS (input) CHARACTER*(*) +C The character options to the subroutine NAME, concatenated +C into a single character string. +C +C N1 (input) INTEGER +C N2 (input) INTEGER +C N3 (input) INTEGER +C Problem dimensions for the subroutine NAME; these may not +C all be required. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine ILAHAP). +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, N1, N2, N3 +C +C .. Local Scalars .. + LOGICAL CNAME, SNAME + CHARACTER*1 C1, C3 + CHARACTER*2 C2 + CHARACTER*6 SUBNAM + INTEGER I, IC, IZ, NB, NBMIN, NX +C .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +C .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, MAX +C +C .. Executable Statements .. +C + IF ( ISPEC.EQ.1 .OR. ISPEC.EQ.2 .OR. ISPEC.EQ.3 ) THEN +C +C Convert NAME to upper case if the first character is lower +C case. +C + UE01MD = 1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1:1 ) ) + IZ = ICHAR( 'Z' ) + IF ( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +C +C ASCII character set. +C + IF ( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1:1 ) = CHAR( IC-32 ) + DO 10 I = 2, 6 + IC = ICHAR( SUBNAM( I:I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I:I ) = CHAR( IC-32 ) + 10 CONTINUE + END IF +C + ELSE IF ( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +C +C EBCDIC character set. +C + IF ( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1:1 ) = CHAR( IC+64 ) + DO 20 I = 2, 6 + IC = ICHAR( SUBNAM( I:I ) ) + IF ( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) + $ SUBNAM( I:I ) = CHAR( IC+64 ) + 20 CONTINUE + END IF +C + ELSE IF ( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +C +C Prime machines: ASCII+128. +C + IF ( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1:1 ) = CHAR( IC-32 ) + DO 30 I = 2, 6 + IC = ICHAR( SUBNAM( I:I ) ) + IF ( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I:I ) = CHAR( IC-32 ) + 30 CONTINUE + END IF + END IF +C + C1 = SUBNAM( 1:1 ) + SNAME = C1.EQ.'S' .OR. C1.EQ.'D' + CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' + IF ( .NOT.( CNAME .OR. SNAME ) ) + $ RETURN + C2 = SUBNAM( 4:5 ) + C3 = SUBNAM( 6:6 ) +C + IF ( ISPEC.EQ.1 ) THEN +C +C Block size. +C + NB = 1 + IF ( C2.EQ.'4S' .OR. C2.EQ.'4T' ) THEN + IF ( C3.EQ.'B' ) THEN + NB = ILAENV( 1, 'DGEQRF', ' ', N1, N2, -1, -1 ) / 2 + ELSE IF ( C3.EQ.'T' ) THEN + NB = ILAENV( 1, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 4 + END IF + ELSE IF ( C2.EQ.'4P' ) THEN + IF ( C3.EQ.'B' ) THEN + NB = ILAENV( 1, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 + END IF + ELSE IF ( C2.EQ.'4W' .OR. C2.EQ.'4Q' ) THEN + IF ( C3.EQ.'D' ) THEN + NB = ILAENV( 1, 'DORGQR', ' ', N1, N2, N3, -1 ) / 2 + ELSE IF ( C3.EQ.'B' ) THEN + NB = ILAENV( 1, 'DORMQR', ' ', N1, N2, N3, -1 ) / 2 + END IF +** ELSE IF ( C2.EQ.'SH' ) THEN +** IF ( C3.EQ.'PVB' ) THEN +** NB = ILAENV( 1, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 +** END IF + END IF + UE01MD = NB + ELSE IF ( ISPEC.EQ.2 ) THEN +C +C Minimum block size. +C + NBMIN = 2 + IF ( C2.EQ.'4S' .OR. C2.EQ.'4T' ) THEN + IF ( C3.EQ.'B' ) THEN + NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', N1, N2, -1, + $ -1 ) / 2 ) + ELSE IF ( C3.EQ.'T' ) THEN + NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N1, N2, N1, + $ -1 ) / 4 ) + END IF + ELSE IF ( C2.EQ.'4P' ) THEN + IF ( C3.EQ.'B' ) THEN + NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N1, N2, N1, + $ -1 ) / 4 ) + END IF + ELSE IF ( C2.EQ.'4W' .OR. C2.EQ.'4Q' ) THEN + IF ( C3.EQ.'D' ) THEN + NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', N1, N2, N3, + $ -1 ) / 2 ) + ELSE IF ( C3.EQ.'B' ) THEN + NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', ' ', N1, N2, N3, + $ -1 ) / 2 ) + END IF +** ELSE IF ( C2.EQ.'SH' ) THEN +** IF ( C3.EQ.'PVB' ) THEN +** NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N1, N2, N1, +** $ -1 ) / 4 ) +** END IF + END IF + UE01MD = NBMIN + ELSE IF ( ISPEC.EQ.3 ) THEN +C +C Crossover point. +C + NX = 0 + IF ( C2.EQ.'4S' .OR. C2.EQ.'4T' ) THEN + IF ( C3.EQ.'B' ) THEN + NX = ILAENV( 3, 'DGEQRF', ' ', N1, N2, -1, -1 ) + ELSE IF ( C3.EQ.'T' ) THEN + NX = ILAENV( 3, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 + END IF + ELSE IF ( C2.EQ.'4P' ) THEN + IF ( C3.EQ.'B' ) THEN + NX = ILAENV( 3, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 + END IF + ELSE IF ( C2.EQ.'4W' .OR. C2.EQ.'4Q' ) THEN + IF ( C3.EQ.'D' ) THEN + NX = ILAENV( 3, 'DORGQR', ' ', N1, N2, N3, -1 ) + ELSE IF ( C3.EQ.'B' ) THEN + NX = ILAENV( 3, 'DORGQR', ' ', N1, N2, N3, -1 ) + END IF +** ELSE IF ( C2.EQ.'SH' ) THEN +** IF ( C3.EQ.'PVB' ) THEN +** NX = ILAENV( 3, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 +** END IF + END IF + UE01MD = NX + END IF + ELSE IF ( ISPEC.EQ.4 ) THEN +C +C Number of shifts (used by MB03XP). +C + UE01MD = ILAENV( 4, 'DHSEQR', OPTS, N1, N2, N3, -1 ) + ELSE IF ( ISPEC.EQ.8 ) THEN +C +C Crossover point for multishift (used by MB03XP). +C + UE01MD = ILAENV( 8, 'DHSEQR', OPTS, N1, N2, N3, -1 ) + ELSE +C +C Invalid value for ISPEC. +C + UE01MD = -1 + END IF + RETURN +C *** Last line of UE01MD *** + END diff --git a/mex/sources/libslicot/dcabs1.f b/mex/sources/libslicot/dcabs1.f new file mode 100644 index 000000000..c4acbeb5a --- /dev/null +++ b/mex/sources/libslicot/dcabs1.f @@ -0,0 +1,16 @@ + DOUBLE PRECISION FUNCTION DCABS1(Z) +* .. Scalar Arguments .. + DOUBLE COMPLEX Z +* .. +* .. +* Purpose +* ======= +* +* DCABS1 computes absolute value of a double complex number +* +* .. Intrinsic Functions .. + INTRINSIC ABS,DBLE,DIMAG +* + DCABS1 = ABS(DBLE(Z)) + ABS(DIMAG(Z)) + RETURN + END diff --git a/mex/sources/libslicot/delctg.f b/mex/sources/libslicot/delctg.f new file mode 100644 index 000000000..b6b44b7c8 --- /dev/null +++ b/mex/sources/libslicot/delctg.f @@ -0,0 +1,27 @@ + LOGICAL FUNCTION DELCTG( PAR1, PAR2, PAR3 ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C Void logical function for DGGES. +C + DOUBLE PRECISION PAR1, PAR2, PAR3 +C + DELCTG = .TRUE. + RETURN + END diff --git a/mex/sources/libslicot/dhgeqz.f b/mex/sources/libslicot/dhgeqz.f new file mode 100644 index 000000000..2269451e1 --- /dev/null +++ b/mex/sources/libslicot/dhgeqz.f @@ -0,0 +1,1249 @@ + SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, + $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, + $ LWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ, JOB + INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), + $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), + $ WORK( * ), Z( LDZ, * ) +* .. +* +* Purpose +* ======= +* +* DHGEQZ computes the eigenvalues of a real matrix pair (H,T), +* where H is an upper Hessenberg matrix and T is upper triangular, +* using the double-shift QZ method. +* Matrix pairs of this type are produced by the reduction to +* generalized upper Hessenberg form of a real matrix pair (A,B): +* +* A = Q1*H*Z1**T, B = Q1*T*Z1**T, +* +* as computed by DGGHRD. +* +* If JOB='S', then the Hessenberg-triangular pair (H,T) is +* also reduced to generalized Schur form, +* +* H = Q*S*Z**T, T = Q*P*Z**T, +* +* where Q and Z are orthogonal matrices, P is an upper triangular +* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 +* diagonal blocks. +* +* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair +* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of +* eigenvalues. +* +* Additionally, the 2-by-2 upper triangular diagonal blocks of P +* corresponding to 2-by-2 blocks of S are reduced to positive diagonal +* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, +* P(j,j) > 0, and P(j+1,j+1) > 0. +* +* Optionally, the orthogonal matrix Q from the generalized Schur +* factorization may be postmultiplied into an input matrix Q1, and the +* orthogonal matrix Z may be postmultiplied into an input matrix Z1. +* If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced +* the matrix pair (A,B) to generalized upper Hessenberg form, then the +* output matrices Q1*Q and Z1*Z are the orthogonal factors from the +* generalized Schur factorization of (A,B): +* +* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. +* +* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, +* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is +* complex and beta real. +* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the +* generalized nonsymmetric eigenvalue problem (GNEP) +* A*x = lambda*B*x +* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the +* alternate form of the GNEP +* mu*A*y = B*y. +* Real eigenvalues can be read directly from the generalized Schur +* form: +* alpha = S(i,i), beta = P(i,i). +* +* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix +* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), +* pp. 241--256. +* +* Arguments +* ========= +* +* JOB (input) CHARACTER*1 +* = 'E': Compute eigenvalues only; +* = 'S': Compute eigenvalues and the Schur form. +* +* COMPQ (input) CHARACTER*1 +* = 'N': Left Schur vectors (Q) are not computed; +* = 'I': Q is initialized to the unit matrix and the matrix Q +* of left Schur vectors of (H,T) is returned; +* = 'V': Q must contain an orthogonal matrix Q1 on entry and +* the product Q1*Q is returned. +* +* COMPZ (input) CHARACTER*1 +* = 'N': Right Schur vectors (Z) are not computed; +* = 'I': Z is initialized to the unit matrix and the matrix Z +* of right Schur vectors of (H,T) is returned; +* = 'V': Z must contain an orthogonal matrix Z1 on entry and +* the product Z1*Z is returned. +* +* N (input) INTEGER +* The order of the matrices H, T, Q, and Z. N >= 0. +* +* ILO (input) INTEGER +* IHI (input) INTEGER +* ILO and IHI mark the rows and columns of H which are in +* Hessenberg form. It is assumed that A is already upper +* triangular in rows and columns 1:ILO-1 and IHI+1:N. +* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. +* +* H (input/output) DOUBLE PRECISION array, dimension (LDH, N) +* On entry, the N-by-N upper Hessenberg matrix H. +* On exit, if JOB = 'S', H contains the upper quasi-triangular +* matrix S from the generalized Schur factorization; +* 2-by-2 diagonal blocks (corresponding to complex conjugate +* pairs of eigenvalues) are returned in standard form, with +* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. +* If JOB = 'E', the diagonal blocks of H match those of S, but +* the rest of H is unspecified. +* +* LDH (input) INTEGER +* The leading dimension of the array H. LDH >= max( 1, N ). +* +* T (input/output) DOUBLE PRECISION array, dimension (LDT, N) +* On entry, the N-by-N upper triangular matrix T. +* On exit, if JOB = 'S', T contains the upper triangular +* matrix P from the generalized Schur factorization; +* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S +* are reduced to positive diagonal form, i.e., if H(j+1,j) is +* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and +* T(j+1,j+1) > 0. +* If JOB = 'E', the diagonal blocks of T match those of P, but +* the rest of T is unspecified. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max( 1, N ). +* +* ALPHAR (output) DOUBLE PRECISION array, dimension (N) +* The real parts of each scalar alpha defining an eigenvalue +* of GNEP. +* +* ALPHAI (output) DOUBLE PRECISION array, dimension (N) +* The imaginary parts of each scalar alpha defining an +* eigenvalue of GNEP. +* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if +* positive, then the j-th and (j+1)-st eigenvalues are a +* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). +* +* BETA (output) DOUBLE PRECISION array, dimension (N) +* The scalars beta that define the eigenvalues of GNEP. +* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and +* beta = BETA(j) represent the j-th eigenvalue of the matrix +* pair (A,B), in one of the forms lambda = alpha/beta or +* mu = beta/alpha. Since either lambda or mu may overflow, +* they should not, in general, be computed. +* +* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) +* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in +* the reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur +* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix +* of left Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. +* +* LDQ (input) INTEGER +* The leading dimension of the array Q. LDQ >= 1. +* If COMPQ='V' or 'I', then LDQ >= N. +* +* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) +* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in +* the reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the orthogonal matrix of +* right Schur vectors of (H,T), and if COMPZ = 'V', the +* orthogonal matrix of right Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. +* +* LDZ (input) INTEGER +* The leading dimension of the array Z. LDZ >= 1. +* If COMPZ='V' or 'I', then LDZ >= N. +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= max(1,N). +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* = 1,...,N: the QZ iteration did not converge. (H,T) is not +* in Schur form, but ALPHAR(i), ALPHAI(i), and +* BETA(i), i=INFO+1,...,N should be correct. +* = N+1,...,2*N: the shift calculation failed. (H,T) is not +* in Schur form, but ALPHAR(i), ALPHAI(i), and +* BETA(i), i=INFO-N+1,...,N should be correct. +* +* Further Details +* =============== +* +* Iteration counters: +* +* JITER -- counts iterations. +* IITER -- counts iterations run since ILAST was last +* changed. This is therefore reset only when a 1-by-1 or +* 2-by-2 block deflates off the bottom. +* +* ===================================================================== +* +* .. Parameters .. +* $ SAFETY = 1.0E+0 ) + DOUBLE PRECISION HALF, ZERO, ONE, SAFETY + PARAMETER ( HALF = 0.5D+0, ZERO = 0.0D+0, ONE = 1.0D+0, + $ SAFETY = 1.0D+2 ) +* .. +* .. Local Scalars .. + LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ, + $ LQUERY + INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST, + $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER, + $ JR, MAXIT + DOUBLE PRECISION A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11, + $ AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L, + $ AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I, + $ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE, + $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, + $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, + $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1, + $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, + $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, + $ WR2 +* .. +* .. Local Arrays .. + DOUBLE PRECISION V( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANHS, DLAPY2, DLAPY3 + EXTERNAL LSAME, DLAMCH, DLANHS, DLAPY2, DLAPY3 +* .. +* .. External Subroutines .. + EXTERNAL DLAG2, DLARFG, DLARTG, DLASET, DLASV2, DROT, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Decode JOB, COMPQ, COMPZ +* + IF( LSAME( JOB, 'E' ) ) THEN + ILSCHR = .FALSE. + ISCHUR = 1 + ELSE IF( LSAME( JOB, 'S' ) ) THEN + ILSCHR = .TRUE. + ISCHUR = 2 + ELSE + ISCHUR = 0 + END IF +* + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'V' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +* + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'V' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF +* +* Check Argument Values +* + INFO = 0 + WORK( 1 ) = MAX( 1, N ) + LQUERY = ( LWORK.EQ.-1 ) + IF( ISCHUR.EQ.0 ) THEN + INFO = -1 + ELSE IF( ICOMPQ.EQ.0 ) THEN + INFO = -2 + ELSE IF( ICOMPZ.EQ.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( ILO.LT.1 ) THEN + INFO = -5 + ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN + INFO = -6 + ELSE IF( LDH.LT.N ) THEN + INFO = -8 + ELSE IF( LDT.LT.N ) THEN + INFO = -10 + ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN + INFO = -15 + ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN + INFO = -17 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -19 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DHGEQZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + WORK( 1 ) = DBLE( 1 ) + RETURN + END IF +* +* Initialize Q and Z +* + IF( ICOMPQ.EQ.3 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) + IF( ICOMPZ.EQ.3 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +* +* Machine Constants +* + IN = IHI + 1 - ILO + SAFMIN = DLAMCH( 'S' ) + SAFMAX = ONE / SAFMIN + ULP = DLAMCH( 'E' )*DLAMCH( 'B' ) + ANORM = DLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK ) + BNORM = DLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK ) + ATOL = MAX( SAFMIN, ULP*ANORM ) + BTOL = MAX( SAFMIN, ULP*BNORM ) + ASCALE = ONE / MAX( SAFMIN, ANORM ) + BSCALE = ONE / MAX( SAFMIN, BNORM ) +* +* Set Eigenvalues IHI+1:N +* + DO 30 J = IHI + 1, N + IF( T( J, J ).LT.ZERO ) THEN + IF( ILSCHR ) THEN + DO 10 JR = 1, J + H( JR, J ) = -H( JR, J ) + T( JR, J ) = -T( JR, J ) + 10 CONTINUE + ELSE + H( J, J ) = -H( J, J ) + T( J, J ) = -T( J, J ) + END IF + IF( ILZ ) THEN + DO 20 JR = 1, N + Z( JR, J ) = -Z( JR, J ) + 20 CONTINUE + END IF + END IF + ALPHAR( J ) = H( J, J ) + ALPHAI( J ) = ZERO + BETA( J ) = T( J, J ) + 30 CONTINUE +* +* If IHI < ILO, skip QZ steps +* + IF( IHI.LT.ILO ) + $ GO TO 380 +* +* MAIN QZ ITERATION LOOP +* +* Initialize dynamic indices +* +* Eigenvalues ILAST+1:N have been found. +* Column operations modify rows IFRSTM:whatever. +* Row operations modify columns whatever:ILASTM. +* +* If only eigenvalues are being computed, then +* IFRSTM is the row of the last splitting row above row ILAST; +* this is always at least ILO. +* IITER counts iterations since the last eigenvalue was found, +* to tell when to use an extraordinary shift. +* MAXIT is the maximum number of QZ sweeps allowed. +* + ILAST = IHI + IF( ILSCHR ) THEN + IFRSTM = 1 + ILASTM = N + ELSE + IFRSTM = ILO + ILASTM = IHI + END IF + IITER = 0 + ESHIFT = ZERO + MAXIT = 30*( IHI-ILO+1 ) +* + DO 360 JITER = 1, MAXIT +* +* Split the matrix if possible. +* +* Two tests: +* 1: H(j,j-1)=0 or j=ILO +* 2: T(j,j)=0 +* + IF( ILAST.EQ.ILO ) THEN +* +* Special case: j=ILAST +* + GO TO 80 + ELSE + IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN + H( ILAST, ILAST-1 ) = ZERO + GO TO 80 + END IF + END IF +* + IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN + T( ILAST, ILAST ) = ZERO + GO TO 70 + END IF +* +* General case: j unfl ) +* __ +* (sA - wB) ( CZ -SZ ) +* ( SZ CZ ) +* + C11R = S1*A11 - WR*B11 + C11I = -WI*B11 + C12 = S1*A12 + C21 = S1*A21 + C22R = S1*A22 - WR*B22 + C22I = -WI*B22 +* + IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+ + $ ABS( C22R )+ABS( C22I ) ) THEN + T1 = DLAPY3( C12, C11R, C11I ) + CZ = C12 / T1 + SZR = -C11R / T1 + SZI = -C11I / T1 + ELSE + CZ = DLAPY2( C22R, C22I ) + IF( CZ.LE.SAFMIN ) THEN + CZ = ZERO + SZR = ONE + SZI = ZERO + ELSE + TEMPR = C22R / CZ + TEMPI = C22I / CZ + T1 = DLAPY2( CZ, C21 ) + CZ = CZ / T1 + SZR = -C21*TEMPR / T1 + SZI = C21*TEMPI / T1 + END IF + END IF +* +* Compute Givens rotation on left +* +* ( CQ SQ ) +* ( __ ) A or B +* ( -SQ CQ ) +* + AN = ABS( A11 ) + ABS( A12 ) + ABS( A21 ) + ABS( A22 ) + BN = ABS( B11 ) + ABS( B22 ) + WABS = ABS( WR ) + ABS( WI ) + IF( S1*AN.GT.WABS*BN ) THEN + CQ = CZ*B11 + SQR = SZR*B22 + SQI = -SZI*B22 + ELSE + A1R = CZ*A11 + SZR*A12 + A1I = SZI*A12 + A2R = CZ*A21 + SZR*A22 + A2I = SZI*A22 + CQ = DLAPY2( A1R, A1I ) + IF( CQ.LE.SAFMIN ) THEN + CQ = ZERO + SQR = ONE + SQI = ZERO + ELSE + TEMPR = A1R / CQ + TEMPI = A1I / CQ + SQR = TEMPR*A2R + TEMPI*A2I + SQI = TEMPI*A2R - TEMPR*A2I + END IF + END IF + T1 = DLAPY3( CQ, SQR, SQI ) + CQ = CQ / T1 + SQR = SQR / T1 + SQI = SQI / T1 +* +* Compute diagonal elements of QBZ +* + TEMPR = SQR*SZR - SQI*SZI + TEMPI = SQR*SZI + SQI*SZR + B1R = CQ*CZ*B11 + TEMPR*B22 + B1I = TEMPI*B22 + B1A = DLAPY2( B1R, B1I ) + B2R = CQ*CZ*B22 + TEMPR*B11 + B2I = -TEMPI*B11 + B2A = DLAPY2( B2R, B2I ) +* +* Normalize so beta > 0, and Im( alpha1 ) > 0 +* + BETA( ILAST-1 ) = B1A + BETA( ILAST ) = B2A + ALPHAR( ILAST-1 ) = ( WR*B1A )*S1INV + ALPHAI( ILAST-1 ) = ( WI*B1A )*S1INV + ALPHAR( ILAST ) = ( WR*B2A )*S1INV + ALPHAI( ILAST ) = -( WI*B2A )*S1INV +* +* Step 3: Go to next block -- exit if finished. +* + ILAST = IFIRST - 1 + IF( ILAST.LT.ILO ) + $ GO TO 380 +* +* Reset counters +* + IITER = 0 + ESHIFT = ZERO + IF( .NOT.ILSCHR ) THEN + ILASTM = ILAST + IF( IFRSTM.GT.ILAST ) + $ IFRSTM = ILO + END IF + GO TO 350 + ELSE +* +* Usual case: 3x3 or larger block, using Francis implicit +* double-shift +* +* 2 +* Eigenvalue equation is w - c w + d = 0, +* +* -1 2 -1 +* so compute 1st column of (A B ) - c A B + d +* using the formula in QZIT (from EISPACK) +* +* We assume that the block is at least 3x3 +* + AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + AD22 = ( ASCALE*H( ILAST, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST ) + AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) / + $ ( BSCALE*T( IFIRST, IFIRST ) ) + AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) / + $ ( BSCALE*T( IFIRST, IFIRST ) ) + AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 ) +* + V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 + + $ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L + V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )- + $ ( AD22-AD11L )+AD21*U12 )*AD21L + V( 3 ) = AD32L*AD21L +* + ISTART = IFIRST +* + CALL DLARFG( 3, V( 1 ), V( 2 ), 1, TAU ) + V( 1 ) = ONE +* +* Sweep +* + DO 290 J = ISTART, ILAST - 2 +* +* All but last elements: use 3x3 Householder transforms. +* +* Zero (j-1)st column of A +* + IF( J.GT.ISTART ) THEN + V( 1 ) = H( J, J-1 ) + V( 2 ) = H( J+1, J-1 ) + V( 3 ) = H( J+2, J-1 ) +* + CALL DLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU ) + V( 1 ) = ONE + H( J+1, J-1 ) = ZERO + H( J+2, J-1 ) = ZERO + END IF +* + DO 230 JC = J, ILASTM + TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* + $ H( J+2, JC ) ) + H( J, JC ) = H( J, JC ) - TEMP + H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) + H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) + TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* + $ T( J+2, JC ) ) + T( J, JC ) = T( J, JC ) - TEMP2 + T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) + T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) + 230 CONTINUE + IF( ILQ ) THEN + DO 240 JR = 1, N + TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )* + $ Q( JR, J+2 ) ) + Q( JR, J ) = Q( JR, J ) - TEMP + Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 ) + Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 ) + 240 CONTINUE + END IF +* +* Zero j-th column of B (see DLAGBC for details) +* +* Swap rows to pivot +* + ILPIVT = .FALSE. + TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) ) + TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) ) + IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN + SCALE = ZERO + U1 = ONE + U2 = ZERO + GO TO 250 + ELSE IF( TEMP.GE.TEMP2 ) THEN + W11 = T( J+1, J+1 ) + W21 = T( J+2, J+1 ) + W12 = T( J+1, J+2 ) + W22 = T( J+2, J+2 ) + U1 = T( J+1, J ) + U2 = T( J+2, J ) + ELSE + W21 = T( J+1, J+1 ) + W11 = T( J+2, J+1 ) + W22 = T( J+1, J+2 ) + W12 = T( J+2, J+2 ) + U2 = T( J+1, J ) + U1 = T( J+2, J ) + END IF +* +* Swap columns if nec. +* + IF( ABS( W12 ).GT.ABS( W11 ) ) THEN + ILPIVT = .TRUE. + TEMP = W12 + TEMP2 = W22 + W12 = W11 + W22 = W21 + W11 = TEMP + W21 = TEMP2 + END IF +* +* LU-factor +* + TEMP = W21 / W11 + U2 = U2 - TEMP*U1 + W22 = W22 - TEMP*W12 + W21 = ZERO +* +* Compute SCALE +* + SCALE = ONE + IF( ABS( W22 ).LT.SAFMIN ) THEN + SCALE = ZERO + U2 = ONE + U1 = -W12 / W11 + GO TO 250 + END IF + IF( ABS( W22 ).LT.ABS( U2 ) ) + $ SCALE = ABS( W22 / U2 ) + IF( ABS( W11 ).LT.ABS( U1 ) ) + $ SCALE = MIN( SCALE, ABS( W11 / U1 ) ) +* +* Solve +* + U2 = ( SCALE*U2 ) / W22 + U1 = ( SCALE*U1-W12*U2 ) / W11 +* + 250 CONTINUE + IF( ILPIVT ) THEN + TEMP = U2 + U2 = U1 + U1 = TEMP + END IF +* +* Compute Householder Vector +* + T1 = SQRT( SCALE**2+U1**2+U2**2 ) + TAU = ONE + SCALE / T1 + VS = -ONE / ( SCALE+T1 ) + V( 1 ) = ONE + V( 2 ) = VS*U1 + V( 3 ) = VS*U2 +* +* Apply transformations from the right. +* + DO 260 JR = IFRSTM, MIN( J+3, ILAST ) + TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* + $ H( JR, J+2 ) ) + H( JR, J ) = H( JR, J ) - TEMP + H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) + H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) + 260 CONTINUE + DO 270 JR = IFRSTM, J + 2 + TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* + $ T( JR, J+2 ) ) + T( JR, J ) = T( JR, J ) - TEMP + T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) + T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) + 270 CONTINUE + IF( ILZ ) THEN + DO 280 JR = 1, N + TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )* + $ Z( JR, J+2 ) ) + Z( JR, J ) = Z( JR, J ) - TEMP + Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 ) + Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) + 280 CONTINUE + END IF + T( J+1, J ) = ZERO + T( J+2, J ) = ZERO + 290 CONTINUE +* +* Last elements: Use Givens rotations +* +* Rotations from the left +* + J = ILAST - 1 + TEMP = H( J, J-1 ) + CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) + H( J+1, J-1 ) = ZERO +* + DO 300 JC = J, ILASTM + TEMP = C*H( J, JC ) + S*H( J+1, JC ) + H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) + H( J, JC ) = TEMP + TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) + T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) + T( J, JC ) = TEMP2 + 300 CONTINUE + IF( ILQ ) THEN + DO 310 JR = 1, N + TEMP = C*Q( JR, J ) + S*Q( JR, J+1 ) + Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 ) + Q( JR, J ) = TEMP + 310 CONTINUE + END IF +* +* Rotations from the right. +* + TEMP = T( J+1, J+1 ) + CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) + T( J+1, J ) = ZERO +* + DO 320 JR = IFRSTM, ILAST + TEMP = C*H( JR, J+1 ) + S*H( JR, J ) + H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) + H( JR, J+1 ) = TEMP + 320 CONTINUE + DO 330 JR = IFRSTM, ILAST - 1 + TEMP = C*T( JR, J+1 ) + S*T( JR, J ) + T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) + T( JR, J+1 ) = TEMP + 330 CONTINUE + IF( ILZ ) THEN + DO 340 JR = 1, N + TEMP = C*Z( JR, J+1 ) + S*Z( JR, J ) + Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J ) + Z( JR, J+1 ) = TEMP + 340 CONTINUE + END IF +* +* End of Double-Shift code +* + END IF +* + GO TO 350 +* +* End of iteration loop +* + 350 CONTINUE + 360 CONTINUE +* +* Drop-through = non-convergence +* + INFO = ILAST + GO TO 420 +* +* Successful completion of all QZ steps +* + 380 CONTINUE +* +* Set Eigenvalues 1:ILO-1 +* + DO 410 J = 1, ILO - 1 + IF( T( J, J ).LT.ZERO ) THEN + IF( ILSCHR ) THEN + DO 390 JR = 1, J + H( JR, J ) = -H( JR, J ) + T( JR, J ) = -T( JR, J ) + 390 CONTINUE + ELSE + H( J, J ) = -H( J, J ) + T( J, J ) = -T( J, J ) + END IF + IF( ILZ ) THEN + DO 400 JR = 1, N + Z( JR, J ) = -Z( JR, J ) + 400 CONTINUE + END IF + END IF + ALPHAR( J ) = H( J, J ) + ALPHAI( J ) = ZERO + BETA( J ) = T( J, J ) + 410 CONTINUE +* +* Normal Termination +* + INFO = 0 +* +* Exit (other than argument error) -- return optimal workspace size +* + 420 CONTINUE + WORK( 1 ) = DBLE( N ) + RETURN +* +* End of DHGEQZ +* + END diff --git a/mex/sources/libslicot/dtgsy2.f b/mex/sources/libslicot/dtgsy2.f new file mode 100644 index 000000000..3486ec482 --- /dev/null +++ b/mex/sources/libslicot/dtgsy2.f @@ -0,0 +1,956 @@ + SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, + $ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, + $ IWORK, PQ, INFO ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* January 2007. V. Sima, February 2009: added IWORK in former 640. +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N, + $ PQ + DOUBLE PRECISION RDSCAL, RDSUM, SCALE +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), E( LDE, * ), F( LDF, * ) +* .. +* +* Purpose +* ======= +* +* DTGSY2 solves the generalized Sylvester equation: +* +* A * R - L * B = scale * C (1) +* D * R - L * E = scale * F, +* +* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices, +* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, +* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E) +* must be in generalized Schur canonical form, i.e. A, B are upper +* quasi triangular and D, E are upper triangular. The solution (R, L) +* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor +* chosen to avoid overflow. +* +* In matrix notation solving equation (1) corresponds to solve +* Z*x = scale*b, where Z is defined as +* +* Z = [ kron(In, A) -kron(B', Im) ] (2) +* [ kron(In, D) -kron(E', Im) ], +* +* Ik is the identity matrix of size k and X' is the transpose of X. +* kron(X, Y) is the Kronecker product between the matrices X and Y. +* In the process of solving (1), we solve a number of such systems +* where Dim(In), Dim(In) = 1 or 2. +* +* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y, +* which is equivalent to solve for R and L in +* +* A' * R + D' * L = scale * C (3) +* R * B' + L * E' = scale * -F +* +* This case is used to compute an estimate of Dif[(A, D), (B, E)] = +* sigma_min(Z) using reverse communicaton with DLACON. +* +* DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL +* of an upper bound on the separation between to matrix pairs. Then +* the input (A, D), (B, E) are sub-pencils of the matrix pair in +* DTGSYL. See DTGSYL for details. +* +* Arguments +* ========= +* +* TRANS (input) CHARACTER*1 +* = 'N', solve the generalized Sylvester equation (1). +* = 'T': solve the 'transposed' system (3). +* +* IJOB (input) INTEGER +* Specifies what kind of functionality to be performed. +* = 0: solve (1) only. +* = 1: A contribution from this subsystem to a Frobenius +* norm-based estimate of the separation between two matrix +* pairs is computed. (look ahead strategy is used). +* = 2: A contribution from this subsystem to a Frobenius +* norm-based estimate of the separation between two matrix +* pairs is computed. (DGECON on sub-systems is used.) +* Not referenced if TRANS = 'T'. +* +* M (input) INTEGER +* On entry, M specifies the order of A and D, and the row +* dimension of C, F, R and L. +* +* N (input) INTEGER +* On entry, N specifies the order of B and E, and the column +* dimension of C, F, R and L. +* +* A (input) DOUBLE PRECISION array, dimension (LDA, M) +* On entry, A contains an upper quasi triangular matrix. +* +* LDA (input) INTEGER +* The leading dimension of the matrix A. LDA >= max(1, M). +* +* B (input) DOUBLE PRECISION array, dimension (LDB, N) +* On entry, B contains an upper quasi triangular matrix. +* +* LDB (input) INTEGER +* The leading dimension of the matrix B. LDB >= max(1, N). +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC, N) +* On entry, C contains the right-hand-side of the first matrix +* equation in (1). +* On exit, if IJOB = 0, C has been overwritten by the +* solution R. +* +* LDC (input) INTEGER +* The leading dimension of the matrix C. LDC >= max(1, M). +* +* D (input) DOUBLE PRECISION array, dimension (LDD, M) +* On entry, D contains an upper triangular matrix. +* +* LDD (input) INTEGER +* The leading dimension of the matrix D. LDD >= max(1, M). +* +* E (input) DOUBLE PRECISION array, dimension (LDE, N) +* On entry, E contains an upper triangular matrix. +* +* LDE (input) INTEGER +* The leading dimension of the matrix E. LDE >= max(1, N). +* +* F (input/output) DOUBLE PRECISION array, dimension (LDF, N) +* On entry, F contains the right-hand-side of the second matrix +* equation in (1). +* On exit, if IJOB = 0, F has been overwritten by the +* solution L. +* +* LDF (input) INTEGER +* The leading dimension of the matrix F. LDF >= max(1, M). +* +* SCALE (output) DOUBLE PRECISION +* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions +* R and L (C and F on entry) will hold the solutions to a +* slightly perturbed system but the input matrices A, B, D and +* E have not been changed. If SCALE = 0, R and L will hold the +* solutions to the homogeneous system with C = F = 0. Normally, +* SCALE = 1. +* +* RDSUM (input/output) DOUBLE PRECISION +* On entry, the sum of squares of computed contributions to +* the Dif-estimate under computation by DTGSYL, where the +* scaling factor RDSCAL (see below) has been factored out. +* On exit, the corresponding sum of squares updated with the +* contributions from the current sub-system. +* If TRANS = 'T' RDSUM is not touched. +* NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL. +* +* RDSCAL (input/output) DOUBLE PRECISION +* On entry, scaling factor used to prevent overflow in RDSUM. +* On exit, RDSCAL is updated w.r.t. the current contributions +* in RDSUM. +* If TRANS = 'T', RDSCAL is not touched. +* NOTE: RDSCAL only makes sense when DTGSY2 is called by +* DTGSYL. +* +* IWORK (workspace) INTEGER array, dimension (M+N+2) +* +* PQ (output) INTEGER +* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and +* 8-by-8) solved by this routine. +* +* INFO (output) INTEGER +* On exit, if INFO is set to +* =0: Successful exit +* <0: If INFO = -i, the i-th argument had an illegal value. +* >0: The matrix pairs (A, D) and (B, E) have common or very +* close eigenvalues. +* +* Further Details +* =============== +* +* Based on contributions by +* Bo Kagstrom and Peter Poromaa, Department of Computing Science, +* Umea University, S-901 87 Umea, Sweden. +* +* ===================================================================== +* Replaced various illegal calls to DCOPY by calls to DLASET. +* Sven Hammarling, 27/5/02. +* +* .. Parameters .. + INTEGER LDZ + PARAMETER ( LDZ = 8 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN + INTEGER I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1, + $ K, MB, NB, P, Q, ZDIM + DOUBLE PRECISION ALPHA, SCALOC +* .. +* .. Local Arrays .. + INTEGER IPIV( LDZ ), JPIV( LDZ ) + DOUBLE PRECISION RHS( LDZ ), Z( LDZ, LDZ ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGER, DGESC2, + $ DGETC2, DLASET, DLATDF, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Decode and test input parameters +* + INFO = 0 + IERR = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -1 + ELSE IF( NOTRAN ) THEN + IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN + INFO = -2 + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( M.LE.0 ) THEN + INFO = -3 + ELSE IF( N.LE.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, M ) ) THEN + INFO = -12 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -16 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTGSY2', -INFO ) + RETURN + END IF +* +* Determine block structure of A +* + PQ = 0 + P = 0 + I = 1 + 10 CONTINUE + IF( I.GT.M ) + $ GO TO 20 + P = P + 1 + IWORK( P ) = I + IF( I.EQ.M ) + $ GO TO 20 + IF( A( I+1, I ).NE.ZERO ) THEN + I = I + 2 + ELSE + I = I + 1 + END IF + GO TO 10 + 20 CONTINUE + IWORK( P+1 ) = M + 1 +* +* Determine block structure of B +* + Q = P + 1 + J = 1 + 30 CONTINUE + IF( J.GT.N ) + $ GO TO 40 + Q = Q + 1 + IWORK( Q ) = J + IF( J.EQ.N ) + $ GO TO 40 + IF( B( J+1, J ).NE.ZERO ) THEN + J = J + 2 + ELSE + J = J + 1 + END IF + GO TO 30 + 40 CONTINUE + IWORK( Q+1 ) = N + 1 + PQ = P*( Q-P-1 ) +* + IF( NOTRAN ) THEN +* +* Solve (I, J) - subsystem +* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) +* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) +* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q +* + SCALE = ONE + SCALOC = ONE + DO 120 J = P + 2, Q + JS = IWORK( J ) + JSP1 = JS + 1 + JE = IWORK( J+1 ) - 1 + NB = JE - JS + 1 + DO 110 I = P, 1, -1 +* + IS = IWORK( I ) + ISP1 = IS + 1 + IE = IWORK( I+1 ) - 1 + MB = IE - IS + 1 + ZDIM = MB*NB*2 +* + IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN +* +* Build a 2-by-2 system Z * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = D( IS, IS ) + Z( 1, 2 ) = -B( JS, JS ) + Z( 2, 2 ) = -E( JS, JS ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = F( IS, JS ) +* +* Solve Z * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR +* + IF( IJOB.EQ.0 ) THEN + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, + $ SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 50 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 50 CONTINUE + SCALE = SCALE*SCALOC + END IF + ELSE + CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, + $ RDSCAL, IPIV, JPIV ) + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + F( IS, JS ) = RHS( 2 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( I.GT.1 ) THEN + ALPHA = -RHS( 1 ) + CALL DAXPY( IS-1, ALPHA, A( 1, IS ), 1, C( 1, JS ), + $ 1 ) + CALL DAXPY( IS-1, ALPHA, D( 1, IS ), 1, F( 1, JS ), + $ 1 ) + END IF + IF( J.LT.Q ) THEN + CALL DAXPY( N-JE, RHS( 2 ), B( JS, JE+1 ), LDB, + $ C( IS, JE+1 ), LDC ) + CALL DAXPY( N-JE, RHS( 2 ), E( JS, JE+1 ), LDE, + $ F( IS, JE+1 ), LDF ) + END IF +* + ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN +* +* Build a 4-by-4 system Z * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = ZERO + Z( 3, 1 ) = D( IS, IS ) + Z( 4, 1 ) = ZERO +* + Z( 1, 2 ) = ZERO + Z( 2, 2 ) = A( IS, IS ) + Z( 3, 2 ) = ZERO + Z( 4, 2 ) = D( IS, IS ) +* + Z( 1, 3 ) = -B( JS, JS ) + Z( 2, 3 ) = -B( JS, JSP1 ) + Z( 3, 3 ) = -E( JS, JS ) + Z( 4, 3 ) = -E( JS, JSP1 ) +* + Z( 1, 4 ) = -B( JSP1, JS ) + Z( 2, 4 ) = -B( JSP1, JSP1 ) + Z( 3, 4 ) = ZERO + Z( 4, 4 ) = -E( JSP1, JSP1 ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = C( IS, JSP1 ) + RHS( 3 ) = F( IS, JS ) + RHS( 4 ) = F( IS, JSP1 ) +* +* Solve Z * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR +* + IF( IJOB.EQ.0 ) THEN + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, + $ SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 60 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 60 CONTINUE + SCALE = SCALE*SCALOC + END IF + ELSE + CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, + $ RDSCAL, IPIV, JPIV ) + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + C( IS, JSP1 ) = RHS( 2 ) + F( IS, JS ) = RHS( 3 ) + F( IS, JSP1 ) = RHS( 4 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( I.GT.1 ) THEN + CALL DGER( IS-1, NB, -ONE, A( 1, IS ), 1, RHS( 1 ), + $ 1, C( 1, JS ), LDC ) + CALL DGER( IS-1, NB, -ONE, D( 1, IS ), 1, RHS( 1 ), + $ 1, F( 1, JS ), LDF ) + END IF + IF( J.LT.Q ) THEN + CALL DAXPY( N-JE, RHS( 3 ), B( JS, JE+1 ), LDB, + $ C( IS, JE+1 ), LDC ) + CALL DAXPY( N-JE, RHS( 3 ), E( JS, JE+1 ), LDE, + $ F( IS, JE+1 ), LDF ) + CALL DAXPY( N-JE, RHS( 4 ), B( JSP1, JE+1 ), LDB, + $ C( IS, JE+1 ), LDC ) + CALL DAXPY( N-JE, RHS( 4 ), E( JSP1, JE+1 ), LDE, + $ F( IS, JE+1 ), LDF ) + END IF +* + ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN +* +* Build a 4-by-4 system Z * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = A( ISP1, IS ) + Z( 3, 1 ) = D( IS, IS ) + Z( 4, 1 ) = ZERO +* + Z( 1, 2 ) = A( IS, ISP1 ) + Z( 2, 2 ) = A( ISP1, ISP1 ) + Z( 3, 2 ) = D( IS, ISP1 ) + Z( 4, 2 ) = D( ISP1, ISP1 ) +* + Z( 1, 3 ) = -B( JS, JS ) + Z( 2, 3 ) = ZERO + Z( 3, 3 ) = -E( JS, JS ) + Z( 4, 3 ) = ZERO +* + Z( 1, 4 ) = ZERO + Z( 2, 4 ) = -B( JS, JS ) + Z( 3, 4 ) = ZERO + Z( 4, 4 ) = -E( JS, JS ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = C( ISP1, JS ) + RHS( 3 ) = F( IS, JS ) + RHS( 4 ) = F( ISP1, JS ) +* +* Solve Z * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR + IF( IJOB.EQ.0 ) THEN + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, + $ SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 70 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 70 CONTINUE + SCALE = SCALE*SCALOC + END IF + ELSE + CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, + $ RDSCAL, IPIV, JPIV ) + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + C( ISP1, JS ) = RHS( 2 ) + F( IS, JS ) = RHS( 3 ) + F( ISP1, JS ) = RHS( 4 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( I.GT.1 ) THEN + CALL DGEMV( 'N', IS-1, MB, -ONE, A( 1, IS ), LDA, + $ RHS( 1 ), 1, ONE, C( 1, JS ), 1 ) + CALL DGEMV( 'N', IS-1, MB, -ONE, D( 1, IS ), LDD, + $ RHS( 1 ), 1, ONE, F( 1, JS ), 1 ) + END IF + IF( J.LT.Q ) THEN + CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1, + $ B( JS, JE+1 ), LDB, C( IS, JE+1 ), LDC ) + CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1, + $ E( JS, JE+1 ), LDE, F( IS, JE+1 ), LDF ) + END IF +* + ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN +* +* Build an 8-by-8 system Z * x = RHS +* + CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = A( ISP1, IS ) + Z( 5, 1 ) = D( IS, IS ) +* + Z( 1, 2 ) = A( IS, ISP1 ) + Z( 2, 2 ) = A( ISP1, ISP1 ) + Z( 5, 2 ) = D( IS, ISP1 ) + Z( 6, 2 ) = D( ISP1, ISP1 ) +* + Z( 3, 3 ) = A( IS, IS ) + Z( 4, 3 ) = A( ISP1, IS ) + Z( 7, 3 ) = D( IS, IS ) +* + Z( 3, 4 ) = A( IS, ISP1 ) + Z( 4, 4 ) = A( ISP1, ISP1 ) + Z( 7, 4 ) = D( IS, ISP1 ) + Z( 8, 4 ) = D( ISP1, ISP1 ) +* + Z( 1, 5 ) = -B( JS, JS ) + Z( 3, 5 ) = -B( JS, JSP1 ) + Z( 5, 5 ) = -E( JS, JS ) + Z( 7, 5 ) = -E( JS, JSP1 ) +* + Z( 2, 6 ) = -B( JS, JS ) + Z( 4, 6 ) = -B( JS, JSP1 ) + Z( 6, 6 ) = -E( JS, JS ) + Z( 8, 6 ) = -E( JS, JSP1 ) +* + Z( 1, 7 ) = -B( JSP1, JS ) + Z( 3, 7 ) = -B( JSP1, JSP1 ) + Z( 7, 7 ) = -E( JSP1, JSP1 ) +* + Z( 2, 8 ) = -B( JSP1, JS ) + Z( 4, 8 ) = -B( JSP1, JSP1 ) + Z( 8, 8 ) = -E( JSP1, JSP1 ) +* +* Set up right hand side(s) +* + K = 1 + II = MB*NB + 1 + DO 80 JJ = 0, NB - 1 + CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 ) + CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 ) + K = K + MB + II = II + MB + 80 CONTINUE +* +* Solve Z * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR + IF( IJOB.EQ.0 ) THEN + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, + $ SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 90 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 90 CONTINUE + SCALE = SCALE*SCALOC + END IF + ELSE + CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, + $ RDSCAL, IPIV, JPIV ) + END IF +* +* Unpack solution vector(s) +* + K = 1 + II = MB*NB + 1 + DO 100 JJ = 0, NB - 1 + CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 ) + CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 ) + K = K + MB + II = II + MB + 100 CONTINUE +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( I.GT.1 ) THEN + CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, + $ A( 1, IS ), LDA, RHS( 1 ), MB, ONE, + $ C( 1, JS ), LDC ) + CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, + $ D( 1, IS ), LDD, RHS( 1 ), MB, ONE, + $ F( 1, JS ), LDF ) + END IF + IF( J.LT.Q ) THEN + K = MB*NB + 1 + CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ), + $ MB, B( JS, JE+1 ), LDB, ONE, + $ C( IS, JE+1 ), LDC ) + CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ), + $ MB, E( JS, JE+1 ), LDE, ONE, + $ F( IS, JE+1 ), LDF ) + END IF +* + END IF +* + 110 CONTINUE + 120 CONTINUE + ELSE +* +* Solve (I, J) - subsystem +* A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J) +* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) +* for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1 +* + SCALE = ONE + SCALOC = ONE + DO 200 I = 1, P +* + IS = IWORK( I ) + ISP1 = IS + 1 + IE = IWORK( I+1 ) - 1 + MB = IE - IS + 1 + DO 190 J = Q, P + 2, -1 +* + JS = IWORK( J ) + JSP1 = JS + 1 + JE = IWORK( J+1 ) - 1 + NB = JE - JS + 1 + ZDIM = MB*NB*2 + IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN +* +* Build a 2-by-2 system Z' * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = -B( JS, JS ) + Z( 1, 2 ) = D( IS, IS ) + Z( 2, 2 ) = -E( JS, JS ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = F( IS, JS ) +* +* Solve Z' * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR +* + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 130 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 130 CONTINUE + SCALE = SCALE*SCALOC + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + F( IS, JS ) = RHS( 2 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( J.GT.P+2 ) THEN + ALPHA = RHS( 1 ) + CALL DAXPY( JS-1, ALPHA, B( 1, JS ), 1, F( IS, 1 ), + $ LDF ) + ALPHA = RHS( 2 ) + CALL DAXPY( JS-1, ALPHA, E( 1, JS ), 1, F( IS, 1 ), + $ LDF ) + END IF + IF( I.LT.P ) THEN + ALPHA = -RHS( 1 ) + CALL DAXPY( M-IE, ALPHA, A( IS, IE+1 ), LDA, + $ C( IE+1, JS ), 1 ) + ALPHA = -RHS( 2 ) + CALL DAXPY( M-IE, ALPHA, D( IS, IE+1 ), LDD, + $ C( IE+1, JS ), 1 ) + END IF +* + ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN +* +* Build a 4-by-4 system Z' * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = ZERO + Z( 3, 1 ) = -B( JS, JS ) + Z( 4, 1 ) = -B( JSP1, JS ) +* + Z( 1, 2 ) = ZERO + Z( 2, 2 ) = A( IS, IS ) + Z( 3, 2 ) = -B( JS, JSP1 ) + Z( 4, 2 ) = -B( JSP1, JSP1 ) +* + Z( 1, 3 ) = D( IS, IS ) + Z( 2, 3 ) = ZERO + Z( 3, 3 ) = -E( JS, JS ) + Z( 4, 3 ) = ZERO +* + Z( 1, 4 ) = ZERO + Z( 2, 4 ) = D( IS, IS ) + Z( 3, 4 ) = -E( JS, JSP1 ) + Z( 4, 4 ) = -E( JSP1, JSP1 ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = C( IS, JSP1 ) + RHS( 3 ) = F( IS, JS ) + RHS( 4 ) = F( IS, JSP1 ) +* +* Solve Z' * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 140 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 140 CONTINUE + SCALE = SCALE*SCALOC + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + C( IS, JSP1 ) = RHS( 2 ) + F( IS, JS ) = RHS( 3 ) + F( IS, JSP1 ) = RHS( 4 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( J.GT.P+2 ) THEN + CALL DAXPY( JS-1, RHS( 1 ), B( 1, JS ), 1, + $ F( IS, 1 ), LDF ) + CALL DAXPY( JS-1, RHS( 2 ), B( 1, JSP1 ), 1, + $ F( IS, 1 ), LDF ) + CALL DAXPY( JS-1, RHS( 3 ), E( 1, JS ), 1, + $ F( IS, 1 ), LDF ) + CALL DAXPY( JS-1, RHS( 4 ), E( 1, JSP1 ), 1, + $ F( IS, 1 ), LDF ) + END IF + IF( I.LT.P ) THEN + CALL DGER( M-IE, NB, -ONE, A( IS, IE+1 ), LDA, + $ RHS( 1 ), 1, C( IE+1, JS ), LDC ) + CALL DGER( M-IE, NB, -ONE, D( IS, IE+1 ), LDD, + $ RHS( 3 ), 1, C( IE+1, JS ), LDC ) + END IF +* + ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN +* +* Build a 4-by-4 system Z' * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = A( IS, ISP1 ) + Z( 3, 1 ) = -B( JS, JS ) + Z( 4, 1 ) = ZERO +* + Z( 1, 2 ) = A( ISP1, IS ) + Z( 2, 2 ) = A( ISP1, ISP1 ) + Z( 3, 2 ) = ZERO + Z( 4, 2 ) = -B( JS, JS ) +* + Z( 1, 3 ) = D( IS, IS ) + Z( 2, 3 ) = D( IS, ISP1 ) + Z( 3, 3 ) = -E( JS, JS ) + Z( 4, 3 ) = ZERO +* + Z( 1, 4 ) = ZERO + Z( 2, 4 ) = D( ISP1, ISP1 ) + Z( 3, 4 ) = ZERO + Z( 4, 4 ) = -E( JS, JS ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = C( ISP1, JS ) + RHS( 3 ) = F( IS, JS ) + RHS( 4 ) = F( ISP1, JS ) +* +* Solve Z' * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR +* + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 150 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 150 CONTINUE + SCALE = SCALE*SCALOC + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + C( ISP1, JS ) = RHS( 2 ) + F( IS, JS ) = RHS( 3 ) + F( ISP1, JS ) = RHS( 4 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( J.GT.P+2 ) THEN + CALL DGER( MB, JS-1, ONE, RHS( 1 ), 1, B( 1, JS ), + $ 1, F( IS, 1 ), LDF ) + CALL DGER( MB, JS-1, ONE, RHS( 3 ), 1, E( 1, JS ), + $ 1, F( IS, 1 ), LDF ) + END IF + IF( I.LT.P ) THEN + CALL DGEMV( 'T', MB, M-IE, -ONE, A( IS, IE+1 ), + $ LDA, RHS( 1 ), 1, ONE, C( IE+1, JS ), + $ 1 ) + CALL DGEMV( 'T', MB, M-IE, -ONE, D( IS, IE+1 ), + $ LDD, RHS( 3 ), 1, ONE, C( IE+1, JS ), + $ 1 ) + END IF +* + ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN +* +* Build an 8-by-8 system Z' * x = RHS +* + CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = A( IS, ISP1 ) + Z( 5, 1 ) = -B( JS, JS ) + Z( 7, 1 ) = -B( JSP1, JS ) +* + Z( 1, 2 ) = A( ISP1, IS ) + Z( 2, 2 ) = A( ISP1, ISP1 ) + Z( 6, 2 ) = -B( JS, JS ) + Z( 8, 2 ) = -B( JSP1, JS ) +* + Z( 3, 3 ) = A( IS, IS ) + Z( 4, 3 ) = A( IS, ISP1 ) + Z( 5, 3 ) = -B( JS, JSP1 ) + Z( 7, 3 ) = -B( JSP1, JSP1 ) +* + Z( 3, 4 ) = A( ISP1, IS ) + Z( 4, 4 ) = A( ISP1, ISP1 ) + Z( 6, 4 ) = -B( JS, JSP1 ) + Z( 8, 4 ) = -B( JSP1, JSP1 ) +* + Z( 1, 5 ) = D( IS, IS ) + Z( 2, 5 ) = D( IS, ISP1 ) + Z( 5, 5 ) = -E( JS, JS ) +* + Z( 2, 6 ) = D( ISP1, ISP1 ) + Z( 6, 6 ) = -E( JS, JS ) +* + Z( 3, 7 ) = D( IS, IS ) + Z( 4, 7 ) = D( IS, ISP1 ) + Z( 5, 7 ) = -E( JS, JSP1 ) + Z( 7, 7 ) = -E( JSP1, JSP1 ) +* + Z( 4, 8 ) = D( ISP1, ISP1 ) + Z( 6, 8 ) = -E( JS, JSP1 ) + Z( 8, 8 ) = -E( JSP1, JSP1 ) +* +* Set up right hand side(s) +* + K = 1 + II = MB*NB + 1 + DO 160 JJ = 0, NB - 1 + CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 ) + CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 ) + K = K + MB + II = II + MB + 160 CONTINUE +* +* +* Solve Z' * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR +* + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 170 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 170 CONTINUE + SCALE = SCALE*SCALOC + END IF +* +* Unpack solution vector(s) +* + K = 1 + II = MB*NB + 1 + DO 180 JJ = 0, NB - 1 + CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 ) + CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 ) + K = K + MB + II = II + MB + 180 CONTINUE +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( J.GT.P+2 ) THEN + CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, + $ C( IS, JS ), LDC, B( 1, JS ), LDB, ONE, + $ F( IS, 1 ), LDF ) + CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, + $ F( IS, JS ), LDF, E( 1, JS ), LDE, ONE, + $ F( IS, 1 ), LDF ) + END IF + IF( I.LT.P ) THEN + CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, + $ A( IS, IE+1 ), LDA, C( IS, JS ), LDC, + $ ONE, C( IE+1, JS ), LDC ) + CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, + $ D( IS, IE+1 ), LDD, F( IS, JS ), LDF, + $ ONE, C( IE+1, JS ), LDC ) + END IF +* + END IF +* + 190 CONTINUE + 200 CONTINUE +* + END IF + RETURN +* +* End of DTGSY2 +* + END diff --git a/mex/sources/libslicot/readme b/mex/sources/libslicot/readme new file mode 100644 index 000000000..85f5bce37 --- /dev/null +++ b/mex/sources/libslicot/readme @@ -0,0 +1,8 @@ +SLICOT Library Subdirectory src +------------------------------- + +SLICOT Library Subdirectory src contains all source files of the +SLICOT Library routines. The codes follow the Fortran 77 language +conventions. SLICOT routines make calls to the state-of-the-art +packages LAPACK (Linear Algebra Package) and BLAS (Basic Linear +Algebra Subprograms). diff --git a/mex/sources/libslicot/select.f b/mex/sources/libslicot/select.f new file mode 100644 index 000000000..dd3e62baf --- /dev/null +++ b/mex/sources/libslicot/select.f @@ -0,0 +1,27 @@ + LOGICAL FUNCTION SELECT( PAR1, PAR2 ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C Void logical function for DGEES. +C + DOUBLE PRECISION PAR1, PAR2 +C + SELECT = .TRUE. + RETURN + END